Mario LaRosa program delaying routine ESmemberNEMESIS@aol.com 03-16-03 ( : ) QB, PDS 1 1243 qdelay.bas ''' ' Qdelay v1.1, a pure QB, program delaying routine. ' ' Brought to you by... MARIO SOFT. ' ' (C)opyright 2002 ' ' Contact me at ESmemberNEMESIS@aol.com ' If you have any questions or comments concerning these routines. ' ' THIS PROGRAM MAY BE DISTRIBUTED FREELY AS PUBLIC DOMAIN SOFTWARE ' AS LONG AS ANY PART OF THIS FILE IS NOT ALTERED IN ANY WAY. ' IF YOU DO WISH TO USE THESE ROUTINES IN YOUR OWN PROGRAMS ' THEN PLEASE GIVE CREDIT TO THE AUTHOR... Mario LaRosa. ' ''' ' '$DYNAMIC ' DEFINT A-Z ' DECLARE SUB QDELAY (seconds!) ' SCREEN 0 COLOR 7 CLS ' QDELAY 0 'Always calibrate routine first. ' DO: LOOP UNTIL TIMER <> TIMER ' DO ' t! = TIMER ' QDELAY 1 / 2 'Delay approx. 1/2 seconds. ' PRINT TIMER - t!; " seconds" ' LOOP UNTIL LEN(INKEY$) ' SYSTEM ' TIMERinterrupt: sys& = clc&: clc& = &H7FFFFFFE RETURN ' REM $STATIC SUB QDELAY (seconds!) STATIC ' SHARED sys&, clc& ' IF seconds! THEN ' del& = sys& * seconds! ' FOR clc& = 1 TO del&: NEXT ' ELSE ' ON TIMER(1) GOSUB TIMERinterrupt ' DO: LOOP UNTIL TIMER <> TIMER ' TIMER ON ' FOR clc& = 1 TO &H7FFFFFFE: NEXT ' TIMER OFF ' END IF ' END SUB ãDavid Williams Satallite Position Update david.williams@ablelink.org 06-13-03 ( : ) Qbasic, QB, PDS, PB 404 10275 SAT_CALC.BAS' SAT_CALC.BAS ã' TV Satellites, Commodore PET version, David Williams, 1982 ã ã' david.williams@ablelink.org ã ã' Updated for other computers 1995, 2000, 2002 ã' Solar outage code added March 2003 ã ã' This version dated 2003 April 5 ã ãDECLARE SUB InNum (Pt$, V, MX%) ãDECLARE FUNCTION YesNo$ () ãDECLARE FUNCTION ROff$ (J, P%) ãDECLARE FUNCTION ATan (A, B) ãDECLARE SUB Instructions () ãDECLARE SUB SpaceBar () ã ãDIM SHARED PI ãPI = 4 * ATN(1) ãCF = PI / 180 ' Degree/radian factor ãCF2 = PI / 182.5 ãR = 6.615 ' Radius of geosynchronous orbit in units of earth radius ã ãON ERROR GOTO Etrap ãF% = FREEFILE ãN$ = "TVSATDAT.DAT" ãE% = 0 ãOPEN N$ FOR INPUT AS F% ã' Note: File does not have to exist for program to run. If no file ã' is found, default values are used. File is created or updated ã' at end of program. ã ãIF E% THEN ã ã FA = 45 ') ã FG = 80 ') Default latitude & longitudes, used if file not found ã FS = 90 ') ã FZ = -5 ' Default time zone ã ãELSE ã ã INPUT #F%, FA, FG, FS, FZ ã ãEND IF ã ãCLOSE F% ã ãON ERROR GOTO 0 ã ãLA = FA ãLG = FG ãLS = FS ãTZ = FZ ã ãCLS ãPRINT "Do you want instructions"; ãIF YesNo$ = "y" THEN CALL Instructions ã ãNewcalc: ã ã' Input section ã ãCLS ãPRINT "For your current position on the ground:" ãPRINT "Latitude is"; ROff$(LA, -2); "degrees north." ãPRINT "Longitude is"; ROff$(LG, -2); "degrees west." ã ãPRINT ãPRINT "Input latitude and longitude in degrees." ãPRINT "Use negative numbers for angles in" ãPRINT "opposite directions to those shown." ãPRINT ã ãInNum "Your latitude (deg. north)", LA, 90 ãInNum "Your longitude (deg. west)", LG, 180 ã ãPRINT "For current satellite:" ãPRINT "Longitude is"; ROff$(LS, -2); "degrees west." ãPRINT ãPRINT "Input longitude of satellite in" ãPRINT "degrees west. (Use negative number" ãPRINT "if you want to input degrees east.)" ãPRINT ãInNum "Satellite's longitude", LS, 180 ã ãPRINT "Current time zone offset is"; ãPRINT ROff$(TZ, -1); "hours from GMT / UT." ãInNum "Time zone (+/- hours from GMT / UT)", TZ, 14 ã ãPRINT "Confirm these entries"; ãIF YesNo$ = "n" GOTO Newcalc ã ãLD = (LG - LS) * CF ' longitude difference in radians ãLR = CF * LA ' latitude in radians for outages ãLT = LR + PI / 2 ' latitude from s. pole ã ã' satellite's x,y,z coordinates ãY = 0 ' equatorial orbit ãX = R * SIN(LD) ãZ = R * COS(LD) ã ã' rotate system to put observer at s. pole ãD = ABS(Z) ' distance from x-axis ãAN = SGN(Z) * PI / 2 ã' azimuth angle onto y-z plane (y-axis as zero) ãAN = AN + LT ' rotate system ãY = D * COS(AN) ' new y ãZ = D * SIN(AN) ' new z ã ãCLS ã ãIF Y > -1 THEN ã ã PRINT "Satellite is invisible (below horizon)." ã ãELSE ã ã ' calculate altitude ã ã AL = ATan(-1 - Y, SQR(X * X + Z * Z)) ã ã AL = AL / CF ' alt. in degrees ã A$ = ROff$(AL, 1) ã ã IF VAL(A$) = 90 THEN ã ã PRINT "Satellite is vertically overhead." ã PRINT "(Altitude is 90.0 degrees.)" ã ã ELSE ã ã ' calculate new bearing ã ã BE = ATan(X, Z) ã ã BE = BE / CF ' bearing in degrees ã ã ' roundoff and printout ã ã BE = VAL(ROff$(BE, 1)) ã BE = BE - 360 * INT(BE / 360) ã ã PRINT "Satellite's position:" ã ã B$ = ROff$(BE, 1) ã BE = VAL(B$) ã ã PRINT "Bearing is"; B$; "degrees. "; ã ã X = BE / 90 ã IF X = INT(X) THEN ã Y1$ = RTRIM$(MID$("NorthEast SouthWest", 5 * X + 1, 5)) ã PRINT "(Due "; Y1$; ")" ã ELSE ã Z = ABS(180 - BE) ã IF Z < 90 THEN ã Y1$ = "(South," ã ELSE ã Y1$ = "(North," ã Z = 180 - Z ã END IF ã IF X < 2 THEN ã Y2$ = "East)" ã ELSE ã Y2$ = "West)" ã END IF ã PRINT Y1$; ROff$(Z, 1); "degrees "; Y2$ ã END IF ã ã PRINT "Altitude is"; A$; "degrees." ã IF AL < 5 THEN ã PRINT ã PRINT "Very low altitude - Communication unreliable" ã END IF ã ã END IF ã ã ' Solar outage calculation ã ã ' coordinate differences ã X1 = -R * SIN(LD) ã Y1 = -SIN(LR) ã Z1 = R * COS(LD) - COS(LR) ã ã ' calculate apparent declination ã AD = ATN(Y1 / SQR(X1 * X1 + Z1 * Z1)) ã ã ' calculate apparent longitude ã AG = ATan(X1, Z1) ã ã V = 4 * (AG / CF + LG) + 60 * TZ + 720.5 ã ã PRINT ã PRINT "Nominal solar outage dates and times:" ã ã ' find dates (days after Jan 31) when sun is at same declination ã FOR J = 0 TO 1 ã ã U = 182 ã L = 364 * J ã FOR K = 1 TO 20 ã D = (U + L) / 2 ã A = CF2 * D + .033 * SIN(CF2 * (D - 12)) ã IF INT(L) = INT(U) THEN EXIT FOR ã S = -.398 * COS(A) ã S = ATN(S / SQR(1 - S * S)) ã IF S > AD THEN U = D ELSE L = D ã NEXT ã D = INT(D - 40 + TZ / 24) ' 40 days from Dec solstice to Jan 31 ã ã ' convert date to month and day ã P = 1 ã DO ã L = VAL(MID$(" 28, 31,122, 31, 30,999", P, 3)) ã IF D <= L THEN EXIT DO ã D = D - L ã P = P + 4 ã LOOP ã MN$ = MID$("Feb,Mar,Apr,Aug,Sep,Oct", P, 3) ã ã ' calculate equation of time ã ET = 9.8 * SIN(A + A) + 7.6 * SIN(A - .2) ã ã ' calculate outage time ã T = INT(V + ET) ã T = T - 1440 * INT(T / 1440) ã H = T \ 60 ã M = T MOD 60 ã ã PRINT MN$; D, H; "hrs,"; M; "mins" ã ã NEXT ã ã PRINT ã PRINT "Outages occur for a few days before and after nominal dates," ã PRINT "and for a few minutes before and after nominal times." ã ãEND IF ã ãPRINT ã ãPRINT "Another calculation"; ã ãIF YesNo$ = "y" GOTO Newcalc ã ãIF LA <> FA OR LG <> FG OR LS <> FS OR TZ <> FZ THEN ã PRINT "Keep current latitude, longitudes & time zone for next run"; ã IF YesNo$ = "y" THEN ã ON ERROR GOTO Etrap ã E% = 0 ã OPEN N$ FOR OUTPUT AS F% ã IF E% = 0 THEN ã PRINT #F%, ROff$(LA, -3); ","; ROff$(LG, -3); ","; ã PRINT #F%, ROff$(LS, -3); ","; ROff$(TZ, -1) ã END IF ã CLOSE F% ã ON ERROR GOTO 0 ã END IF ãEND IF ã ãEND ã ãEtrap: ã E% = 1 ã RESUME NEXT ã ã ãFUNCTION ATan (A, B) ã IF B = 0 THEN ã X = SGN(A) * PI / 2 ã ELSE ã X = ATN(A / B) ã IF B < 0 THEN X = X + PI ã END IF ã ATan = X ãEND FUNCTION ã ãSUB InNum (Pt$, V, MX%) ã ã DO ã ã PRINT Pt$; " (or ENTER to keep value)? "; ã C = POS(0) ã LINE INPUT In$ ã IF In$ = "" THEN ã LOCATE CSRLIN - 1, C - 1 ã PRINT ROff$(V, -3); "(kept)" ã PRINT ã EXIT DO ã END IF ã W = VAL(In$) ã IF ABS(W) <= MX% AND INSTR(In$, ",") = 0 THEN ã V = W ã PRINT ã EXIT DO ã END IF ã BEEP ã M$ = LTRIM$(STR$(MX%)) ã PRINT "Input illegal or out of range! (-"; M$; " to "; M$; ")" ã PRINT "Try again..." ã PRINT ã ã LOOP ã ãEND SUB ã ãSUB Instructions ã ã CLS ã PRINT "This program calculates the position in the sky, as true" ã PRINT "compass bearing and altitude (or angle of elevation), of" ã PRINT "any satellite that is in geostationary orbit. (Almost all" ã PRINT "T.V. broadcasting and relay satellites are geostationary.)" ã PRINT ã PRINT "The program also calculates the dates and times of 'solar" ã PRINT "outages' which occur when the satellite passes in front" ã PRINT "of, or very near, the sun in the sky. Radio waves from the" ã PRINT "sun then interfere with the satellite's communications." ã PRINT ã PRINT "You will be asked for your latitude and longitude, and for" ã PRINT "the longitude of the satellite. Enter these quantities, in" ã PRINT "degrees, accurate to at least one place of decimals (0.1" ã PRINT "degree) if possible. Errors greater than 0.1 degree will" ã PRINT "cause significantly inaccurate calculated results. It is" ã PRINT "a good idea to use a G.P.S. receiver to find your own" ã PRINT "latitude and longitude." ã PRINT ã PRINT "You will also be asked for your time zone, which is used" ã PRINT "in the solar outage calculation. Enter the number of hours" ã PRINT "by which it is ahead of (+) or behind (-) G.M.T. / U.T." ã ã CALL SpaceBar ã ã CLS ã PRINT "Note that the bearings are true. If you want a magnetic" ã PRINT "bearing, look up the local magnetic deviation. To find" ã PRINT "the magnetic bearing, add the deviation to the true" ã PRINT "bearing if magnetic north is west of true north. Subtract" ã PRINT "the deviation if magnetic north is east of true north." ã PRINT ã PRINT "The solar outage dates and times shown by the program" ã PRINT "are those when the satellite is closest to the centre of" ã PRINT "the sun's disk, as seen from your location on the earth." ã PRINT "Outages can occur when the satellite is a couple of degrees" ã PRINT "from the centre, depending on sunspot activity and the" ã PRINT "geometry of your dish. This means that outages can be" ã PRINT "several minutes in length, centred on the nominal time, and" ã PRINT "can occur for several successive days (at the same time of" ã PRINT "day), centred on the nominal date." ã PRINT ã PRINT "Your entries of latitude, longitudes and time zone can be" ã PRINT "kept on disk and used in subsequent runs. Initially," ã PRINT "arbitary defaults are used." ã ã CALL SpaceBar ã ãEND SUB ã ãFUNCTION ROff$ (J, P%) ã F% = ABS(P%) ã H& = INT(10 ^ F% * J + .5) ã IF H& < 0 THEN M$ = " -" ELSE M$ = " " ã S$ = LTRIM$(STR$(ABS(H&))) ã L% = LEN(S$) ã IF L% < F% + 1 THEN ã S$ = STRING$(F% + 1 - L%, "0") + S$ ã L% = F% + 1 ã END IF ã T$ = "." + RIGHT$(S$, F%) ã IF P% <= 0 THEN ã DO WHILE RIGHT$(T$, 1) = "0" ã T$ = LEFT$(T$, LEN(T$) - 1) ã LOOP ã IF T$ = "." THEN T$ = "" ã END IF ã ROff$ = M$ + LEFT$(S$, L% - F%) + T$ + " " ãEND FUNCTION ã ãSUB SpaceBar ã ã PRINT ã PRINT "Press Space Bar to continue"; ã ã DO WHILE LEN(INKEY$) ã LOOP ã ã DO WHILE INKEY$ <> " " ã LOOP ã ãEND SUB ã ãFUNCTION YesNo$ ã ã PRINT "? (y/n) "; ã DO WHILE INKEY$ <> "" ã LOOP ã DO ã G$ = LCASE$(INKEY$) ã LOOP UNTIL G$ = "y" OR G$ = "n" ã PRINT G$ ã PRINT ã YesNo$ = G$ ã ãEND FUNCTION ãDavid Williams Satallite Outages david.williams@ablelink.org 06-13-03 ( : ) Qbasic, QB, PDS, PB 97 2316 SAT_OUTS.BAS' SATOUTS.BAS ã' David Williams, 2003 ã' This version dated 2003 Apr 5 ã ã' david.williams@ablelink.orgã ãCLS ãPRINT "Calculates dates and times when geostationary satellites" ãPRINT "pass in front of sun, interfering with transmissions." ãPRINT ã ãR = 6.615 ' Radius of geosynchronous orbit in units of earth radius ãPI = 4 * ATN(1) ãCF1 = PI / 180 ãCF2 = PI / 182.5 ã ãPRINT "Input latitude and longitudes in degrees." ãPRINT "Use negative numbers for angles in" ãPRINT "opposite directions to those shown." ãPRINT ã ãINPUT "Your latitude (deg. north)"; LT ãLT = CF1 * LT ã ãINPUT "Your longitude (deg. west)"; LG ã ãINPUT "Satellite's longitude (deg. west)"; LS ã ãLD = (LS - LG) * CF1 ' longitude difference in radians ã ãINPUT "Time zone offset (+/- hours from G.M.T. / U.T.)"; TZ ã ã' coordinate differences ãX = R * SIN(LD) ãY = -SIN(LT) ãZ = R * COS(LD) - COS(LT) ã ã' calculate apparent declination ãAD = ATN(Y / SQR(X * X + Z * Z)) ã ã' calculate apparent longitude ãIF Z = 0 THEN ã AG = SGN(X) * PI / 2 ãELSE ã AG = ATN(X / Z) ã IF Z < 0 THEN AG = AG + PI ãEND IF ã ãV = 4 * (AG / CF1 + LG) + 60 * TZ + 720.5 ã ãPRINT ãPRINT "Nominal solar outage dates and times:" ã ã' find dates (days after Jan 31) when sun is at same declination ãFOR J = 0 TO 1 ã ã U = 182 ã L = 364 * J ã FOR K = 1 TO 20 ã D = (U + L) / 2 ã A = CF2 * D + .033 * SIN(CF2 * (D - 12)) ã IF INT(L) = INT(U) THEN EXIT FOR ã S = -.398 * COS(A) ã S = ATN(S / SQR(1 - S * S)) ã IF S > AD THEN U = D ELSE L = D ã NEXT ã D = INT(D - 40 + TZ / 24) ' 40 days from Dec solstice to Jan 31 ã ã ' convert date to month and day ã P = 1 ã DO ã L = VAL(MID$(" 28, 31,122, 31, 30,999", P, 3)) ã IF D <= L THEN EXIT DO ã D = D - L ã P = P + 4 ã LOOP ã MN$ = MID$("Feb,Mar,Apr,Aug,Sep,Oct", P, 3) ã ã ' calculate equation of time ã ET = 9.8 * SIN(A + A) + 7.6 * SIN(A - .2) ã ã ' calculate outage time ã T = INT(V + ET) ã T = T - 1440 * INT(T / 1440) ã H = T \ 60 ã M = T MOD 60 ã ã PRINT MN$; D, H; "hrs,"; M; "mins" ã ãNEXT ã ãPRINT ãPRINT "Outages occur for a few days before and after nominal dates," ãPRINT "and for a few minutes before and after nominal times." ã ãEND ã ãDavid Williams Month and Day Names david.williams@ablelink.org 06-13-03 ( : ) Qbasic, QB, PDS, PB 33 896 MNTHNAME.BAS' MNTHNAME.BASã' David Williams, 2003ã' david.williams@ablelink.orgãã' Function MonthName$(N%) returns the name of the N%th month ofã' the year. With minor changes, the same technique can be used forã' the names of days of the week, and so on.ããDECLARE FUNCTION MonthName$ (N%)ããDOã INPUT "Number of month (1 - 12)"; N%ã IF N% < 1 OR N% > 12 THEN ENDã Name$ = MonthName$(N%)ã PRINT "That month is "; Name$; "."ã PRINTãLOOPãã ããFUNCTION MonthName$ (N%)ã 'produces the name of the N%th monthã W$ = "January,February,March,April,May,June,July,"ã W$ = W$ + "August,September,October,November,December"ã Q% = 0ã FOR X% = 1 TO N%ã P% = Q% + 1ã Q% = INSTR(P%, W$, ",")ã NEXTã IF Q% = 0 THEN Q% = LEN(W$) + 1ã MonthName$ = MID$(W$, P%, Q% - P%)ãEND FUNCTIONããDieter Folger Perpetual Calendar ba2049@bnv-bamberg.de 06-13-03 ( : ) RAPID-Q 1 4270 Cal.bas '--------------------------------------------- 'CALENDAR.BAS for RapidQ 'Perpetual calendar (c) 2003 by Dieter Folger 'From 1583 until the twelfth of never. 'Note: 'The Gregorian Calendar was introduced in 'many European countries in October 1582, 'in England not until 1752. '--------------------------------------------- $INCLUDE "rapidq.inc" $TypeCheck ON DIM Dm(12) AS INTEGER, Month(12) AS STRING DIM DateLbl(37) AS qLabel DIM Day AS STRING, iLeft AS INTEGER, iTop AS INTEGER DIM d AS STRING, m AS BYTE, y AS INTEGER, i AS INTEGER DIM cM AS INTEGER, cY AS INTEGER, cD AS INTEGER DIM mo AS INTEGER, yy AS INTEGER, fd AS INTEGER, yr AS INTEGER DIM Cent AS INTEGER, FirstTime AS Byte, Insert AS STRING DECLARE SUB WriteMonth DECLARE SUB ChangeYear DECLARE SUB ChangeMonth DECLARE SUB Minimize DATA 31, " January ", 28, " February ", 31, " March " DATA 30, " April ", 31, " May ", 30, " June " DATA 31, " July ", 31, " August ", 30, "September " DATA 31, " October ", 30, "November ", 31, "December " FOR i = 1 TO 12 : READ Dm(i), Month(i) : NEXT Day = "Mo Tu We Th Fr Sa Su" ' get current date values d = Date$ : m = VAL(Left$(d, 2)) : y = VAL(MID$(d, 7, 4)) cD = VAL(MID$(d, 4, 2)) : cM = m : cY = y CREATE DayFont AS QFont Name = "Arial" Size = 12 Color = clRed END CREATE CREATE TopFont AS QFont Name = "Arial" Size = 12 AddStyles (fsBold) END CREATE CREATE Form AS QFORM Caption = LTRIM$(Month(m)) + STR$(cD) + ", "+ STR$(cY) Width = 230 Height = 225 Center Color = &hEEFAFA delBorderIcons(biMaximize) WndProc = Minimize onShow = WriteMonth CREATE DayLbl AS qLabel Left = 25 Top = 50 Caption = Day Font = DayFont END CREATE CREATE DateLabel AS QLabel Left = 50 Top = 21 Font = TopFont END CREATE CREATE ScrollMonth AS QScrollBar Top = 20 Left = 20 Width = 25 Height = 18 Position = m Min = 0 Max = 13 Hint = "Go up or down one month" ShowHint = 1 onChange = ChangeMonth END CREATE CREATE ScrollYear AS QScrollBar Top = 20 Left = 180 Width = 25 Height = 18 Max = 65000 Min = 1583 Position = y Hint = "Go up or down one year" ShowHint = 1 onChange = ChangeYear END CREATE END CREATE Form.ShowModal SUB WriteMonth Dm(2) = 28 IF y MOD 4 = 0 THEN Dm(2) = 29 'February has 28 days except 'in leap years. Centuries are only leap years when they can 'be divided by 400 (i.e. 1900 was not leap year, 2000 was one) IF y MOD 100 = 0 AND y MOD 400 <> 0 then Dm(2) = 28 mo = m : yy = y 'Calculate first day of current month '(Monday = 0...Sunday = 6) '(algorithm by Carl Friedrich Gauss 1777-1855): IF mo < 3 THEN INC mo, 10 : DEC yy ELSE DEC mo, 2 END IF Cent = yy \ 100 : yr = yy MOD 100 fd = ((((26 * mo - 2) \ 10) + yr + (yr \ 4) _ + (Cent \ 4) - (2 * Cent)) MOD 7) IF fd < 0 THEN INC fd, 7 iLeft = 25 : iTop = 75 FOR i = 1 TO 37 IF FirstTime = 0 THEN 'create labels only once DateLbl(i).Parent = Form DateLbl(i).Left = iLeft DateLbl(i).Top = iTop DateLbl(i).Width = 25 DateLbl(i).Height = 20 END IF IF i-fd < 10 then Insert = " " ELSE INSERT = "" DateLbl(i).Caption = " " + Insert + STR$(i - fd) + " " IF i <= fd THEN DateLbl(i).Caption = " " IF i > dm(m) + fd THEN DateLbl(i).Caption = " " IF( i - fd = cd) AND m = cm AND y = cy THEN DateLbl(i).Font.Color_ = clred ELSE DateLbl(i).Font.Color = clBlack IF FirstTime = 0 THEN IF (i) MOD 7 = 0 THEN iLeft = 25 : INC iTop, 20 ELSE INC iLeft, 25 END IF END IF NEXT DateLabel.Caption = Month(m) + STR$(y) FirstTime = 1 END SUB SUB ChangeMonth m = ScrollMonth.Position IF m = 0 THEN IF y > ScrollMonth.Min THEN m = 12 : DEC y ELSE m = 1 END IF ScrollMonth.Position = m END IF IF m = 13 THEN m = 1 : INC y ScrollMonth.Position = m END IF WriteMonth END SUB SUB ChangeYear y = ScrollYear.Position WriteMonth END SUB ãDavid Williams Equation of Time david.williams@ablelink.org 06-14-03 ( : ) Qbasic, QB, PDS 215 6912 ETIMSDEC.BAS' ETIMSDEC.BASã' David Williams, 2003ã' david.williams@ablelink.orgãã' This version dated 2003 June 14ãã' Compares results of (home brewed) Equation of Timeã' and Solar Declination calculations (performed inã' functions Equt, ETApprox and Declin) with published values.ãã' Equation of Time is difference between Solar Time and Mean Time.ã' Sundials show solar time. Clocks show mean time.ã' Solar Declination is latitude of the sun in celestial coordinates.ãã' Published values are from the book:ã' Sundials, Their Theory and Constructionã' by: Albert E. Waughã' Dover Publications, New York, 1973ã' ISBN 0-486-22947-5ããDECLARE FUNCTION Equt! (D!)ãDECLARE FUNCTION Declin! (D!)ãDECLARE FUNCTION ETApprox! (D!)ããDIM ML(1 TO 13)ãFOR X = 1 TO 13ã READ ML(X)ãNEXTãDATA 33,29,33,31,33,31,33,33,31,33,31,33,0ã' Month lengths adjusted for numbers of pixels on screenããETData:ããDATA 9, 128, 375, -20, 15: ' plotting parameters for E. of T. graphããDATA 3.12,7.38,11.08,13.33,14.19,13.49,12.34,10.18,7.28ãDATA 4.08,1.16,-1,-2.51,-3.4,-3.34,-2.25,-.39,1.28ãDATA 3.33,5.16,6.15,6.16,5.14,3.16,.12,-3.08,-6.4ãDATA -10.05,-13.02,-15.12,-16.2,-16,-14.16,-11.11,-7.02,-2.13ã' Above data show published values of Equation of Time onã' 1st, 11th and 21st days of months. Decimal point separatesã' minutes, to left, from seconds, to right, e.g. 3.16 meansã' 3 minutes and 16 seconds. Seconds are multiplied by 5/3 toã' get fractional minutes after READ instruction.ããDeclnData:ããDATA 5, 65, 407, -25, 25: ' plotting parameters for Decl'n graphããDATA -23.04,-21.56,-20.05,-17.2,-14.18,-10.52,-7.49,-3.57,0ãDATA 4.18,8.07,11.39,14.54,17.43,20.04,21.58,23.02,23.26ãDATA 23.09,22.11,20.36,18.1,15.27,12.19,8.3,4.48,.57ãDATA -2.57,-6.48,-10.29,-14.14,-17.15,-19.47,-21.43,-22.57,-23.26ã' Above data show published values of solar declination on 1st,ã' 11th and 21st days of month. See note after Equation of Time data.ããSCREEN 12ãCL0 = 7: CL1 = 14: CL2 = 11 ' colours usedããMenu:ãCLSãCOLOR CL0ãPRINT "1. Draw Equation of Time Graph (Fairly Accurate Function)"ãPRINT "2. Draw Equation of Time Graph (Simple Approximate Function)"ãPRINT "3. Draw Solar Declination Graph"ãPRINT "4. Quit program"ãPRINTãPRINT "Which (by number)?";ãWHILE INKEY$ <> "": WENDãDOã F% = VAL(INKEY$)ãLOOP UNTIL F% >= 1 AND F% <= 4ãPRINT F%ãIF F% = 4 GOTO Wayoutãã' Set up graphãCLSããIF F% < 3 THENã PRINT TAB(30); "EQUATION OF TIME"ã LOCATE 3, 15ã PRINT "Graph shows difference in minutes between clock"ã PRINT TAB(15); "and sundial time. Positive difference means"ã PRINT TAB(15); "clock is ahead of sundial, and vice versa."ã LOCATE 26, 15ã COLOR CL1ã PRINT "Graph shows results of ";ã IF F% = 2 THEN PRINT "(approximate) ";ã PRINT "calculation."ã COLOR CL2ã PRINT TAB(15); "Circles show published values of Equation of Time."ã RESTORE ETDataãELSEã PRINT TAB(25); "Declination of Sun, in Degrees"ã LOCATE 3, 10ã COLOR CL1ã PRINT "Graph shows calculated function. ";ã COLOR CL2ã PRINT "Circles show published values.";ã RESTORE DeclnDataãEND IFããREAD ML%, VT%, VB%, LL%, UL%ããCOLOR CL0ãLOCATE 16, 67ãPRINT "-=";ããFOR T = LL% TO UL% STEP 5ã LINE (137, 247 - 6.4 * T)-(530, 247 - 6.4 * T)ã LOCATE 16 - T / 2.5, 14ã PRINT RIGHT$(" " + STR$(T), 3);ã IF T = 0 THEN PRINT " =";ãNEXTãLOCATE ML%, 20ãPRINT "Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec";ãã' Do graphingãT = 0ãD = 0ãMC = 0ãFOR M = 0 TO 384ã M1 = 147 + Mã IF M = T THENã ' Draw vertical lineã COLOR CL0ã LINE (M1, VT%)-(M1, VB%)ã MC = MC + 1ã T = T + ML(MC)ã MS = 0ã ELSEã ' Plot point(s)ã COLOR CL1ã SELECT CASE F%ã CASE 1: G = Equt(D)ã CASE 2: G = ETApprox(D)ã CASE ELSE: G = Declin(D)ã END SELECTã PSET (M1, 247 - 6.4 * G)ã IF MS = 0 OR MS = 10 OR MS = 20 THENã ' Plot circle representing published valueã COLOR CL2ã READ E ' published valuesã E = FIX(E) + (E - FIX(E)) * 5 / 3ã CIRCLE (M1, 247 - 6.4 * E), 2ã END IFã MS = MS + 1ã D = D + 1ã END IFã IF ML(MC) = 33 AND M = T - 18 THEN M = M + 1ãNEXTãã' Tidy upãCOLOR CL0ãLOCATE 30, 25ãPRINT "*** Press any key to continue ***";ãWHILE INKEY$ <> "": WENDãWHILE INKEY$ = "": WENDãGOTO MenuããWayout:ãPRINTãPRINTãPRINT "Note: Using the fairly accurate function, the calculated and published"ãPRINT "values of Equation of Time show a Root Mean Square difference of about"ãPRINT "3.7 *seconds*. The greatest difference is 6.0 seconds, on July 11."ãPRINT "Using the approximate function, the R.M.S. difference is about 10.5"ãPRINT "seconds. The largest difference is 19.6 seconds, on March 1."ãPRINTãPRINT "The approximate calculation is simpler and faster than the more"ãPRINT "accurate one, and is certainly adequate for many purposes, such as"ãPRINT "comparing the readings of sundials and clocks."ãPRINTãPRINT "Comparison of the calculated and published values of Solar Declination"ãPRINT "on same dates shows a Root Mean Square difference of 4.7 arc-minutes."ãPRINT "The largest difference is 8.8 arc-minutes, on April 11."ãPRINTãPRINT "In order to get even better accuracy than this declination calculation"ãPRINT "and the more accurate Equation of Time one, much more elaborate"ãPRINT "methods are needed."ããENDããFUNCTION Declin (D)ã ' Calculates declination of sun, in degrees, on Dth day of year.ã ' D = 0 on January 1.ã PI = 3.14159265#ã W = PI / 182.5 ' mean orbital angular speed in radians per dayã ' Solstice 10 days before New Year's Day. Perihelion 2 days after.ã A = W * (D + 10) + .0334 * SIN(W * (D - 2)) ' .0334 is twice eccentricityã S = -.3979 * COS(A) ' .3979 is sine of axial tiltã Declin = ATN(S / SQR(1 - S * S)) * 180 / PI ' arc-sine, in degreesãEND FUNCTIONããFUNCTION Equt (D)ã ' Calculates equation of time, in minutes, onã ' Dth day of year. (D = 0 on January 1.)ã PI = 3.14159265#ã W = PI / 182.5 ' mean orbital angular speed in radians per dayã T = D + 10 'Solstice 10 days before Jan 1. Perihelion 12 days after solsticeã A = W * T + .0334 * SIN(W * (T - 12)) ' .0334 is twice eccentricityã B = ATN(TAN(A) / .9174) - W * T ' .9174 is cosine of axial tiltã B = B - PI * INT(B / PI + .5) ' ATN uncertain. B must be close to zero.ã Equt = B * 720 / PI ' 720 minutes in 12 hoursãEND FUNCTIONããFUNCTION ETApprox (D)ã ' Calculates approximate equation of time, in minutes, onã ' Dth day of year. (D = 0 on January 1.)ã W = 3.14159265# / 182.5 ' mean orbital angular speed in radians/dayã ' solstice 10 days before new year's day. perihelion 2 days afterã A = W * (D + 10) + .0334 * SIN(W * (D - 2)) ' .0334 is twice eccentricityã ETApprox = 9.8 * SIN(A + A) + 7.7 * SIN(A - .21) ' approximate formulaãEND FUNCTIONããAchilles b. Mina Digital/Analog Clock w/Sound wasaywasay@edsamail.com.ph 06-15-03 ( : ) RAPIDQ 422 11365 Alarmed.bas 'Alarmed v1.00ã'Uploaded 5/19/03ã'By Achilles B. Minaãã'Alarmed is yet another alarm clock. It demonstrates Rapid-Q's talent ã'for producing highly useful utilities easily and, unfortunately, also ã'shows the author's lack of talent for innovative programming. ã'You can do as you please with this code but kindly acknowledge ã'the talentless author.ãã'To run the program, provide .wav files of the stated filenamesã'in you current directoryãã$RESOURCE birds AS "birds.wav"ã$RESOURCE parrot AS "parrot.wav"ã$RESOURCE clicker AS "click.wav"ããDECLARE SUB InitAlarmãDECLARE SUB CountdownModeãDECLARE SUB OffãDECLARE SUB ClickãDECLARE SUB CheckAMPMãDECLARE SUB RemindedãDECLARE SUB AlarmHowãDECLARE SUB AlarmTimeãDECLARE SUB CountdownãDECLARE SUB DigitClockãDECLARE SUB AlarmPaintãDECLARE SUB SweepãDECLARE SUB AboutãDECLARE SUB GetMMãDECLARE SUB PlayAlarmãDECLARE SUB HelpããDECLARE FUNCTION SetWindowLong Lib "User32" Alias "SetWindowLongA" _ã(hwnd as Long, nIndex as Long, dwNewLong as Long) as LongããDECLARE FUNCTION GetShortPathName Lib "kernel32" _ãAlias "GetShortPathNameA"(ByVal lpszLongPath As String, _ãByVal lpszShortPath As long, ByVal lBuffer As Long) As LongããDECLARE FUNCTION PlayMedia Lib "winmm.dll" _ãAlias "mciSendStringA"(ByVal lpstrCommand As String, _ãlpstrReturnString As Long, uReturnLength As _ãLong, hwndCallback As Long) As LongããDEFINT hour, min, sec, runcountãDEFBYTE clicked, alarmedãDEFSTR ampm$, AlarmFileName$ããDIM AlarmEdit(1 TO 3) AS QEDITãDIM AlarmLabel(1 TO 2) AS QLABELãDIM AMPM(1 TO 2) AS QRADIOBUTTONãDIM mAudio AS STRING*256ããCREATE Clock AS QTIMERã Interval = 250ã Enabled = 1ã OnTimer = CountdownModeãEND CREATEããCREATE AlarmForm AS QFORMã Height = 203ã Centerã Color = 100050001ã DelBorderIcons(2)ã OnClose = Offã CREATE Label AS QLABELã Align = 1ã Alignment = 2ã LabelStyle = 2ã Font.Name = "Arial"ã Font.Size = 40ã END CREATEã CREATE Label1 AS QLABELã Top = 85ã Left = 45ã Alignment = 2ã LabelStyle = 2ã Font.Name = "Arial"ã Font.Size = 15ã Caption = "Alarm at:"ã Hint = "Click to toggle countdown mode"ã ShowHint = 1ã Cursor = -21ã OnClick = AlarmHowã END CREATEã CREATE Remind AS QLABELã Top = 112ã Left = 184ã Alignment = 2ã LabelStyle = 1ã Font.Name = "Arial"ã Font.Size = 10ã Font.Color = 390909ã Caption = "Click AM or PM"ã END CREATEã CREATE GetButt AS QCOOLBTNã Top = 145ã Left = 35ã Width = 40ã Font.Name = "Arial"ã Font.Size = 10ã Font.Color = &HFFFFFFã Caption = "Open"ã Flat = 1ã Cursor = -21ã Hint = "Choose another alarm sound"ã ShowHint = 1ã OnClick = GetMMã END CREATEã CREATE OffButt AS QCOOLBTNã Top = 145ã Left = 81ã Width = 40ã Font.Name = "Arial"ã Font.Size = 10ã Font.Color = &HFFFFFFã Caption = "On/Off"ã Flat = 1ã Cursor = -21ã Hint = "Alarm is enabled"ã ShowHint = 1ã OnClick = Clickã END CREATEã CREATE AboutButt AS QCOOLBTNã Top = 145ã Left = 127ã Width = 40ã Font.Name = "Arial"ã Font.Size = 10ã Font.Color = &HFFFFFFã Caption = "Help"ã Flat = 1ã Cursor = -21ã Hint = "Click to know how to use Alarmed"ã ShowHint = 1ã OnClick = Helpã END CREATEã CREATE AlarmClock AS QDXSCREENã Top = 53ã Left = 178ã Cursor = -21ã Hint = "About"ã Showhint = 1ã OnClick = Aboutã END CREATEã CREATE AlarmHelp AS QFORMã Height = 203ã Width = 150ã Top = (Screen.Height - AlarmHelp.Height)*.5ã Left = Screen.Width*.5 + 160ã BorderStyle = 3ã Caption = "Help"ã Visible = 0ã CREATE AlarmRich AS QRICHEDITã Align = 5ã ReadOnly = 1ã ScrollBars = 3ã AddStrings "Welcome!"ã AddStrings ""ã AddStrings "Alarmed is a simple hint-based alarm clock. _ã To operate it, simply take note of the bubble hints."ã AddStrings ""ã AddStrings "To set the alarm, just type in the hour, _ã minutes and seconds when you want it to _ã go off. Seconds is optional."ã AddStrings ""ã AddStrings "There are two ways the alarm can go off: _ã when the time itself is reached, or after _ã a certain period has elapsed. Either mode can _ã be set by clicking Alarm at:"ã AddStrings ""ã AddStrings "You can also change the alarm itself: just click _ã Open. You can choose all kinds of sounds, including _ã MP3, midi and even movies!"ã AddStrings ""ã AddStrings "In fact, you don't even have to choose a particular sound. _ã Alarmed defaults to a parrot call--and that should _ã wake up even the dead."ã Line(0) = "Welcome!" ã END CREATEã END CREATEãEND CREATEãããSUB InitAlarmã SetWindowLong(AlarmForm.Handle,-8,0)ã SetWindowLong(Application.Handle,-8,AlarmForm.Handle)ã AlarmEditLeft = -5ã AlarmLabelLeft = 28ã FOR x = 1 TO 3ã AlarmEdit(x).Parent = AlarmFormã AlarmEdit(x).Top = 110 ã AlarmEdit(x).Left = AlarmEditLeft + 45ã AlarmEditLeft = AlarmEdit(x).Leftã AlarmEdit(x).Width = 30ã IF x = 1 THENã AlarmEdit(x).Hint = "Hour"ã ELSEIF x = 2 THENã AlarmEdit(x).Hint = "Minutes"ã ELSEIF x = 3 THENã AlarmEdit(x).Hint = "Seconds"ã END IFã AlarmEdit(x).ShowHint = 1ã AlarmEdit(x).Font.Name = "Arial"ã AlarmEdit(x).Font.Size = 15ã IF x < 3 THENã AlarmLabel(x).Parent = AlarmFormã AlarmLabel(x).Top = 105ã AlarmLabel(x).Left = AlarmLabelLeft + 45ã AlarmLabelLeft = AlarmLabel(x).Left ã AlarmLabel(x).Width = 10ã AlarmLabel(x).Alignment = 2ã AlarmLabel(x).LabelStyle = 2ã AlarmLabel(x).Font.Name = "Arial"ã AlarmLabel(x).Font.Size = 25ã AlarmLabel(x).Caption = ":"ã AMPM(x).Parent = AlarmForm ã AMPM(x).Top = 148ã AMPM(x).Width = 60ã AMPM(x).Font.Name = "Arial"ã AMPM(x).Font.Size = 15ã IF x = 1 THENã AMPM(x).Left = 175ã AMPM(x).Caption = "AM"ã ELSEã AMPM(x).Left = 230ã AMPM(x).Caption = "PM"ã END IFã AMPM(x).OnClick = Remindedã END IFã NEXTã AlarmEdit(2).OnChange = CheckAMPMãEND SUBããSUB CheckAMPMã IF Label1.Caption = "Alarm at:" THENã IF AMPM(1).Checked = 0 AND AMPM(2).Checked = 0 THENã PLAYWAV birds,1ã AlarmClock.Visible = 0ã END IFã END IFãEND SUBããSUB DigitClockã hour = VAL(LEFT$(TIME$,2))ã min = VAL(MID$(TIME$,4,2))ã sec = VAL(RIGHT$(TIME$,2)) ã IF hour >= 12 AND hour < 24 THENã hour = hour - 12ã IF hour = 0 THEN hour = 12ã ampm$ = " PM"ã ELSEIF hour = 0 THEN ã hour = 12ã ampm$ = " AM"ã ELSEã ampm$ = " AM"ã END IFã thetime$ = STR$(hour) + MID$(TIME$,3,3) + RIGHT$(TIME$,3) + ampm$ã Label.Caption = thetime$ã AlarmForm.Caption = "Alarmed " + DATE$ãEND SUBããSUB AlarmTimeã DigitClockã IF clicked = 1 THEN EXIT SUBã IF alarmed = 0 THENã IF VAL(AlarmEdit(1).Text) = hour THENã IF VAL(AlarmEdit(2).Text) = min THENã IF VAL(AlarmEdit(3).Text) = sec THENã IF (AMPM(1).Checked = 1 AND ampm$ = " AM") OR _ã (AMPM(2).Checked = 1 AND ampm$ = " PM") THEN ã PlayAlarmã alarmed = 1ã END IFã END IFã END IFã END IFã ELSEã PlayAlarmã END IFãEND SUBããSUB Countdownã DigitClockã IF clicked = 1 THEN EXIT SUBã IF runcount = 0 THENã hcount = VAL(AlarmEdit(1).Text)ã mcount = VAL(AlarmEdit(2).Text)ã scount = VAL(AlarmEdit(3).Text)ã count = hcount*3600 + mcount*60 + scountã END IFã IF runcount >= count AND count > 0 THEN ã PLAYWAV parrot,1ã END IFã INC runcountãEND SUBããSUB Clickã PLAYWAV clicker,1ã IF clicked = 0 THENã clicked = 1ã OffButt.Hint = "Alarm is disabled"ã ELSEã clicked = 0ã alarmed = 0ã runcount = 0ã OffButt.Hint = "Alarm is enabled"ã END IFãEND SUBããSUB Remindedã PLAYWAV clicker,1ã AlarmClock.Visible = 1ãEND SUBããSUB AlarmHowã PLAYWAV clicker,1ã IF Label1.Caption = "Alarm at:" THENã Label1.Caption = "Alarm after:"ã ELSEã Label1.Caption = "Alarm at:"ã END IFãEND SUBããSUB CountdownModeã IF Label1.Caption = "Alarm at:" THENã AlarmTimeã ELSEã Countdownã END IFã SweepãEND SUB ããSUB Sweepã AlarmForm.TextOut(90,59,TIME$,0,100050001)ã incsec = sec*6 - 90ã incmin = min*6 - 90ã IF hour = 12 THEN hour = 0 ã inchour = (hour + min/60)*30 - 90 ã anglesec = 0.0175*incsec '3.14153/180ã anglemin = 0.0175*incminã anglehour = 0.0175*inchourã xsec = 40*cos(anglesec) + 50ã ysec = 40*sin(anglesec) + 48 ã xmin = 40*cos(anglemin) + 50ã ymin = 40*sin(anglemin) + 48ã IF hour < 7 THENã xhour = SQR(ABS(625-(25*sin(anglehour))^2)) + 50ã ELSEã xhour = -SQR(ABS(625-(25*sin(anglehour))^2)) + 50ã END IFã yhour = 25*sin(anglehour) + 48ã AlarmClock.Circle(6,4,94,92,&HFFFFF,400050004)ã AlarmClock.Circle(48,8,52,12,&HFFFFFF,&HFFFFFF)ã AlarmClock.Circle(48,84,52,88,&HFFFFFF,&HFFFFFF)ã AlarmClock.Circle(10,48,14,52,&HFFFFFF,&HFFFFFF)ã AlarmClock.Circle(86,48,90,52,&HFFFFFF,&HFFFFFF)ã AlarmClock.Line(50,48,xsec,ysec,&HFFFFFF)ã AlarmClock.Line(50,48,xmin,ymin,&HFFFB)ã AlarmClock.Line(50,48,xhour,yhour,&HFFFB)ã AlarmClock.Flip ãEND SUBããSUB GetMMã CREATE OpenMM As QOPENDIALOGã Filter = "Multimedia files|*.m3u;*.rmi;*.midi;*.mid;*.wav;*.au;*.snd;*.mpa;*.wma;_ã *.mp2;*.mp3;*.asx;*.asf;*.aif;*.iff;*.mpm;*.m1v;*.mpeg;*.mpg;*.avi;*.mov;*.wmv;*.mpv;*.qt;*.dat|_ã Audio files|*.m3u;*.rmi;*.midi;*.mid;*.wav;*.au;*.snd;*.wma;_ã *.mp2;*.mp3;*.aif;*.iff|All files|*.*"ã END CREATEã IF OpenMM.Execute = 1 THENã filePath$ = STRING$(165,0)ã lenFilename = GetShortPathName_ã (OpenMM.FileName,VARPTR(filePath$),164)ã AlarmFileName$ = LEFT$(filePath$,lenFilename)ã END IFãEND SUBããSUB PlayAlarmã IF AlarmFileName$ = "" THEN ã PLAYWAV parrot,1ã ELSEã PlayMedia("open " + AlarmFileName$ + " type MpegVideo",0,0,0)ã PlayMedia("play " + AlarmFileName$ + " from 0",0,0,0)ã DOã DOEVENTSã PlayMedia("status " + AlarmFileName$ + " mode",VARPTR(mAudio),256,0)ã LOOP UNTIL LEFT$(mAudio,7) = "stopped" OR clicked = 1 ã PlayMedia("close " + AlarmFileName$,0,0,0)ã END IFãEND SUBããSUB Aboutã MESSAGEBOX (" This is freeware." + CHR$(13) +_ã "Copyright (c) 2003" + CHR$(13) +_ ã " Achilles B. Mina" + CHR$(13) + CHR$(13) +_ ã " Alatmed is yet" + CHR$(13) +_ ã "another alarm clock." + CHR$(13) +_ ã " It was written in" + CHR$(13) +_ ã " Rapid-Q." + CHR$(13) + CHR$(13) +_ ã " It demonstrates" + CHR$(13) +_ ã " Rapid-Q's talent" + CHR$(13) +_ ã "for producing highly" + CHR$(13) +_ ã " useful apps easily." + CHR$(13) +_ ã " It also shows the" + CHR$(13) +_ ã " author's lack of" + CHR$(13) +_ ã " talent for" + CHR$(13) +_ ã " innovative coding.","Alarmed",0)ãEND SUBããSUB Helpã AlarmHelp.Visible = 1ãEND SUBããSUB Offã Application.TerminateãEND SUBããInitAlarmãAlarmForm.ShowModalãMichael Webster Milli-second Delay mfwebster@pdq.net 10-19-03 ( : ) XPB!BASIC 76 1868 DELAY.BAS ' DELAY.BASããDECLARE SUB SyncTimer ()ãDECLARE SUB Delay (millisecond%)ãã' This program contains a millisecond delay procedureã' that should work reliably under Windows XP, alongã' with a support procedure and some test code.ã'ã' Running under Windows, the actual delay intervalã' is somewhat variable, but typically within ~4% ofã' the specified interval.ãã' Calibrate the delay loop count.ãDelay 0ã' Wait for disk activity to subside.ãDelay 2000ããSyncTimerãã' This test should require 2.00 seconds.ãs! = TIMERãFOR i% = 1 TO 200ã Delay 10ãNEXTãf! = TIMERãPRINT USING "#.##"; f! - s!ããSUB Delay (milliseconds%) STATICã ' Delays for ms before returning.ã 'ã ' Calibrates the delay loop count on first call.ãã IF fRun% THENã loops& = milliseconds% * loopsPerMs&ã FOR i& = 1 TO loops&ã x! = x! ^ 2ã NEXTã ELSEã loops& = 100ã SyncTimerã DOã s! = TIMERã FOR i& = 1 TO loops&ã x! = x! ^ 2ã NEXTã f! = TIMERã IF f! > s! + 1 THENã fRun% = -1ã EXIT DOã END IFã loops& = loops& * 2ã LOOPã loopsPerMs& = loops& / (f! - s!) / 1000ã END IFãEND SUBããSUB SyncTimerã ' Waits for the next system timer tick beforeã ' returning.ã 'ã ' The value of the TIMER function changes inã ' increments of ~55ms, corresponding to theã ' period of the system timer tick that it isã ' derived from. Because the timing of anã ' interval requires two calls to the TIMERã ' function, the uncertainty in the intervalã ' is ~110ms. Synchronizing with the timerã ' tick will reduce the uncertainty to ~55ms.ã ã s! = TIMERã DOã LOOP UNTIL s! <> TIMERããEND SUBããThe ABC Programmer A PERPETUAL CALENDAR PERPETUAL,CALENDAR 05/15/94 (00:00) QB, QBasic, PDS 363 9072 CALENDAR.BASDECLARE FUNCTION MonthDays% (monthNum%, year%)ãDECLARE SUB ClearBuffer ()ãDECLARE SUB ShowSchedule ()ãDECLARE SUB CenterMessage (Info$, LineNum%, Colour%)ãDECLARE SUB ShowMonth (Month%, day%, year%)ãDECLARE FUNCTION DayNum% (Month%, day%, year%)ãDECLARE FUNCTION DateNum& (Month%, day%, year%)ãDECLARE FUNCTION LeapYear% (year%)ãDECLARE FUNCTION MonthName$ (monthNum%)ãDECLARE FUNCTION MonthDay% (Month%, year%)ããCONST MAXYEAR% = 2100ãCONST MINYEAR% = 1950ãCONST FALSE% = 0ãCONST TRUE% = NOT FALSE%ããcurMonth% = VAL(LEFT$(DATE$, 2))ãcurDay% = VAL(MID$(DATE$, 4, 2))ãcurYear% = VAL(RIGHT$(DATE$, 4))ãCLSãShowMonth curMonth%, curDay%, curYear%ãCALL ShowScheduleãGOSUB ShowNotesããSelectMonth:ããV$ = INKEY$ã IF V$ = CHR$(0) + "H" THEN GOSUB PreviousWeekã IF V$ = CHR$(0) + "P" THEN GOSUB NextWeekã IF V$ = CHR$(0) + "K" THEN GOSUB PreviousDayã IF V$ = CHR$(0) + "M" THEN GOSUB NextDayã IF V$ = CHR$(0) + "Q" THEN GOSUB NextMonthã IF V$ = CHR$(0) + "I" THEN GOSUB PreviousMonthã IF V$ = CHR$(13) THEN GOTO CallCalendarã IF V$ = CHR$(27) THEN GOTO QuitProgramãããdone% = FALSE%ãmakeCall% = FALSE%ããGOTO SelectMonthããCallCalendar:ã ComLine$ = STR$(curMonth%) + "/"ã ComLine$ = ComLine$ + STR$(curDay%) + "/"ã ComLine$ = ComLine$ + STR$(curYear%)ãã OPEN "SCHEDULE.DAT" FOR INPUT AS #1ã DOã LINE INPUT #1, DAT$ã IF INSTR(DAT$, ComLine$) > 0 THENã GOSUB DisplaySchedule: EXIT DOã ELSEã GOSUB InputSchedule: EXIT DOã END IFã LOOP UNTIL EOF(1)ã CLOSE #1ãã ShowMonth curMonth%, curDay%, curYear%ããGOTO SelectMonthããPreviousDay:ã IF curDay% > 1 THENã curDay% = curDay% - 1ã ELSEIF curMonth% > 1 THENã curMonth% = curMonth% - 1ã curDay% = MonthDays%(curMonth%, curYear%)ã VIEW PRINT 1 TO 11ã CLSã GOSUB ShowNotesã ELSEã curYear% = curYear% - 1ã curMonth% = 12ã curDay% = 31ã END IFã ShowMonth curMonth%, curDay%, curYear%ãRETURNããNextDay:ã IF curDay% < MonthDays%(curMonth%, curYear%) THENã curDay% = curDay% + 1ã ELSEIF curMonth% <> 12 THENã curDay% = 1ã curMonth% = curMonth% + 1ã VIEW PRINT 1 TO 11ã CLSã GOSUB ShowNotesã ELSEã curDay% = 1ã curMonth% = 1ã curYear% = curYear% + 1ã END IFã ShowMonth curMonth%, curDay%, curYear%ãRETURNããPreviousWeek:ã IF curDay% > 7 THENã curDay% = curDay% - 7ã ShowMonth curMonth%, curDay%, curYear%ã END IFãRETURNããNextWeek:ã IF curDay% <= MonthDays%(curMonth%, curYear%) - 7 THENã curDay% = curDay% + 7ã ShowMonth curMonth%, curDay%, curYear%ã END IFãRETURNããPreviousMonth:ã IF curMonth% > 1 THENã curMonth% = curMonth% - 1ã ELSEIF curYear% > MINYEAR% THENã curYear% = curYear% - 1ã curMonth% = 12ã END IFã maxDay% = MonthDays%(curMonth%, curYear%)ã IF curDay% > maxDay% THEN curDay% = maxDay%ã VIEW PRINT 1 TO 11ã CLSã ShowMonth curMonth%, curDay%, curYear%ã GOSUB ShowNotesãRETURNããNextMonth:ã IF curMonth% < 12 THENã curMonth% = curMonth% + 1ã ELSEIF curYear% < MAXYEAR% THENã curYear% = curYear% + 1ã curMonth% = 1ã END IFã maxDay% = MonthDays%(curMonth%, curYear%)ã IF curDay% > maxDay% THEN curDay% = maxDay%ã VIEW PRINT 1 TO 11ã CLSã ShowMonth curMonth%, curDay%, curYear%ã GOSUB ShowNotesãRETURNããPreviousYear:ã IF curYear% > MINTEAR% THENã curYear% = curYear% - 1ã maxDay% = MonthDays%(curMonth%, curYear%)ã IF curDay% > maxDay% THEN curDay% = maxDay%ã ShowMonth curMonth%, curDay%, curYear%ã END IFãRETURNããNextYear:ã IF curYear% < MAXYEAR% THENã curYear% = curYear% + 1ã maxDay% = MonthDays%(curMonth%, curYear%)ã IF curDay% > maxDay% THEN curDay% = maxDay%ã ShowMonth curMonth%, curDay%, curYear%ã END IFãRETURNããDisplaySchedule:ã INPUT #1, Info1$, Info2$, Info3$ã VIEW PRINT 12 TO 23ã IF curMonth% = 1 THEN curMonth$ = " January"ã IF curMonth% = 2 THEN curMonth$ = " February"ã IF curMonth% = 3 THEN curMonth$ = " March"ã IF curMonth% = 4 THEN curMonth$ = " April"ã IF curMonth% = 5 THEN curMonth$ = " May"ã IF curMonth% = 6 THEN curMonth$ = " June"ã IF curMonth% = 7 THEN curMonth$ = " July"ã IF curMonth% = 8 THEN curMonth$ = " August"ã IF curMonth% = 9 THEN curMonth$ = " September"ã IF curMonth% = 10 THEN curMonth$ = " October"ã IF curMonth% = 11 THEN curMonth$ = " November"ã IF curMonth% = 12 THEN curMonth$ = " December"ã LOCATE 17, 5: COLOR 14: PRINT curMonth$; curDay%; curYear%ã CALL CenterMessage(Info1$, 19, 15)ã CALL CenterMessage(Info2$, 20, 7)ã CALL CenterMessage(Info3$, 21, 7)ã VIEW PRINT 1 TO 11ãRETURNããShowNotes:ãVIEW PRINT 13 TO 15ãLOCATE 14, 3: COLOR 7: PRINT "Notes:"ãCOLOR 10ãcurrentDay% = curDay%ãGOSUB NextCurDayãM = 7ãOPEN "SCHEDULE.DAT" FOR INPUT AS #1ã DOã LINE INPUT #1, DAT$ã IF INSTR(DAT$, ComLine$) THEN M = M + 2: LOCATE 14, M: PRINT currentDay%: currentDay% = currentDay% + 1: GOSUB NextCurDayã LOOP UNTIL EOF(1)ãCLOSE #1ãVIEW PRINT 1 TO 11ãRETURNããNextCurDay:ã ComLine$ = STR$(curMonth%) + "/"ã ComLine$ = ComLine$ + STR$(currentDay%) + "/"ã ComLine$ = ComLine$ + STR$(curYear%)ãRETURNããInputSchedule:ãRETURNããQuitProgram:ã done% = TRUE%ããSUB CenterMessage (Info$, LineNum%, Colour%)ãLOCATE LineNum%, 15ãLOCATE LineNum%, INT((80 - LEN(Info$)) / 2)ãCOLOR Colour%, 0ãPRINT LEFT$(Info$, 77)ãEND SUBããSUB ClearBufferãã DO WHILE INKEY$ <> ""ã LOOPããEND SUBããFUNCTION DateNum& (Month%, day%, year%)ãã startYear% = 1900ã january% = 1ã daysPerYr& = 365ãã tooEarly% = (year% < startYear%)ã badMonth% = (Month% < 1 OR Month% > 12)ã badDay% = (day% < 1 OR day% > MonthDays%(Month%, year%))ã IF tooEarly% OR badMonth% OR badDay% THENã DateNum& = 0ã EXIT FUNCTIONã END IFãã num& = daysPerYr& * (year% - startYear%)ãã FOR curYear% = startYear% TO year% - 1 STEP 4ã IF LeapYear%(curYear%) THEN num& = num& + 1ã NEXT curYear%ãã FOR curMonth% = january% TO Month% - 1ã num& = num& + MonthDays%(curMonth%, year%)ã NEXT curMonth%ãã num& = num& + day%ã DateNum& = num&ããEND FUNCTIONããFUNCTION DayNum% (Month%, day%, year%)ãã d& = DateNum&(Month%, day%, year%)ã IF d& <> 0 THEN dow% = d& MOD 7 + 1 ELSE dow% = 0ãã DayNum% = dow%ããEND FUNCTIONããFUNCTION LeapYear% (year%)ãã divBy4% = (year% MOD 4 = 0)ã century% = (year% MOD 100 = 0)ã century400% = (year% MOD 400 = 0)ãã LeapYear% = divBy4% AND (century% IMP century400%)ããEND FUNCTIONããFUNCTION MonthDays% (monthNum%, year%)ãã IF monthNum% < 1 OR monthNum% > 12 THENã MonthDays% = 0ã EXIT FUNCTIONã END IFãã SELECT CASE monthNum%ã ã CASE 2ã days% = 28ã IF LeapYear%(year%) THEN days% = days% + 1ã CASE 4, 6, 9, 11ã days% = 30ã CASE ELSEã days% = 31ã END SELECTãã MonthDays% = days%ããEND FUNCTIONããFUNCTION MonthName$ (monthNum%)ãã M$ = "January February March April "ã M$ = M$ + "May June July August "ã M$ = M$ + "September October Novemeber December "ãã IF monthNum% >= 1 AND monthNum% <= 12 THENã moStr$ = MID$(M$, (monthNum% - 1) * 10 + 1, 10)ã moStr$ = RTRIM$(moStr$)ã ELSEã moStr$ = ""ã END IFã MonthName$ = moStr$ããEND FUNCTIONããSUB ShowMonth (Month%, day%, year%)ãã firstDay% = DayNum%(Month%, 1, year%)ã monthLength% = MonthDays%(Month%, year%)ã moStr$ = MonthName$(Month%)ã LOCATE 1, 1ã COLOR 14, 0: PRINT SPACE$(35 - LEN(moStr$) \ 2); moStr$; year%ã PRINTã COLOR 15ã PRINT " Sunday Monday Tuesday Wednesday Thursday Friday Saturday"ã PRINTã COLOR 7ãã curDate% = 0ã DOã PRINT " ";ã FOR curDay% = 1 TO 7ã isFirstDay% = (curDay% = firstDay% AND curDate% = 0)ã isInMonth% = (curDate% > 0 AND curDate% < monthLength%)ã IF isFirstDay% OR isInMonth% THENã curDate% = curDate% + 1ã IF curDate% = day% THEN COLOR 15, 1ã PRINT USING "###"; curDate%;ã PRINT " ";ã COLOR 7, 0ã ELSEã PRINT " ";ã END IFã NEXT curDay%ã PRINTã LOOP UNTIL curDate% = monthLength%ãã ãEND SUBããSUB ShowScheduleãVIEW PRINT 12 TO 24ãCOLOR 11ãLOCATE 13, 1: PRINT CHR$(218); STRING$(77, 196); CHR$(191)ãLOCATE 14, 1: PRINT CHR$(179); STRING$(77, 0); CHR$(179)ãLOCATE 15, 1: PRINT CHR$(192); STRING$(77, 196); CHR$(217)ãLOCATE 17, 1: PRINT CHR$(218); STRING$(77, 196); CHR$(191)ãLOCATE 18, 1: PRINT CHR$(179); STRING$(77, 0); CHR$(179)ãLOCATE 19, 1: PRINT CHR$(179); STRING$(77, 0); CHR$(179)ãLOCATE 20, 1: PRINT CHR$(179); STRING$(77, 0); CHR$(179)ãLOCATE 21, 1: PRINT CHR$(179); STRING$(77, 0); CHR$(179)ãLOCATE 22, 1: PRINT CHR$(179); STRING$(77, 0); CHR$(179)ãLOCATE 23, 1: PRINT CHR$(192); STRING$(77, 196); CHR$(217)ãVIEW PRINT 1 TO 11ãEND SUBããã--------------[ Cut and save this as SCHEDULE.DAT ]-----------------ã 8/ 28/ 1995ã"This is the Schedule.Dat file","To save notes press enter on any day","Enjoy!"ãDick Dennison RETURNS DAY OF THE WEEK DAY,FUNCTION 10/26/89 (00:00) QB, PDS 16 646 DAYWEEK.BAS 'Day of Week - Dick Dennison 10/26/89ã'$INCLUDE: 'qb.bi' 'load qb with the /L switchã'Interrupt 21 Function 2AH - get dateãDIM InRegs AS RegType, OutRegs AS RegTypeãDIM Day(7) AS STRING * 3ãDay$(0) = "Sun": Day$(1) = "Mon": Day$(2) = "Tue": Day$(3) = "Wed"ãDay$(4) = "Thu": Day$(5) = "Fri": Day$(6) = "Sat"ãCLSãInRegs.ax = &H2A * 256 '2Ah in ahãCALL INTERRUPT(&H21, InRegs, OutRegs)ã' * * * cx is the year, dh is the month, dl is the date, al is the dayãPRINT OutRegs.cx; " = year"ãPRINT OutRegs.dx \ 256; " = month"ãPRINT OutRegs.dx MOD 256; " = date"ãdaynum% = OutRegs.ax MOD 256ãPRINT "Day of the week is "; Day$(daynum%)ãJoe Negron MONTHLY CALENDAR MONTHLY,CALENDAR 01/08/93 (10:53) QB, QBasic, PDS 215 6180 MONCAL.BAS 'Al, I'm reposting this as Richard Dale informs me that the copy heã'received had been cut off. Let me know if you receive it OK.ããDEFINT A-ZããDECLARE SUB OneMthCal (DateX$)ããDECLARE FUNCTION Date2Day% (DateX$)ãDECLARE FUNCTION Date2Mth% (DateX$)ãDECLARE FUNCTION Date2Serial& (DateX$)ãDECLARE FUNCTION Date2Year% (DateX$)ãDECLARE FUNCTION DayOfTheWeek$ (DateX$)ãDECLARE FUNCTION Serial2Date$ (Serial&)ãDECLARE FUNCTION MDY2Date$ (Month%, Day%, Year%)ãDECLARE FUNCTION MthName$ (DateX$)ããCLSãOneMthCal DATE$ããSYSTEMãã'**********************************************************************ã'* FUNCTION Date2Day%ã'*ã'* PURPOSEã'* Returns the day number given a date in the standard date format.ã'**********************************************************************ãã'**********************************************************************ã'* FUNCTION Date2Mth%ã'*ã'* PURPOSEã'* Returns the month number given a date in the standard date format.ã'**********************************************************************ãã'**********************************************************************ãã'* FUNCTION Date2Serial&ã'*ã'* PURPOSEã'* Returns the astronomical Julian day number given a date in theã'* standard date format. Note that the year must be 1583 or greater.ã'*ã'* INTERNAL ROUTINE(S)ã'* FUNCTION Date2Day% (DateX$)ã'* FUNCTION Date2Mth% (DateX$)ã'* FUNCTION Date2Year% (DateX$)ã'**********************************************************************ãã'**********************************************************************ã'* FUNCTION Date2Year%ã'*ã'* PURPOSEã'* Returns the year number given a date in the standard date format.ã'**********************************************************************ãã'**********************************************************************ã'* FUNCTION DayOfTheWeek$ã'*ã'* PURPOSEã'* Returns a string stating the day of the week given a date in theã'* standard date format.ã'*ã'* INTERNAL ROUTINE(S)ã'* FUNCTION Date2Serial& (DateX$)ã'**********************************************************************ãã'**********************************************************************ã'* FUNCTION MDY2Date$ã'*ã'* PURPOSEã'* Converts Month%, Day%, and Year% to a string in the standard dateã'* format.ã'**********************************************************************ãã'**********************************************************************ã'* FUNCTION MthName$ã'*ã'* PURPOSEã'* Returns then name of the month given a string in the standard dateã'* format.ã'**********************************************************************ãã'**********************************************************************ã'* SUB OneMthCalã'*ã'* PURPOSEã'* Prints a one-month calendar for the given date at the currentã'* screen location.ã'*ã'* INTERNAL ROUTINE(S)ã'* FUNCTION Date2Day% (DateX$)ã'* FUNCTION Date2Mth% (DateX$)ã'* FUNCTION Date2Serial& (DateX$)ã'* FUNCTION Date2Year% (DateX$)ã'* FUNCTION DayOfTheWeek$ (DateX$)ã'* FUNCTION MDY2Date$ (Month%, Day%, Year%)ã'* FUNCTION MthName$ (DateX$)ã'* FUNCTION Serial2Date$ (Serial&)ã'**********************************************************************ãã'**********************************************************************ã'* FUNCTION Serial2Date$ã'*ã'* PURPOSEã'* Returns a date in the standard date format given a Julian dayã'* number.ã'*ã'* INTERNAL ROUTINE(S)ã'* FUNCTION MDY2Date$ (Month%, Day%, Year%)ã'**********************************************************************ããFUNCTION Date2Day% (DateX$) STATICã Date2Day% = VAL(MID$(DateX$, 4))ãEND FUNCTIONããFUNCTION Date2Mth% (DateX$) STATICã Date2Mth% = VAL(DateX$)ãEND FUNCTIONããFUNCTION Date2Serial& (DateX$) STATICã Month% = Date2Mth%(DateX$)ã Day% = Date2Day%(DateX$)ã Year% = Date2Year%(DateX$)ãã IF Month% > 2 THENã Month% = Month% - 3ã ELSEã Month% = Month% + 9ã Year% = Year% - 1ã END IFãã TA& = 146097 * (Year% \ 100) \ 4ã TB& = 1461& * (Year% MOD 100) \ 4ã TC& = (153 * Month% + 2) \ 5 + Day% + 1721119ã Date2Serial& = TA& + TB& + TC&ãEND FUNCTIONããFUNCTION Date2Year% (DateX$) STATICã Date2Year% = VAL(MID$(DateX$, 7))ãEND FUNCTIONããFUNCTION DayOfTheWeek$ (DateX$) STATICã DayOfTheWeek$ = MID$("MonTueWedThuFriSatSun", ((Date2Serial&(DateX$) MOD 7) + 1) * 3 - 2, 3)ãEND FUNCTIONããFUNCTION MDY2Date$ (Month%, Day%, Year%) STATICã MDY2Date$ = RIGHT$("0" + MID$(STR$(Month%), 2), 2) + "-" + RIGHT$("0" + MID$(STR$(Day%), 2), 2) + "-" + RIGHT$("000" + MID$(STR$(Year%), 2), 4)ãEND FUNCTIONããFUNCTION MthName$ (DateX$) STATICã MthName$ = MID$("JanFebMarAprMayJunJulAugSepOctNovDec", VAL(DateX$) * 3 - 2, 3)ãEND FUNCTIONããSUB OneMthCal (DateX$) STATICã Row% = CSRLINã Col% = POS(0)ãã MName$ = MthName$(DateX$)ã LOCATE Row%, Col% + 12 - LEN(MName$) \ 2ãã Year% = Date2Year%(DateX$)ã PRINT MName$; ","; Year%ãã Month% = Date2Mth%(DateX$)ã Day% = 1ã Date1$ = MDY2Date$(Month%, Day%, Year%)ã Serial& = Date2Serial&(Date1$)ã Heading$ = " Sun Mon Tue Wed Thu Fri Sat"ã WA% = INSTR(1, Heading$, LEFT$(DayOfTheWeek$(Date1$), 3)) \ 4ã LOCATE Row% + 1, Col%ã PRINT Heading$ãã RowLoc% = Row% + 2ã LOCATE RowLoc%, Col% + 4 * WA%ãã DOã PRINT USING "####"; Day%;ãã IF WA% = 6 THENã RowLoc% = RowLoc% + 1ã LOCATE RowLoc%, Col%ã END IFãã WA% = (WA% + 1) MOD 7ã Serial& = Serial& + 1ã Day% = Date2Day%(Serial2Date$(Serial&))ã LOOP UNTIL Day% = 1ãEND SUBããFUNCTION Serial2Date$ (Serial&) STATICã X& = 4 * Serial& - 6884477ã Y& = (X& \ 146097) * 100ã D& = (X& MOD 146097) \ 4ãã X& = 4 * D& + 3ã Y& = (X& \ 1461) + Y&ã D& = (X& MOD 1461) \ 4 + 1ã X& = 5 * D& - 3ã M& = X& \ 153 + 1ã D& = (X& MOD 153) \ 5 + 1ãã IF M& < 11 THENã Month% = M& + 2ã ELSEã Month% = M& - 10ã END IFãã Day% = D&ã Year% = Y& + M& \ 11ãã DateX$ = MDY2Date$(Month%, Day%, Year%)ã Serial2Date$ = DateX$ãEND FUNCTIONããzabudsk@ecf.utoronto.ca COUNT TIMER TICKS COUNT,TIMER,TICKS Unknown Date (00:00) QB, QBasic, PDS 111 4829 TIMER.BAS DEFINT H, L, XãDEFDBL F, SãCLSãINPUT "Input scanning frequency: ", scanfreqãã'Initial CalculationsãTickFreq = 18.20678518# 'Number of Ticks per secondãTimerResolution = 65536 * TickFreq 'Used to change computer's tick freq.ãDelay = INT(TimerResolution / scanfreq) 'Calculates the delay betweenã 'clock ticks (Quantized)ãDelayL = Delay MOD 256 'Delay - Low ByteãDelayH = INT(Delay / 256) 'Delay - High byteãactualfreq = TimerResolution / Delay 'Actual frequency the computer isã 'operating atãresfrac = TickFreq / actualfreq 'A resulting fraction used to easilyã 'calculate the elapsed timeããPRINT "Press any key to start."ãWHILE INKEY$ = ""ãWENDãã'Set timer register to new timing rate (Timer now speeds up)ã'Elapsed time 1s will now show up using "TIMER" as > 1sãOUT &H43, &H36ãOUT &H40, DelayLãOUT &H40, DelayHãã'Reset time (TIMER=0)ãTIME$ = "00:00:00"ãPRINT "Press any key to stop."ããWHILE INKEY$ = ""ã LOCATE 4, 1ã PRINT USING "#####.####"; TIMER * resfracã 'Calculates actual elapsed time (TIMER-InitialTime)*resfracãWENDããFinalTime = TIMERã'gets final timeããCLSãPRINT "Total Elapsed Time: ";ãPRINT USING "#####.####"; FinalTime * resfracãã'Reset timer register - Normal time modeã'Important! returns timing mode to normal for DOSã'Some programs will not properly execute under a different timeã'speed mode.ãOUT &H43, &H36ãOUT &H40, 255ãOUT &H40, 255ããENDãã'Theory of operation:ã'Port 43h is some sort of computer paremeters registerã'function 36h changes the tick timer speed by accepting two bytes from dataã'register 40h.ã'^----This was gleaned from a (horribly complex) C++ program and prototypedã'into a QuickBasic program.ãã'From experimentation, a two byte integer is entered into the computer asã'a tick speed. The low byte is entered first (bits 0 to 7, 2^0 to 2^7) andã'the high byte second (bits 8 to 15, 2^8 to 2^15). This is expressed in myã'program as Delay, with DelayL and DelayH calculated. This corresponds toã'the delay between tick counts of the processor. (As I understand,ã'each tick an internal interrupt is called to update the clock. If TSRs areã'dependent on the system clock, they will also be called (the more TSRs,ã'the slower the response of the computer).ãã'I found that for a high number (Delay = 65535), the clock speed was identicalã'to the normal clock speed. For low numbers, the clock goes faster. For reallyã'low values, the clock speed slows down and stops at Delay=0. It gets dampenedã'by the fact that updating the clock and such takes a finite amount of time,ã'and can take longer than the tick delay time. Thus you need to find the bestã'scanning frequency for a particular computer. My 486DX266 can scan at aã'frequency of at least 15000 Hz, where my zenith 8086 laptop can scan up toã'maybe 1200 at best.ãã'After a scanning frequency is specified, it is converted to store in theã'computers memory by the equation: Delay = 65536 * (18.206../Scan frequency)ã'Only the integer portion of the delay is taken.ã'Thus the computers New tick frequency does not exactly match the scanã'frequency and our new frequency is calculated by the equation:ã' 65536 * 18.20678158ã'F = -------------------------------------ã' actual int(65536 * 18.20678158 / scanrate)ã'Thus F_actual is very close to the scan rate (within a few percent).ã'The new tick frequency will speed up the clock at a rate porportional toã'the tick frequency. with 18.2..Hz being the normal frequency,ã'the clock gets speeded up (F_actual/18.2..) times.ã'Thus our final actual time = TIMER / (F_actual/18.2...)ã' = TIMER * (18.2.../F_actual)ã'In our program, the scanning frequency is constant so we can set a constantã'to multiply the timer by to get the elapsed time in seconds (resfrac) in ourã'case.ãã'Well, good luck implementing this program, I had no trouble fitting thisã'code into an existing program (Race car timer). I just had to include theã'setup code at the beginning of the program and multiply all times byã'resfrac to get the elapsed time, worked like a charm.ãã'Sorry, I lost the original C program that had the wonderful TSR code toã'continuously set the tick timer to go faster. I do not know who toã'attribute for first supplying the addresses for the timer registers.ã'I didn't bother to fix the Midnight rollover problem or the resetted timeã'problems (no doubt easy enough to fix).ã'Any comments, questions, fixes, etc. direct to comp.lang.basic.misc orã'alt.lang.basic or Email to: zabudsk@ecf.utoronto.caã'Code can be freely distributed anywhere.ããSteve Halko SLEEP REPLACEMENT SLEEP,REPLACEMENT 06-30-92 (00:00) QB, QBasic, PDS 37 1142 NEWSLEEP.BAS 'NEWSLEEP.BAS by Steve Halko, 6-30-92ãã DEFINT A-Zã DECLARE FUNCTION ReadTimer& ()ã DECLARE SUB NewSleep (Ticks)ãã CALL NewSleep(18) 'Delay for 1 second or until key pressedã CALL NewSleep(0) 'Delay until key pressedãã SUB NewSleep (Ticks)ã 'This function is a replacement for SLEEP. It takes the numberã 'of system clock ticks as an argument, which gives you muchã 'finer control than QB's SLEEP. To emulate SLEEP with no arguments,ã 'use NewSleep(0). Unlike SLEEP, key presses are cleared from theã 'keyboard buffer.ãã StopTime& = ReadTimer& + Ticksã DO UNTIL ((ReadTimer& > StopTime&) AND Ticks) OR LEN(INKEY$)ã LOOPãã END SUBãã FUNCTION ReadTimer& STATICãã ã'[]=============================================================[]ã'[] Returns the number of clock ticks since midnightã'[] without invoking FP emulator like TIMER doesã'[]=============================================================[]ãã DEF SEG = &H40ã Lo& = PEEK(&H6C) + 256& * PEEK(&H6D)ã Hi& = PEEK(&H6E) + 256& * PEEK(&H6F)ãã ReadTimer& = (65536 * Hi&) + Lo&ãã END FUNCTIONãUnknown Author(s) TIME ZONES WORLDWIDE TIME,ZONES,WORLDWIDE Unknown Date (00:00) QB, QBasic, PDS 72 3785 TIMEZONE.BAS100 REM CONVERTING LOCAL TIME TO TIME ZONES WORLDWIDEã105 WIDTH 80ã110 GOTO 160: REM IBM BASICã120 PRINT STRING$(80, 45): RETURNã130 CLS : FOR X = 1 TO 10: PRINT : NEXT X: RETURNã140 PRINT : INPUT "PRESS >RETURN< (Q TO QUIT) ", R$: IF R$ = "Q" THEN 150 ELSE RETURNã150 GOSUB 130: GOSUB 120: PRINT TAB(38); "END.": GOSUB 120: ENDã160 TT$ = "THE TIME IN THE COUNTRY YOU ASKED FOR IS ": GOSUB 130: GOSUB 120ã170 GMT$ = "GREENWICH MEAN TIME IS ": ST$ = " STANDARD TIME"ã180 PRINT TAB(5); "THIS PROGRAM CONVERTS LOCAL TIME TO TIME ANYWHERE IN THE WORLD"ã190 GOSUB 120: GOSUB 140: GOSUB 130ã200 PRINT "DO YOU WANT TO CONVERT FROM LOCAL ": PRINTã210 PRINT 1, "STANDARD TIME": PRINT 2, "DAYLIGHT TIME": GOSUB 120ã220 INPUT "WHICH? ", WHICH: GOSUB 130: PRINT "DO YOU WANT TO CONVERT FROM": PRINTã230 PRINT 1, "EASTERN TIME": PRINT 2, "CENTRAL TIME": PRINT 3, "MOUNTIAN TIME"ã240 PRINT 4, "PACIFIC TIME": PRINT 5, "YUKON TIME": PRINT 6, "ALASKA/HAWAII TIME"ã250 PRINT 7, "BERING TIME": GOSUB 120: INPUT "WHICH? ", TIME: GOSUB 130: GOTO 370ã260 GOSUB 120: IF CTRY = 9 THEN 280 ELSE 270ã270 PRINT T$; TIME1; ":"; MINUTE$; " "; M$; ST$: GOTO 290ã280 MIN = MINUTE + 30: IF MIN > 59 THEN MIN = MIN - 60ã285 MIN$ = STR$(MIN): PRINT T$; TIME1; ":"; MIN$; " "; M$; ST$ã290 GOSUB 120: GOSUB 310ã300 PRINT GMT$; TIME2; ":"; MINUTE$; " "; M$: GOSUB 120: GOSUB 140: GOSUB 560ã310 TIME2 = HOUR + (TIME + 4): IF TIME2 > 12 THEN M$ = "PM" ELSE M$ = "AM"ã320 IF TIME2 > 24 THEN M$ = "AM"ã330 IF TIME2 > 24 THEN TIME2 = TIME2 - 24ã340 IF TIME2 > 12 THEN TIME2 = TIME2 - 12ã350 IF TIME2 < 1 THEN TIME2 = TIME2 + 12ã360 RETURNã370 PRINT "COUNTRIES (ALPHABETICALLY):": GOSUB 120ã380 PRINT 1, "ARGENTINA": PRINT 2, "BRAZIL": PRINT 3, "CHINA": PRINT 4, "ENGLAND": PRINT 5, "EGYPT"ã390 PRINT 6, "FRANCE": PRINT 7, "GERMANY": PRINT 8, "GREECE": PRINT 9, "INDIA": PRINT 10, "IRELAND"ã400 PRINT 11, "ISREAL": PRINT 12, "ITALY": PRINT 13, "JAPAN": PRINT 14, "KENYA"ã410 PRINT 15, "PHILIPPINES": PRINT 16, "PORTUGAL": PRINT 17, "RUSSIA (MOSCOW AREA)"ã420 PRINT 18, "SOUTH AFRICA": PRINT 19, "SPAIN": PRINT 20, "TURKEY": GOSUB 120ã430 INPUT "WHICH? ", CTRY: GOSUB 130: GOSUB 580: T$ = TT$: GOSUB 260ã440 TIME1 = TIME2 + GMT - TT: TIME2 = TIME1 - GMT + TTã450 IF TIME1 > 12 THEN M$ = "PM"ã460 IF TIME1 < 12 THEN M$ = "AM"ã470 IF TIME1 = 12 THEN 480 ELSE 490ã480 IF MINUTE = 0 THEN M$ = "NOON" ELSE M$ = "PM"ã490 IF TIME1 = 24 THEN 500 ELSE 510ã500 IF MINUTE = 0 THEN M$ = "MIDNIGHT" ELSE M$ = "AM"ã510 IF TIME1 > 24 THEN M$ = "AM"ã520 IF TIME1 > 24 THEN TIME1 = TIME1 - 24ã530 IF TIME1 > 12 THEN TIME1 = TIME1 - 12ã540 IF TIME1 < 1 THEN TIME1 = TIME1 + 12ã550 RETURNã560 GOSUB 130: INPUT "ANOTHER TIME CONVERSION?(Y/N) ", TC$ã570 IF TC$ <> "N" THEN GOSUB 130: GOTO 200 ELSE 150ã580 TT = TIME + 4: IF WHICH = 2 THEN TT = TT + 1ã590 INPUT "LOCAL TIME? (HOUR ONLY, NO MINUTES) ", HOURã600 INPUT "LOCAL TIME? (MINUTES) ", MINUTEã602 IF MINUTE = 0 THEN MINUTE$ = "00": GOTO 610ã604 MINUTE$ = STR$(MINUTE)ã606 IF LEFT$(MINUTE$, 1) = " " AND LEN(MINUTE$) = 2 THEN MINUTE$ = "0" + MID$(MINUTE$, 2, 1)ã610 INPUT "AM (A) OR PM (P)? ", AM$ã620 IF AM$ = "P" THEN HOUR = HOUR + 12ã630 TIME2 = HOUR + TTã640 IF CTRY = 4 OR CTRY = 10 OR CTRY = 16 THEN GMT = TTã650 IF CTRY = 6 OR CTRY = 7 OR CTRY = 12 OR CTRY = 19 OR CTRY = 8 THEN GMT = TT + 1ã660 IF CTRY = 20 OR CTRY = 11 OR CTRY = 18 OR CTRY = 5 THEN GMT = TT + 2ã670 IF CTRY = 14 OR CTRY = 17 THEN GMT = TT + 3ã680 IF CTRY = 1 OR CTRY = 2 THEN GMT = TT - 3ã690 IF CTRY = 9 THEN GMT = TT + 5ã700 IF MIN > 59 THEN MIN = MIN - 60 AND GMT = GMT + 1ã710 IF CTRY = 15 THEN GMT = TT + 10ã720 IF CTRY = 3 THEN GMT = TT + 8ã730 IF CTRY = 13 THEN GMT = TT + 9ã740 GOTO 440ãããGarry Spencer CALCULATES DAY OF THE WEEK gspencer@stim.tec.tn.us Unknown Date QB, QBasic, PDS 87 2349 WEEKDAY.BAS 'WEEKDAY.BAS - Function to calculate the day of the week when given theã' date in integer form: Mon%, Day%, Year% (year: 1582 to 2450)ã' Note: Returns (0=Sunday...6=Saturday) or -1 if an error occursã' Written by: Garry Spencer (gspencer@stim.tec.tn.us)ãã'To compile & link (stand-alone OBJ): BC WEEKDAY;ã ã'To add the WEEKDAY function to a library: LIB libname +WEEKDAY;ã ã'To compile a user program: BC progname/O;ã'and add the WEEKDAY function to it: LINK/EX progname WEEKDAY;ã ã'To Use:ãDECLARE FUNCTION WEEKDAY% (Mon%, Day%, Year%) 'do not use BYVALã'Example:ãCLSãPRINT : LOCATE 12, 12ãINPUT ; "Enter date (mm,dd,yyyy): ", Mon%, Day%, Year%ãDWeek% = WEEKDAY%(Mon%, Day%, Year%)ãPRINT " is a ";ããSELECT CASE DWeek%ã CASE 0ã PRINT "Sunday."ã CASE 1ã PRINT "Monday."ã CASE 2ã PRINT "Tuesday."ã CASE 3ã PRINT "Wednesday."ã CASE 4ã PRINT "Thursday."ã CASE 5ã PRINT "Friday."ã CASE 6ã PRINT "Saturday."ã CASE ELSEã PRINT "Error"ã END SELECTããFUNCTION WEEKDAY% (Mon%, Day%, Year%)ãDTmp% = 4: Days% = 0: Ofs% = 0: Leap% = 0: WEEKDAY% = -1ãIF Year% < 1582 OR Year% > 2450 OR Mon% < 1 OR Mon% > 12 OR Day% < 1 THEN EXIT FUNCTIONãFOR YTmp% = 1582 TO Year%ã DTmp% = (DTmp% + 1 + Leap%) MOD 7ã SELECT CASE 0ã CASE (YTmp% MOD 400)ã Leap% = 1ã CASE (YTmp% MOD 100)ã Leap% = 0ã CASE (YTmp% MOD 4)ã Leap% = 1ã CASE ELSEã Leap% = 0ã END SELECTãNEXT YTmp%ãFOR MTmp% = 1 TO Mon%: Ofs% = Ofs% + Days%ã SELECT CASE MTmp%ã CASE 1ã Days% = 31:ã CASE 2ã Days% = 28 + Leap%:ã CASE 3ã Days% = 31ã CASE 4ã Days% = 30:ã CASE 5ã Days% = 31:ã CASE 6ã Days% = 30ã CASE 7ã Days% = 31:ã CASE 8ã Days% = 31:ã CASE 9ã Days% = 30ã CASE 10ã Days% = 31ã CASE 11ã Days% = 30:ã CASE 12ã Days% = 31ã END SELECTãNEXT MTmp%ãIF Day% <= Days% THEN WEEKDAY% = (DTmp% + Ofs% + Day% - 1) MOD 7ãEND FUNCTIONããChris Tracy HOW MANY DAYS FidoNet QUIK_BAS Echo Year of 1993 QB, QBasic, PDS 85 2350 DAYS.BAS DECLARE SUB Days (M1, D1, Y1, M2, D2, Y2, N)ã ãDays 1, 1, 85, 1, 3, 93, NumberãPRINT "The number of days between 1/1/85 and 1/1/93 is:"; Numberã ãSUB Days (M1, D1, Y1, M2, D2, Y2, N)ã' How Many Days v1.0 - By Chris Tracyã' Credit goes to the person who originally wrote this routine in GWBASIC...ã' This routine can be used to find the number of days between ANY date.ã' It accounts for leap years, leap centuries, etc.ã ã' M1/D1/Y1 - The First Date (Ie. 1/1/85)ã' M2/D2/Y2 - The Last Date (Ie. 1/3/93)ã' N - The Value Returned.ã ã' See the main module of an example of how to use this routine.ãCheckVariables:ã IF M1 > 12 THEN GOTO EndTheSub:ã IF D1 > 31 THEN GOTO EndTheSub:ãMainBody:ã Y = Y1ã M = M1ã D = D1ã GOSUB FindDays:ã N = Aã Y = Y2ã D = D2ã M = M2ã GOSUB FindDays:ã N = A - Nã GOTO EndTheSub:ãFindDays:ã ON M GOTO Check1, Check2, Check1, Check3, Check1, Check3, Check1, Check1, Check3, Check1, Check3, Check1ã RETURNãCheck1:ã IF D > 31 THEN GOTO FindDays:ã GOTO DetermineDays:ãCheck2:ã IF Y / 4 <> INT(Y / 4) THEN GOTO Check4:ã IF Y / 400 = INT(Y / 400) THEN GOTO Check5:ã IF Y / 100 <> INT(Y / 100) THEN GOTO Check5:ãCheck4:ã IF D > 28 THEN GOTO Returner:ãCheck5:ã IF D > 29 THEN GOTO Returner:ã GOTO DetermineDays:ãCheck3:ã IF D > 30 THEN GOTO Returner:ãDetermineDays:ã SELECT CASE Mã CASE 1ã A = 0ã CASE 2ã A = 31ã CASE 3ã A = 59ã CASE 4ã A = 90ã CASE 5ã A = 120ã CASE 6ã A = 151ã CASE 7ã A = 181ã CASE 8ã A = 212ã CASE 9ã A = 243ã CASE 10ã A = 273ã CASE 11ã A = 304ã CASE 12ã A = 334ã END SELECTã A = A + Y * 365 + INT(Y / 4) + D + 1 - INT(Y / 100) + INT(Y / 400)ã IF INT(Y / 4) <> Y / 4 THEN GOTO Returner:ã IF Y / 400 = INT(Y / 400) THEN GOTO Returner:ã IF Y / 100 = INT(Y / 100) THEN GOTO Returner:ã IF M > 2 THEN GOTO Returner:ã A = A - 1ãReturner:ã RETURNãEndTheSub:ã END SUBãZachary Becker UNIVERSAL TIME ZONE FINDER Night Owl v10 CD-ROM Year of 1993 QB, QBasic, PDS 62 2282 UTZ.BAS 'This program will determine the current coordinated universal time (UTC)ã'in any one of the 5 time zones in the United States, plus the Atlanticã'time zone. This program will adjust for daylight savings time.ãããDECLARE SUB pause ()ã0 CLSã10 PRINT " Coordinated Universal Time Finder for the United States"ã15 PRINT ""ã20 PRINT " U U TTTTTTTT ZZZZZZZZZ "ã30 PRINT " U U TT ZZ"ã40 PRINT " U U TT ZZ"ã50 PRINT " U U TT ZZ"ã60 PRINT " UUUU TT ZZZZZZZZZ"ã70 PRINT ""ã100 PRINT "Copyright 1993 by Zachary Becker. All Rights Reserved. "ã105 PRINT " Version 1.0 Use this program at your OWN RISK. No warranties"ã106 PRINT "either expressed or implied are given and the author is not liable"ã107 PRINT "for any damage to any property or person resulting from use of "ã108 PRINT "this program. THIS VERSION (1.0) may be distributed freely, as shareware"ã109 PRINT "in its ENTIRE and ORIGINAL form ONLY. DO NOT TAMPER."ãpauseã110 CLSã120 PRINT "Do you wish to continue? (Y/N)"ã130 INPUT b$ã140 IF b$ = "N" OR b$ = "n" THEN GOTO 155ã150 IF b$ = "Y" OR b$ = "y" THEN GOTO 160ã155 PRINT "Have a nice day!"; CHR$(1)ã157 ENDã160 CLSã170 PRINT "What is the local time right now? (Please type as a 24 hour numeral.)"ã180 INPUT cã190 CLSã200 PRINT "What time zone are you in now?"ã210 PRINT " H-Hawaii or Alaska"ã220 PRINT " P-Pacific"ã230 PRINT " M-Mountain"ã240 PRINT " C-Central"ã250 PRINT " E-Eastern"ã260 PRINT " A-Atlantic"ã270 INPUT d$ã280 IF d$ = "H" OR d$ = "h" THEN LET e = c + 1000ã290 IF d$ = "P" OR d$ = "p" THEN LET e = c + 800ã300 IF d$ = "M" OR d$ = "m" THEN LET e = c + 700ã310 IF d$ = "C" OR d$ = "c" THEN LET e = c + 600ã320 IF d$ = "E" OR d$ = "e" THEN LET e = c + 500ã330 IF d$ = "A" OR d$ = "a" THEN LET e = c + 400ã340 CLSã350 PRINT "Are you on daylight savings time now? (Y/N) "ã360 INPUT f$ã370 IF f$ = "N" OR f$ = "n" THEN LET e = eã380 IF f$ = "Y" OR f$ = "y" THEN LET e = e - 100ã390 CLSã400 IF e > 2400 THEN LET e = e - 2400ã440 PRINT "The correct coordinated universal time is "; e; " hours."ã450 GOTO 120ããSUB pauseãFOR a = 1 TO 200000ãNEXT aãEND SUBããPeter Norton VISUAL CLOCK DISPLAY Advanced BASIC Book Unknown Date QB, QBasic, PDS 15 566 CLOCK.BAS SCREEN 8ã DRAW "BU50 NL25 F12 D20 G12 L50 H12 U20 E12 R25 BD22"ã DOã TimeMark! = TIMERã Hours! = INT(TimeMark! / 3600)ã Remainder! = TimeMark! - 3600 * Hours!ã IF Hours! > 12 THEN Hours! = Hours! - 12ã HourAngle! = -Hours! / 12 * 360ã Minutes! = INT(Remainder! / 60)ã MinuteAngle! = -Minutes! / 60 * 360ã DRAW "TA=" + VARPTR$(HourAngle!) + " NU8"ã DRAW "TA=" + VARPTR$(MinuteAngle!) + " NU12"ã LOCATE 15, 34: PRINT TIME$ã LOOP UNTIL INKEY$ = CHR$(27)ããMatt Pritchard TIMER FUNCTIONS FidoNet QUIK_BAS Echo 09-30-92 (09:42) QB, QBasic, PDS 39 1091 TIMERS.BAS '>Start! = TIMER 'Start! had to be a single so it can handle the maã'> 'amount that timer returns (86400) and so it can saveã'> ' the decimal place.ããã'>> Do the peeks directly and use an INTEGER or LONG.... It'll be a wholeã'>> lot faster than involving floating point...ãã'>How can I do that? I got SMALLEXE.BAS from the QB news and it had aã'>TIMER replacement, but after midnight, it wouldn't reset to 0!ã'> And it hardley ever returned the same thing as TIMER (itã'>started out at 4 million whenever I ran the program!)!ããYou can do this:ãã DEF SEG = 0ã TimerLo% = PEEK (&h046C)ãã (or)ãã TimerFull& = PEEK (&h046C) + 256& * PEEK(&h046D)ãã or in assembly ...ãã;TIMERCOUNT - QuickBASIC 4.5 File Timer Value Returned: ;DECLAREãFUNCTION TIMERCOUNT% ;Count = TIMERCOUNT% ;ãã PUBLIC TIMERCOUNTããTIMERCOUNT PROC FARãã XOR AX,AX ;Segment = 0000ã MOV ES,AXã MOV AX,ES:[046Ch] ;Get Timer Word..ãã RETããTIMERCOUNT ENDPããKurt Kuzba DELAY TIMERS FidoNet QUIK_BAS Echo 11-06-95 (15:00) QB, QBasic, PDS 76 3129 QBDELAY.BAS 'Someone wrote:ãã'> Does anybody have a routine to pause a program for aã'> certain amount of time before continuing? Thankyou.ã'>......................................................ãã'Kurt Kuzba Replied:ãã' Generally, SLEEP is sufficient, but sometimes you need aã'finer resolution or the ability to ignore keypresses.ã' You may use the DOS internal clock, which allows a minimumã'delay of 0.054931641 seconds. The DOS clock increments at aã'rate of 18.20444444 times per second.ã' You may also use the vertical retrace, though I have been toldã'that it is not recommended. This allows a more precise control.ã'This allows increments of 0.0014285714 seconds. The Video Retraceã'usually occurs at a rate of 70 times per second, but may changeã'due to use of different hardware on various systems.ã' You may also use the Programmable Interrupt Timer at hardwareã'port (&H40), or 64 decimal, allowing an adjustable delay, whichã'depends on the speed of your processor. The PIT calibrationã'FUNCTION attempts to read the PIT based on the DOS clock and setã'the delay interval accordingly. It has not been tested and mayã'lose accuracy at greater speeds with better processors, so itã'should only be used in personal use software on known systems,ã'or require configuration to individual setups. I haven't the rangeã'of hardware to test for other processors and conditions.ãã'_|_|_| QBDELAY.BASã'_|_|_| This program utilizes three different delay timers.ã'_|_|_| Each uses the same method but employs a differentã'_|_|_| measure. DOSDelay uses the internal DOS clock.ã'_|_|_| VRTDelay uses the VIDEO hardware interrupt retrace.ã'_|_|_| PITDelay uses the hardware interrupt Programmableã'_|_|_| Interrupt Timer. Each will generate a 10 second delay.ã'_|_|_| Released to the Public Domain by Kurt KuzbaãDECLARE FUNCTION PITcal& ()ãDECLARE SUB PITDelay (seconds!)ãDECLARE SUB DOSDelay (seconds!)ãDECLARE SUB VRTDelay (seconds!)ãCOLOR 2, 0: CLS : DIM SHARED PIT(1) AS LONGãPRINT "DOSDelay : "; TIME$: DOSDelay 10ãPRINT " "; TIME$: COLOR 9ãPRINT "VRTDelay : "; TIME$: VRTDelay 10ãPRINT " "; TIME$: COLOR 15ãPIT(0) = PITcal: COLOR 12ãPRINT "PIT calibrated at"; PIT(0); "increments per second."ãCOLOR 14ãPRINT "PITDelay : "; TIME$: PITDelay 10ãPRINT " "; TIME$ãSUB DOSDelay (seconds!)ã DEF SEG = 0ã d& = FIX(seconds! * 18.20444444#)ã FOR t& = t& TO d&ã d% = PEEK(&H46C) AND 255ã WHILE d% = (PEEK(&H46C) AND 255): WENDã NEXTãEND SUBãFUNCTION PITcal&ã p& = 0: DEF SEG = 0: x% = (PEEK(&H46C) + 1) AND 255ã WHILE x% <> (PEEK(&H46C) AND 255): WENDã WHILE x% = (PEEK(&H46C) AND 255)ã p& = p& + 33ã FOR t% = 1 TO 19: WAIT (64), 128, 128: WAIT (64), 128: NEXTã WENDã PITcal& = p& * 11.02ãEND FUNCTIONãSUB PITDelay (seconds!)ã d& = FIX(seconds! * PIT(0))ã FOR t& = 0 TO d&: WAIT 64, 128: WAIT 64, 128, 128: NEXTãEND SUBãSUB VRTDelay (seconds!)ã d& = FIX(seconds! * 70)ã FOR t& = 0 TO d&: WAIT (&H3DA), 8: WAIT (&H3DA), 8, 8: NEXTãEND SUBã'_|_|_| end QBDELAY.BASãJack Hudgions TIME SLICING FidoNet QUIK_BAS Echo 10-29-95 (10:52) QB, PDS 65 1970 TIMSLICE.BAS'These routines assume the declarations for the interrupt structures areã'present (QB.BI or QBX.BI), and that the QB.QLB or QBX.QLB quick libraryã'is loaded.ãã'For Windows, it's first necessary to retrieve the DOS version:ãã' Get DOS versionãInReg.AX = &H3306ãCALL Interrupt(&H21, InReg, OutReg)ãDOSver = ((OutReg.BX AND 255) * 100) + (OutReg.BX \ 256)ãIF DOSver = 0 THENã InReg.AX = &H3000ã CALL Interrupt(&H21, InReg, OutReg)ã DOSver = ((OutReg.AX AND 255) * 100) + (OutReg.AX \ 256)ãEND IFãã'This returns the version as an integer for simplicity (300 = DOS 3.00,ã'620 = DOS 6.20, etc.).ãã'Next, call the following function to detect Windows (If you attempt toã'execute this code under DOS 2.x, it will lock up):ãã' Check for WindowsãIF DOSver >= 300 THENã InReg.AX = &H160Aã CALL Interrupt(&H2F, InReg, OutReg)ã IF OutReg.AX <> 0 THENã WinMode = 0ã ELSEã WinMode = OutReg.CXã END IFãEND IFãã'The variable WinMode will be set as follows:ãã' 0 = Windows not detectedã' 1 = Real mode detected (Win 3.0 and earlier only)ã' 2 = Standard mode detected.ã' 3 = 386 enhanced mode detected.ãã'For OS/2, check the DOS version, and if it's 20 or higher, your programã'is running under OS/2 2.0 or later:ãã' Check for OS/2 by checking if DOS ver >= 20.ãIsOS2 = DOSver >= 2000ãã'The variable IsOS2 will be zero (false) if OS/2 is not detected, or -1ã'(true) if OS/2 is detected. You can also use the DOS version toã'determine the OS/2 version. I believe these are correct:ãã' OS/2 version DOS version returnedã' 2.0 20.0ã' 2.1 20.1ã' 2.11 20.2ã' 3.0 20.3ãã'Once you have this information, giving up timeslices is a snap. Simplyã'insert this code wherever your program awaits input:ãã' Give up timeslices under Windows or OS/2ãIF WinMode = 3 OR IsOS2 THENã InReg.AX = &H1680ã CALL Interrupt(&H2F, InReg, OutReg)ãEND IFããKurt Kuzba VERTICAL RETRACE DELAY FidoNet QUIK_BAS Echo 07-21-95 (16:50) QB, QBasic, PDS 42 1876 SCANTIMR.BAS'Does anybody know how stable this routine might be?ã'Would it be necessary to test the scan intervals in a secondã'in order to achieve accuracy, or would assumption of 70 scansã'per second be correct in all cases. With a resolution of 70:secã'we get accuracy to .014285714 seconds, which is quite a bitã'better than the DOS clock at &H46C, with a resolution of 18:secã'and an accuracy to .054931641 seconds. It would only take twoã'seconds to run a test of the number of scans per second.ã'Even with a slower video system, with a resolution of 60:secã'we get accuracy to .016666667 seconds, or .02 with 50:sec.ã'I'd like to avoid the routine to read the scans per second, which isã' scans% = 0ã' begin& = timerã' WHILE begin& = timer: WENDã' begin& = timerã' WHILE begin& = timerã' WHILE (INP(&H3DA) AND 8): WENDã' WHILE (INP(&H3DA) AND 8) = 0: WENDã' scans% = scans% + 1ã' WENDã'but I fear it would be necessary unless the program specified VGA only.ã'And does anybody know what is at I/O port 65, and what it is for?ãã' [=-=] SCANTIMR.BAS [=-=] [=-=] [=-=] [=-=] [=-=] [=-=] [=-=]ã' [=-=] This program demonstrates a method for using the [=-=]ã' [=-=] vertical retrace as a program timer. [=-=]ã' [=-=] Released to the Public Domain by Kurt Kuzba [=-=]ã' [=-=] [=-=] [=-=] [=-=] [=-=] [=-=] [=-=] [=-=] [=-=] [=-=] [=-=]ãCOLOR 9, 0: CLSãINPUT "Seconds to pause"; s!ãPRINT "Pausing for"; INT(s! * 70); "scan intervals."ã'PRINT "begin "; TIME$ãPRINT "begin "; TIMER '<-- Added by Carl!ãFOR t% = 0 TO INT(s! * 70)ã WHILE (INP(&H3DA) AND 8): WENDã WHILE (INP(&H3DA) AND 8) = 0: WENDãNEXTã'PRINT "end "; TIME$ãPRINT "end "; TIMER '<-- Added by Carl!ã'BEEPãWHILE INKEY$ = "": WENDã' [=-=] SCANTIMR.BAS [=-=] [=-=] [=-=] [=-=] [=-=] [=-=] [=-=]ãDouglas Lusher CLOCK SET FidoNet QUIK_BAS Echo 11-01-94 (00:00) QB, QBasic, PDS 234 7102 CLOCKSET.BAS'Well, here we are at daylight saving time again. Thought Iã'would repost this bit of code to set the time and date inã'a computer by calling the NIST (National Institute ofã'Standards and Technology) and obtaining the correct valuesã'from their atomic clock. Just a note for those of you whoã'may have gotten this code from when I have posted it inã'the past: this is an updated version, there were a coupleã'of subtle bugs in the previously posted versions.ãã DEFINT A-Zã CONST False = 0, True = NOT Falseã CONST Modem = 1ãã TimeOut$ = "*** Time limit exceeded, program aborted"ã Abort$ = "*** Program aborted from keyboard"ãã PhoneNumber$ = "1-303-494-4774"ã 'this is the phone number for the National Institute for Standardsã 'and Technology in Colorado. It's the number I use for settingã 'my computer's clock, so the rest of the program is written to useã 'it. Listed below are some other numbers that you can call byã 'modem for the same purpose, but I don't know anything about theã 'service and info they provide.ãã 'PhoneNumber$ = "1-202-653-0351"ã 'the United States Naval Observatory in Anapolis, Marylandãã 'PhoneNumber$ = "07-2217033" ' Brisbane, Australiaã 'PhoneNumber$ = "03-6001641" ' Melbourne, Australiaãã ComSpec$ = "COM1:1200,N,8,1,BIN,CS0,DS0"ã 'Change this ComSpec$ if your modem is on a different serial port.ã '1200 baud and 300 baud are the only speeds available at NISTãã ON ERROR GOTO HandleErrorã WIDTH 80ã PRINTã PRINT "CLOCKSET.BAS"ã PRINT "A program to set the clock/calendar of an IBM compatible"ã PRINT "computer after obtaining the correct date and time via modem."ã PRINT "Written by Douglas H. Lusher, 11-01-1994"ã PRINTã PRINT "Time Zone? astern, entral, ountain,

acific: ";ã DOã LOCATE , , 1: Ky$ = INPUT$(1): LOCATE , , 0ã IF Ky$ = CHR$(27) THEN PRINT : PRINT Abort$: ENDã Ky$ = UCASE$(Ky$)ã TZ% = INSTR("ECMP", Ky$)ã IF TZ% THEN PRINT Ky$: TZ% = TZ% + 4: EXIT DOã BEEPã LOOPã 'If you require other time zones, the above code will haveã 'to be altered. For Alaska, TZ% must be set equal to 9.ã 'For Hawaii, set TZ% equal to 11.ãã PRINT "Daylight Savings Time? es, o: ";ã DOã LOCATE , , 1: Ky$ = INPUT$(1): LOCATE , , 0ã IF Ky$ = CHR$(27) THEN PRINT : PRINT Abort$: ENDã Ky$ = UCASE$(Ky$)ã IF Ky$ = "Y" OR Ky$ = "N" THEN PRINT Ky$: EXIT DOã BEEPã LOOPã IF Ky$ = "Y" THEN TZ% = TZ% - 1ãã Abort% = Falseã OPEN ComSpec$ FOR RANDOM AS #Modemã PRINT #Modem, "ATZ"ã Start! = TIMERã DOã IF LineReceived(ModemInput$) THENã IF INSTR(ModemInput$, "OK") THEN EXIT DOã ELSEIF INKEY$ = CHR$(27) THENã PRINT : PRINT Abort$: Abort% = True: EXIT DOã ELSEIF TimeSince!(Start!) > 20 THENã PRINT : PRINT TimeOut$: Abort% = True: EXIT DOã END IFã LOOPãã IF Abort% THEN GOTO ProgramEndãã SLEEP (3)ã PRINT #Modem, "ATDT"; PhoneNumber$ã Start! = TIMERã DOã IF LineReceived(ModemInput$) THENã IF INSTR(ModemInput$, "CONNECT") THENã EXIT DOã ELSEIF INSTR(ModemInput$, "BUSY") THENã Abort% = True: EXIT DOã ELSEIF INSTR(ModemInput$, "NO CARRIER") THENã Abort% = True: EXIT DOã ELSEIF INSTR(ModemInput$, "ERROR") THENã Abort% = True: EXIT DOã END IFã ELSEIF INKEY$ = CHR$(27) THENã PRINT : PRINT Abort$: Abort% = True: EXIT DOã ELSEIF TimeSince!(Start!) > 30 THENã PRINT : PRINT TimeOut$: Abort% = True: EXIT DOã END IFã LOOPãã IF Abort% THEN GOTO ProgramEndãã Start! = TIMERã LineCount% = 0ã DOã IF LineReceived(ModemInput$) THENã 'discard the first few lines to allow the connectionã ' to stabilizeã LineCount% = LineCount% + 1ã IF LineCount% > 10 THENã GOSUB SetClockã IF ClockSet% THEN EXIT DOã ELSEIF INSTR(ModemInput$, "NO CARRIER") THENã EXIT DOã ELSEIF INSTR(ModemInput$, "ERROR") THENã EXIT DOã END IFã ELSEIF INKEY$ = CHR$(27) THENã PRINT : PRINT Abort$: EXIT DOã ELSEIF TimeSince!(Start!) > 30 THENã PRINT : PRINT TimeOut$: EXIT DOã END IFã LOOPãã ProgramEnd:ã PRINT #Modem, "+++";ã Start! = TIMERã DO UNTIL TimeSince!(Start!) > 2: LOOPã PRINT #Modem, "ATH0"ã Start! = TIMERã DOã IF LineReceived(ModemInput$) THENã IF INSTR(ModemInput$, "OK") THEN EXIT DOã ELSEIF TimeSince!(Start!) > 20 THENã EXIT DOã END IFã LOOPã CLOSE #Modemã ENDãã SetClock:ã 'lines containing the date and time info areã '50 characters long and end with a "*" or "#"ã IF LEN(ModemInput$) <> 50 THENã ClockSet% = False: RETURNã END IFã IF MID$(ModemInput$, 50) <> "*" AND MID$(ModemInput$, 50) <> "#" THENã ClockSet% = False: RETURNã END IFã 'get the date info from the lineã D$ = MID$(ModemInput$, 10, 5) + "-19" + MID$(ModemInput$, 7, 2)ã IF VAL(MID$(ModemInput$, 7, 2)) < 94 THEN MID$(D$, 7, 2) = "20"ã 'get the time infoã T$ = MID$(ModemInput$, 16, 8)ã 'alter the time for the desired time zoneã Hour% = VAL(T$) - TZ%ã IF Hour% < 0 THENã 'some adjustments will be necessaryã Hour% = Hour% + 24ã Day% = VAL(MID$(D$, 4, 2)) - 1ã IF Day% = 0 THENã Month% = VAL(MID$(D$, 1, 2)) - 1ã SELECT CASE Month%ã CASE 0ã Day% = 31ã Month% = 12ã Year% = VAL(MID$(D$, 7, 4)) - 1ã MID$(D$, 7, 4) = RIGHT$(STR$(Year%), 4)ã CASE 1, 3, 5, 7, 8, 10ã Day% = 31ã CASE 4, 6, 9, 11ã Day% = 30ã CASE 2ã Day% = 28ã Year% = VAL(MID$(D$, 7, 4))ã IF LeapYear(Year%) THEN Day% = 29ã END SELECTã MID$(D$, 1, 2) = RIGHT$(STR$(Month% + 100), 2)ã END IFã MID$(D$, 4, 2) = RIGHT$(STR$(Day% + 100), 2)ã END IFã MID$(T$, 1, 2) = RIGHT$(STR$(Hour% + 100), 2)ã PRINT STRING$(58, "*")ã PRINT " Current settings: Date: "; DATE$, "Time: "; TIME$ã DATE$ = D$: TIME$ = T$ã PRINT " Corrected to: Date: "; DATE$, "Time: "; TIME$ã PRINT STRING$(58, "*"): PRINTã ClockSet% = Trueã RETURNãã HandleError:ã ErrCode% = ERRã IF ErrCode% = 57 THENã Err57% = Err57% + 1ã IF Err57% <= 5 THENã RESUMEã ELSEã PRINT "Program terminated; too many I/O errors."ã RESUME ProgramEndã END IFã ELSEã PRINT "ERROR:"; ErrCode%; "- Program terminated."ã RESUME ProgramEndã END IFãã FUNCTION LeapYear% (Year%) STATICã 'returns True (-1) if the specified year is a leap yearã LY% = (Year% MOD 4 = 0) AND (Year% MOD 100 <> 0)ã LY% = LY% OR (Year% MOD 400 = 0)ã LeapYear% = LY%ã END FUNCTIONãã FUNCTION LineReceived (Received$) STATICã CRLF$ = CHR$(13) + CHR$(10)ã LineReceived = Falseã IF LOC(Modem) THENã NewChars$ = INPUT$(LOC(Modem), #Modem)ã PRINT NewChars$;ã Buffer$ = Buffer$ + NewChars$ã LineEnd% = INSTR(Buffer$, CRLF$)ã IF LineEnd% THENã Received$ = LEFT$(Buffer$, LineEnd% - 1)ã Buffer$ = MID$(Buffer$, LineEnd% + 2)ã LineReceived = Trueã END IFã END IFã END FUNCTIONãã FUNCTION TimeSince! (Mark!)ã TimeNow! = TIMERã TimeSince! = (TimeNow! - ((TimeNow! < Mark!) * 86400)) - Mark!ã END FUNCTIONãSteve M. Wiegand CALCULATE DAY OF WEEK stevewie@ksc9.th.com 04-21-96 (16:23) QB, QBasic, PDS 729 28534 DAYOWEEK.BAS'This program will calculate a day of the week for any year from 1753 to 2030ããDEFINT A-ZãDECLARE SUB TRANSLATE ()ãDECLARE SUB LETTERS ()ãDECLARE SUB LAYER1 ()ãDECLARE SUB NORMAL1 ()ãDECLARE SUB NORMAL0 ()ãDECLARE SUB Initialize ()ãDECLARE SUB FancyCls (dots%, Background%)ãDECLARE SUB Center (Row%, text$)ãDECLARE SUB OPENINTRO ()ãDECLARE SUB Box (Row1%, Col1%, Row2%, Col2%)ãDECLARE SUB PAUSE ()ãDECLARE SUB DAYERROR ()ãDECLARE SUB inputerror ()ãDECLARE FUNCTION GetNum# (Row%, Col%)ãCONST TRUE = -1ãCONST FLASE = NOT TRUEãCONST BYEAR = 1753ãCOMMON SHARED P$(), P$, SIZE$ãCOMMON SHARED C1$, C2$, C3$ãCOMMON SHARED C4$, BGC, DOT$ãCOMMON SHARED SPACING$, Word$ãCOMMON SHARED PFT, PFLãCOMMON SHARED m, d, y, nt%ãDIM P$(122)ãDIM SHARED ColorprefãDIM SHARED Colors(0 TO 20, 1 TO 4)ãDIM SHARED year%(278)ãDIM SHARED M1%(12), M2%(12), M3%(12), M4%(12), M5%(12), M6%(12), M7%(12)ãDIM SHARED M8%(12), M9%(12), M10%(12), M11%(12), M12%(12), M13%(12), M14%(12)ãDIM SHARED d1%(31), d2%(31), d3%(31), d4%(31), d5%(31), d6%(31), d7%(31)ãDIM SHARED dn$(7)ãDIM SHARED mn$(12): DIM SHARED mnu%(12)ãCALL LETTERS 'CALL LETTERSETã'ã' Begin Mainline Codeã'ãInitializeãOPENINTROãBEGIN:ãColorpref = 1ãFancyCls Colors(2, Colorpref), Colors(1, Colorpref)ãBox 9, 19, 15, 61ãCOLOR 7, 0ãCenter 11, "Enter the Century and Year (CCYY)"ãnt% = 1ãy = GetNum#(13, 38)ãFancyCls Colors(2, Colorpref), Colors(1, Colorpref)ãBox 9, 19, 15, 61ãCOLOR 7, 0ãCenter 11, "Enter the Month of the Year (01-12)"ãnt% = 2ãm = GetNum#(13, 39)ãFancyCls Colors(2, Colorpref), Colors(1, Colorpref)ãBox 9, 19, 15, 61ãCOLOR 7, 0ãCenter 11, "Enter the Day of the Month (01-31)"ãnt% = 3ãd = GetNum#(13, 39)ãDATEEDIT:ãIF m = 2 THENã z% = y MOD 4ã IF z% = 0 THENã mnu%(2) = 29ã END IFãEND IFãIF d > mnu%(m) THENã CALL DAYERRORã CALL PAUSEã GOTO doagainãEND IFãINDEX1 = (y - BYEAR) + 1ãINDEX2 = year%(INDEX1)ãSELECT CASE INDEX2ã CASE IS = 1ã index3 = M1%(m)ã CASE IS = 2ã index3 = M2%(m)ã CASE IS = 3ã index3 = M3%(m)ã CASE IS = 4ã index3 = M4%(m)ã CASE IS = 5ã index3 = M5%(m)ã CASE IS = 6ã index3 = M6%(m)ã CASE IS = 7ã index3 = M7%(m)ã CASE IS = 8ã index3 = M8%(m)ã CASE IS = 9ã index3 = M9%(m)ã CASE IS = 10ã index3 = M10%(m)ã CASE IS = 11ã index3 = M11%(m)ã CASE IS = 12ã index3 = M12%(m)ã CASE IS = 13ã index3 = M13%(m)ã CASE IS = 14ã index3 = M14%(m)ãEND SELECTãSELECT CASE index3ã CASE IS = 1ã bd% = d1%(d)ã CASE IS = 2ã bd% = d2%(d)ã CASE IS = 3ã bd% = d3%(d)ã CASE IS = 4ã bd% = d4%(d)ã CASE IS = 5ã bd% = d5%(d)ã CASE IS = 6ã bd% = d6%(d)ã CASE IS = 7ã bd% = d7%(d)ãEND SELECTãFancyCls Colors(2, Colorpref), Colors(1, Colorpref)ãBox 9, 19, 15, 61ãCOLOR 7, 0ãIF bd% > 7 OR bd% < 0 THENã LOCATE 10, 20, 0ã PRINT "Calculation Error - bd%"ã LOCATE 11, 41, 0ã PRINT bd%ã GOTO finishãEND IFãz1$ = mn$(m): z2$ = STR$(d): z3$ = STR$(y): z4$ = z1$ + " " + z2$ + z3$ãA$ = "The date entered is a " + dn$(bd%)ãCenter 10, z4$ãCenter 12, A$ãA$ = ""ãPAUSEãdoagain:ãFancyCls Colors(2, Colorpref), Colors(1, Colorpref)ãBox 9, 19, 15, 61ãCOLOR 7, 0ãCenter 12, "Do another date ? [Y/N]"ãLOCATE 14, 40, 1ãWHILE INKEY$ <> "": WENDãDOã kbd$ = UCASE$(INKEY$)ãLOOP UNTIL kbd$ = "Y" OR kbd$ = "N"ãIF kbd$ = "Y" THENã mnu%(2) = 28ã GOTO BEGINãEND IFãCLSãSYSTEMãfinish:ãENDãã'The following data defines the color schemes available via the main menu.ã'ã' scrn dots bar back title shdow choice curs cursbk shdowãDATA 0, 7, 15, 7, 0, 7, 0, 15, 0, 0ãDATA 1, 9, 12, 3, 0, 1, 15, 0, 7, 0ãDATA 3, 15, 13, 1, 14, 3, 15, 0, 7, 0ãDATA 7, 12, 15, 4, 14, 0, 15, 15, 1, 0ãã'Box:ã' Draw a box on the screen between the given coordinates.ãSUB Box (Row1, Col1, Row2, Col2) STATICã COLOR 14, 0ã BoxWidth = Col2 - Col1 + 1ãã LOCATE Row1, Col1ã PRINT "Ú"; STRING$(BoxWidth - 2, "Ä"); "¿";ãã FOR A = Row1 + 1 TO Row2 - 1ã LOCATE A, Col1ã PRINT "³"; SPACE$(BoxWidth - 2); "³";ã NEXT Aãã LOCATE Row2, Col1ã PRINT "À"; STRING$(BoxWidth - 2, "Ä"); "Ù";ããEND SUBããDEFSNG A-Zã'Center:ã' Center text on the given row.ãSUB Center (Row%, text$)ãDEFINT A-Zã LOCATE Row, 41 - LEN(text$) / 2ã PRINT text$;ãEND SUBããSUB DAYERRORãz1$ = STR$(m)ãz2$ = STR$(d)ãz3$ = STR$(y)ãLINE (158, 235)-(390, 249), 7, BãLINE (159, 236)-(389, 248), 15, BFãWord$ = " " + z1$ + "/" + z2$ + "/" + z3$ãSPACING$ = "R0"ãSIZE$ = " 4"ãDOT$ = "N"ãBGC = 15ãCALL TRANSLATEãC1$ = "C 4"ãC2$ = "C12"ãPFT = 245: PFL = 163: CALL NORMAL1ãLINE (158, 262)-(390, 274), 7, BãLINE (159, 263)-(389, 273), 15, BFãWord$ = "The day of the month is invalid"ãSPACING$ = "R0"ãSIZE$ = " 4"ãDOT$ = "N"ãBGC = 15ãCALL TRANSLATEãC1$ = "C 4"ãC2$ = "C12"ãPFT = 272: PFL = 163: CALL NORMAL1ãLINE (158, 279)-(415, 291), 7, BãLINE (159, 280)-(414, 290), 15, BFãx$ = STR$(mnu%(m))ãWord$ = "The month you selected has " + x$ + " days"ãSPACING$ = "R0"ãSIZE$ = " 4"ãDOT$ = "N"ãBGC = 15ãCALL TRANSLATEãC1$ = "C 4"ãC2$ = "C12"ãPFT = 289: PFL = 163: CALL NORMAL1ãLEAPYRERROR:ãIF m < 2 OR m > 2 THENã GOTO exitsubãEND IFãIF d > 29 THENã GOTO exitsubãEND IFãLINE (158, 296)-(415, 308), 7, BãLINE (159, 297)-(414, 307), 15, BFãWord$ = "The year is not a leap year"ãSPACING$ = "R0"ãSIZE$ = " 4"ãDOT$ = "N"ãBGC = 15ãCALL TRANSLATEãC1$ = "C 4"ãC2$ = "C12"ãPFT = 306: PFL = 163: CALL NORMAL1ããexitsub:ãEND SUBããDEFSNG A-Zã'FancyCls:ã' Clears screen in the right color, and draws nice dots.ãSUB FancyCls (dots%, Background%)ãDEFINT A-Zã VIEW PRINT 7 TO 25ã COLOR dots, Backgroundã CLS 2ãã FOR A = 560 TO 1820 STEP 45ã Row = A / 80 + 1ã Col = A MOD 80 + 1ã LOCATE Row, Colã PRINT CHR$(250);ã NEXT AãEND SUBãã'GetNum:ã' Gets valid numeric input from userã'Parameters:ã' Row, Col - location to echo inputãFUNCTION GetNum# (Row, Col)ã result$ = ""ã Done = FALSEã WHILE INKEY$ <> "": WEND 'Clear keyboard bufferãã DO WHILE NOT Doneãã LOCATE Row, Colã PRINT result$; CHR$(95); " ";ã ã kbd$ = INKEY$ã SELECT CASE kbd$ã CASE "0" TO "9"ã result$ = result$ + kbd$ã CASE "."ã IF INSTR(result$, ".") = 0 THENã result$ = result$ + kbd$ã END IFã CASE CHR$(13)ã IF (VAL(result$) > 2030 OR VAL(result$) < 1753) AND nt% = 1 THENã result$ = ""ã CALL inputerrorã ELSEã IF (VAL(result$) > 12 OR VAL(result$) < 1) AND nt% = 2 THENã result$ = ""ã CALL inputerrorã ELSEã IF (VAL(result$) > 31 OR VAL(result$) < 1) AND nt% = 3 THENã result$ = ""ã CALL inputerrorã ELSEã Done = TRUEã END IFã END IFã END IFã ã CASE CHR$(8)ã IF LEN(result$) > 0 THENã result$ = LEFT$(result$, LEN(result$) - 1)ã END IFã CASE ELSEã IF LEN(kbd$) > 0 THENã BEEPã END IFã END SELECTã LOOPãã LOCATE Row, Colã PRINT result$; " ";ãã GetNum# = VAL(result$)ã'ãEND FUNCTIONãã'Initialize:ã' Read colors in and set up assembly routinesãSUB Initializeãyear%(1) = 1: year%(2) = 2: year%(3) = 3: year%(4) = 11: year%(5) = 6: year%(6) = 7ãyear%(7) = 1: year%(8) = 9: year%(9) = 4: year%(10) = 5: year%(11) = 6: year%(12) = 14ãyear%(13) = 2: year%(14) = 3: year%(15) = 4: year%(16) = 12: year%(17) = 7: year%(18) = 1ãyear%(19) = 2: year%(20) = 10: year%(21) = 5: year%(22) = 6: year%(23) = 7: year%(24) = 8ãyear%(25) = 3: year%(26) = 4: year%(27) = 5: year%(28) = 13: year%(29) = 1: year%(30) = 2ãyear%(31) = 3: year%(32) = 11: year%(33) = 6: year%(34) = 7: year%(35) = 1: year%(36) = 9ãyear%(37) = 4: year%(38) = 5: year%(39) = 6: year%(40) = 14: year%(41) = 2: year%(42) = 3ãyear%(43) = 4: year%(44) = 12: year%(45) = 7: year%(46) = 1: year%(47) = 2: year%(48) = 3ãyear%(49) = 4: year%(50) = 5: year%(51) = 6: year%(52) = 14: year%(53) = 2: year%(54) = 3ãyear%(55) = 4: year%(56) = 12: year%(57) = 7: year%(58) = 1: year%(59) = 2: year%(60) = 10ãyear%(61) = 5: year%(62) = 6: year%(63) = 7: year%(64) = 8: year%(65) = 3: year%(66) = 4ãyear%(67) = 5: year%(68) = 13: year%(69) = 1: year%(70) = 2: year%(71) = 3: year%(72) = 11ãyear%(73) = 6: year%(74) = 7: year%(75) = 1: year%(76) = 9: year%(77) = 4: year%(78) = 5ãyear%(79) = 6: year%(80) = 14: year%(81) = 2: year%(82) = 3: year%(83) = 4: year%(84) = 12ãyear%(85) = 7: year%(86) = 1: year%(87) = 2: year%(88) = 10: year%(89) = 5: year%(90) = 6ãyear%(91) = 7: year%(92) = 8: year%(93) = 3: year%(94) = 4: year%(95) = 5: year%(96) = 13ãyear%(97) = 1: year%(98) = 2: year%(99) = 3: year%(100) = 11: year%(101) = 6: year%(102) = 7ãyear%(103) = 1: year%(104) = 9: year%(105) = 4: year%(106) = 5: year%(107) = 6: year%(108) = 14ãyear%(109) = 2: year%(110) = 3: year%(111) = 4: year%(112) = 12: year%(113) = 7: year%(114) = 1ãyear%(115) = 2: year%(116) = 10: year%(117) = 5: year%(118) = 6: year%(119) = 7: year%(120) = 8ãyear%(121) = 3: year%(122) = 4: year%(123) = 5: year%(124) = 13: year%(125) = 1: year%(126) = 2ãyear%(127) = 3: year%(128) = 11: year%(129) = 6: year%(130) = 7: year%(131) = 1: year%(132) = 9ãyear%(133) = 4: year%(134) = 5: year%(135) = 6: year%(136) = 14: year%(137) = 2: year%(138) = 3ãyear%(139) = 4: year%(140) = 12: year%(141) = 7: year%(142) = 1: year%(143) = 2: year%(144) = 10ãyear%(145) = 5: year%(146) = 6: year%(147) = 7: year%(148) = 1: year%(149) = 2: year%(150) = 3ãyear%(151) = 4: year%(152) = 12: year%(153) = 7: year%(154) = 1: year%(155) = 2: year%(156) = 10ãyear%(157) = 5: year%(158) = 6: year%(159) = 7: year%(160) = 8: year%(161) = 3: year%(162) = 4ãyear%(163) = 5: year%(164) = 13: year%(165) = 1: year%(166) = 2: year%(167) = 3: year%(168) = 11ãyear%(169) = 6: year%(170) = 7: year%(171) = 1: year%(172) = 9: year%(173) = 4: year%(174) = 5ãyear%(175) = 6: year%(176) = 14: year%(177) = 2: year%(178) = 3: year%(179) = 4: year%(180) = 12ãyear%(181) = 7: year%(182) = 1: year%(183) = 2: year%(184) = 10: year%(185) = 5: year%(186) = 6ãyear%(187) = 7: year%(188) = 8: year%(189) = 3: year%(190) = 4: year%(191) = 5: year%(192) = 13ãyear%(193) = 1: year%(194) = 2: year%(195) = 3: year%(196) = 11: year%(197) = 6: year%(198) = 7ãyear%(199) = 1: year%(200) = 9: year%(201) = 4: year%(202) = 5: year%(203) = 6: year%(204) = 14ãyear%(205) = 2: year%(206) = 3: year%(207) = 4: year%(208) = 12: year%(209) = 7: year%(210) = 1ãyear%(211) = 2: year%(212) = 10: year%(213) = 5: year%(214) = 6: year%(215) = 7: year%(216) = 8ãyear%(217) = 3: year%(218) = 4: year%(219) = 5: year%(220) = 13: year%(221) = 1: year%(222) = 2ãyear%(223) = 3: year%(224) = 11: year%(225) = 6: year%(226) = 7: year%(227) = 1: year%(228) = 9ãyear%(229) = 4: year%(230) = 5: year%(231) = 6: year%(232) = 14: year%(233) = 2: year%(234) = 3ãyear%(235) = 4: year%(236) = 12: year%(237) = 7: year%(238) = 1: year%(239) = 2: year%(240) = 10ãyear%(241) = 5: year%(242) = 6: year%(243) = 7: year%(244) = 8: year%(245) = 3: year%(246) = 4ãyear%(247) = 5: year%(248) = 13: year%(249) = 1: year%(250) = 2: year%(251) = 3: year%(252) = 11ãyear%(253) = 6: year%(254) = 7: year%(255) = 1: year%(256) = 9: year%(257) = 4: year%(258) = 5ãyear%(259) = 6: year%(260) = 14: year%(261) = 2: year%(262) = 3: year%(263) = 4: year%(264) = 12ãyear%(265) = 7: year%(266) = 1: year%(267) = 2: year%(268) = 10: year%(269) = 5: year%(270) = 6ãyear%(271) = 7: year%(272) = 8: year%(273) = 3: year%(274) = 4: year%(275) = 5: year%(276) = 13ãyear%(277) = 1: year%(278) = 2ãM1%(1) = 1: M1%(2) = 4: M1%(3) = 4: M1%(4) = 7: M1%(5) = 2: M1%(6) = 5ãM1%(7) = 7: M1%(8) = 3: M1%(9) = 6: M1%(10) = 1: M1%(11) = 4: M1%(12) = 6ãM2%(1) = 2: M2%(2) = 5: M2%(3) = 5: M2%(4) = 1: M2%(5) = 3: M2%(6) = 6ãM2%(7) = 1: M2%(8) = 4: M2%(9) = 7: M2%(10) = 2: M2%(11) = 5: M2%(12) = 7ãM3%(1) = 3: M3%(2) = 6: M3%(3) = 6: M3%(4) = 2: M3%(5) = 4: M3%(6) = 7ãM3%(7) = 2: M3%(8) = 5: M3%(9) = 1: M3%(10) = 3: M3%(11) = 6: M3%(12) = 1ãM4%(1) = 4: M4%(2) = 7: M4%(3) = 7: M4%(4) = 3: M4%(5) = 5: M4%(6) = 1ãM4%(7) = 3: M4%(8) = 6: M4%(9) = 2: M4%(10) = 4: M4%(11) = 7: M4%(12) = 2ãM5%(1) = 5: M5%(2) = 1: M5%(3) = 1: M5%(4) = 4: M5%(5) = 6: M5%(6) = 2ãM5%(7) = 4: M5%(8) = 7: M5%(9) = 3: M5%(10) = 5: M5%(11) = 1: M5%(12) = 3ãM6%(1) = 6: M6%(2) = 2: M6%(3) = 2: M6%(4) = 5: M6%(5) = 7: M6%(6) = 3ãM6%(7) = 5: M6%(8) = 1: M6%(9) = 4: M6%(10) = 6: M6%(11) = 2: M6%(12) = 4ãM7%(1) = 7: M7%(2) = 3: M7%(3) = 3: M7%(4) = 6: M7%(5) = 1: M7%(6) = 4ãM7%(7) = 6: M7%(8) = 2: M7%(9) = 5: M7%(10) = 7: M7%(11) = 3: M7%(12) = 5ãM8%(1) = 1: M8%(2) = 4: M8%(3) = 5: M8%(4) = 1: M8%(5) = 3: M8%(6) = 6ãM8%(7) = 1: M8%(8) = 4: M8%(9) = 7: M8%(10) = 2: M8%(11) = 5: M8%(12) = 7ãM9%(1) = 2: M9%(2) = 5: M9%(3) = 6: M9%(4) = 2: M9%(5) = 4: M9%(6) = 7ãM9%(7) = 2: M9%(8) = 5: M9%(9) = 1: M9%(10) = 3: M9%(11) = 6: M9%(12) = 1ãM10%(1) = 3: M10%(2) = 6: M10%(3) = 7: M10%(4) = 3: M10%(5) = 5: M10%(6) = 1ãM10%(7) = 3: M10%(8) = 6: M10%(9) = 2: M10%(10) = 4: M10%(11) = 7: M10%(12) = 2ãM11%(1) = 4: M11%(2) = 7: M11%(3) = 1: M11%(4) = 4: M11%(5) = 6: M11%(6) = 2ãM11%(7) = 4: M11%(8) = 7: M11%(9) = 3: M11%(10) = 5: M11%(11) = 1: M11%(12) = 3ãM12%(1) = 5: M12%(2) = 1: M12%(3) = 2: M12%(4) = 5: M12%(5) = 7: M12%(6) = 3ãM12%(7) = 5: M12%(8) = 1: M12%(9) = 4: M12%(10) = 6: M12%(11) = 2: M12%(12) = 4ãM13%(1) = 6: M13%(2) = 2: M13%(3) = 3: M13%(4) = 6: M13%(5) = 1: M13%(6) = 4ãM13%(7) = 6: M13%(8) = 2: M13%(9) = 5: M13%(10) = 7: M13%(11) = 3: M13%(12) = 5ãM14%(1) = 7: M14%(2) = 3: M14%(3) = 4: M14%(4) = 7: M14%(5) = 2: M14%(6) = 5ãM14%(7) = 7: M14%(8) = 3: M14%(9) = 6: M14%(10) = 1: M14%(11) = 4: M14%(12) = 6ãdn$(1) = "MONDAY ": dn$(2) = "TUESDAY ": dn$(3) = "WEDNESDAY": dn$(4) = "THURSDAY ": dn$(5) = "FRIDAY ": dn$(6) = "SATURDAY ": dn$(7) = "SUNDAY"ãd1%(1) = 1: d1%(2) = 2: d1%(3) = 3: d1%(4) = 4: d1%(5) = 5: d1%(6) = 6:ãd1%(7) = 7: d1%(8) = 1: d1%(9) = 2: d1%(10) = 3ãd1%(11) = 4: d1%(12) = 5: d1%(13) = 6: d1%(14) = 7: d1%(15) = 1: d1%(16) = 2: d1%(17) = 3: d1%(18) = 4: d1%(19) = 5: d1%(20) = 6ãd1%(21) = 7: d1%(22) = 1: d1%(23) = 2: d1%(24) = 3: d1%(25) = 4: d1%(26) = 5: d1%(27) = 6: d1%(28) = 7: d1%(29) = 1: d1%(30) = 2ãd1%(31) = 3ãd2%(1) = 2: d2%(2) = 3: d2%(3) = 4: d2%(4) = 5: d2%(5) = 6: d2%(6) = 7: d2%(7) = 1: d2%(8) = 2: d2%(9) = 3: d2%(10) = 4ãd2%(11) = 5: d2%(12) = 6: d2%(13) = 7: d2%(14) = 1: d2%(15) = 2: d2%(16) = 3: d2%(17) = 4: d2%(18) = 5: d2%(19) = 6: d2%(20) = 7ãd2%(21) = 1: d2%(22) = 2: d2%(23) = 3: d2%(24) = 4: d2%(25) = 5: d2%(26) = 6: d2%(27) = 7: d2%(28) = 1: d2%(29) = 2: d2%(30) = 3ãd2%(31) = 4ãd3%(1) = 3: d3%(2) = 4: d3%(3) = 5: d3%(4) = 6: d3%(5) = 7: d3%(6) = 1: d3%(7) = 2: d3%(8) = 3: d3%(9) = 4: d3%(10) = 5ãd3%(11) = 6: d3%(12) = 7: d3%(13) = 1: d3%(14) = 2: d3%(15) = 3: d3%(16) = 4: d3%(17) = 5: d3%(18) = 6: d3%(19) = 7: d3%(20) = 1ãd3%(21) = 2: d3%(22) = 3: d3%(23) = 4: d3%(24) = 5: d3%(25) = 6: d3%(26) = 7: d3%(27) = 1: d3%(28) = 2: d3%(29) = 3: d3%(30) = 4ãd3%(31) = 5ãd4%(1) = 4: d4%(2) = 5: d4%(3) = 6: d4%(4) = 7: d4%(5) = 1: d4%(6) = 2: d4%(7) = 3: d4%(8) = 4: d4%(9) = 5: d4%(10) = 6ãd4%(11) = 7: d4%(12) = 1: d4%(13) = 2: d4%(14) = 3: d4%(15) = 4: d4%(16) = 5: d4%(17) = 6: d4%(18) = 7: d4%(19) = 1: d4%(20) = 2ãd4%(21) = 3: d4%(22) = 4: d4%(23) = 5: d4%(24) = 6: d4%(25) = 7: d4%(26) = 1: d4%(27) = 2: d4%(28) = 3: d4%(29) = 4: d4%(30) = 5ãd4%(31) = 6ãd5%(1) = 5: d5%(2) = 6: d5%(3) = 7: d5%(4) = 1: d5%(5) = 2: d5%(6) = 3: d5%(7) = 4: d5%(8) = 5: d5%(9) = 6: d5%(10) = 7ãd5%(11) = 1: d5%(12) = 2: d5%(13) = 3: d5%(14) = 4: d5%(15) = 5: d5%(16) = 6: d5%(17) = 7: d5%(18) = 1: d5%(19) = 2: d5%(20) = 3ãd5%(21) = 4: d5%(22) = 5: d5%(23) = 6: d5%(24) = 7: d5%(25) = 1: d5%(26) = 2: d5%(27) = 3: d5%(28) = 4: d5%(29) = 5: d5%(30) = 2ãd5%(31) = 7ãd6%(1) = 6: d6%(2) = 7: d6%(3) = 1: d6%(4) = 2: d6%(5) = 3: d6%(6) = 4: d6%(7) = 5: d6%(8) = 6: d6%(9) = 7: d6%(10) = 1ãd6%(11) = 2: d6%(12) = 3: d6%(13) = 4: d6%(14) = 5: d6%(15) = 6: d6%(16) = 7: d6%(17) = 1: d6%(18) = 2: d6%(19) = 3: d6%(20) = 4ãd6%(21) = 5: d6%(22) = 6: d6%(23) = 7: d6%(24) = 1: d6%(25) = 2: d6%(26) = 3: d6%(27) = 4: d6%(28) = 5: d6%(29) = 6: d6%(30) = 7ãd6%(31) = 1ãd7%(1) = 7: d7%(2) = 1: d7%(3) = 2: d7%(4) = 3: d7%(5) = 4: d7%(6) = 5: d7%(7) = 6: d7%(8) = 7: d7%(9) = 1: d7%(10) = 2ãd7%(11) = 3: d7%(12) = 4: d7%(13) = 5: d7%(14) = 6: d7%(15) = 7: d7%(16) = 1: d7%(17) = 2: d7%(18) = 3: d7%(19) = 4: d7%(20) = 5ãd7%(21) = 6: d7%(22) = 7: d7%(23) = 1: d7%(24) = 2: d7%(25) = 3: d7%(26) = 4: d7%(27) = 5: d7%(28) = 6: d7%(29) = 7: d7%(30) = 1ãd7%(31) = 2ãmn$(1) = "January": mn$(2) = "February": mn$(3) = "March": mn$(4) = "April": mn$(5) = "May": mn$(6) = "June"ãmn$(7) = "July": mn$(8) = "August": mn$(9) = "September": mn$(10) = "October": mn$(11) = "November": mn$(12) = "December"ãmnu%(1) = 31: mnu%(2) = 28: mnu%(3) = 31: mnu%(4) = 30: mnu%(5) = 31: mnu%(6) = 30: mnu%(7) = 31: mnu%(8) = 31: mnu%(9) = 30: mnu%(10) = 31: mnu%(11) = 30: mnu%(12) = 31ããFOR ColorSet = 1 TO 4ã FOR x = 1 TO 10ã READ Colors(x, ColorSet)ã NEXT xãNEXT ColorSetããEND SUBããSUB inputerrorãLINE (158, 235)-(390, 249), 7, BãLINE (159, 236)-(389, 248), 15, BFãWord$ = "Input Error"ãSPACING$ = "R0"ãSIZE$ = " 4"ãDOT$ = "N"ãBGC = 15ãCALL TRANSLATEãC1$ = "C 4"ãC2$ = "C12"ãPFT = 245: PFL = 163: CALL NORMAL1ãLINE (158, 262)-(390, 274), 7, BãLINE (159, 263)-(389, 273), 15, BFãIF nt% = 1 THENã Word$ = "The Year entered is invalid"ãELSEIF nt% = 2 THENã Word$ = "The Month entered is invalid"ãELSEIF nt% = 3 THENã Word$ = "The Day entered is invalid"ãEND IFãSPACING$ = "R0"ãSIZE$ = " 4"ãDOT$ = "N"ãBGC = 15ãCALL TRANSLATEãC1$ = "C 4"ãC2$ = "C12"ãPFT = 272: PFL = 163: CALL NORMAL1ãLINE (158, 279)-(415, 291), 7, BãLINE (159, 280)-(414, 290), 15, BFãIF nt% = 1 THENã Word$ = "Valid range is 1753 - 2030"ãELSEIF nt% = 2 THENã Word$ = "Valid range is 1 - 12"ãELSEIF nt% = 3 THENã Word$ = "Valid range is 1 -31"ãEND IFãSPACING$ = "R0"ãSIZE$ = " 4"ãDOT$ = "N"ãBGC = 15ãCALL TRANSLATEãC1$ = "C 4"ãC2$ = "C12"ãPFT = 289: PFL = 163: CALL NORMAL1ãLINE (158, 296)-(415, 308), 7, BãLINE (159, 297)-(414, 307), 15, BFãWord$ = "Please re-enter"ãSPACING$ = "R0"ãSIZE$ = " 4"ãDOT$ = "N"ãBGC = 15ãCALL TRANSLATEãC1$ = "C 4"ãC2$ = "C12"ãPFT = 306: PFL = 163: CALL NORMAL1ããEND SUBããSUB LAYER1ã PSET (PFL + 2, PFT + 5), BGC: DRAW C3$ + P$ã PSET (PFL + 0, PFT + 5), BGC: DRAW C3$ + P$ã PSET (PFL + 1, PFT + 5), BGC: DRAW C3$ + P$ã PSET (PFL + 0, PFT + 4), BGC: DRAW C3$ + P$ã PSET (PFL + 1, PFT + 2), BGC: DRAW C2$ + P$ã PSET (PFL + 2, PFT + 4), BGC: DRAW C1$ + P$ã PSET (PFL + 3, PFT + 3), BGC: DRAW C4$ + P$ã PSET (PFL + 3, PFT + 2), BGC: DRAW C2$ + P$ã PSET (PFL + 4, PFT + 4), BGC: DRAW C2$ + P$ã PSET (PFL + 5, PFT + 2), BGC: DRAW C3$ + P$ã PSET (PFL + 5, PFT + 3), BGC: DRAW C2$ + P$ã PSET (PFL + 4, PFT + 3), BGC: DRAW C1$ + P$ãEND SUBããSUB LETTERSã P$(32) = "BR4" 'SPACEã P$(33) = "BR1BD1U1BU2U5BD7BR3" '!ã P$(34) = "BR0BU7D2BR2U2BD7BR3" '"ã P$(35) = "BD1BR1U8D2L1R5L1U2D8U2L4R5BR2BD1" '#ã P$(36) = "BD1BR3U8D8BL3BU5U1E1R3F1BD1BL5F1R3F1D1G1L3H1BR7BD1" '$ã P$(37) = "BD1U1E6U1BL5BD2U1R1D1L1BD4BR4R1D1L1U1BD1BR5" '%ã P$(38) = "BR1BU2BL1E3U1H1L1G1D1F6BU1BL5BU3G2D1F1R3E3BD2BR2" '&ã P$(39) = "BR2BU7D1G1BD5BR4" ''ã P$(40) = "BR1BD1BU2U4E2G2D4F2BU1BR4" '(ã P$(41) = "BR2BD1BU2U4H2F2D4G2BU1BR5" ')ã P$(42) = "BR2BU2U6D3L2R4BL4BD2E4BL4F4BD3BR4" '*ã P$(43) = "BR2BD1U7D3L2R5BD3BR3" '+ã P$(44) = "BD1U1R1D2G1BU3BR4" ',ã P$(45) = "BR1BU3R3L3BD3BR5" '-ã P$(46) = "BD1BR1L1BU1BR4" '.ã P$(47) = "BR1E5G5BR7" '/ã P$(48) = "BD1BU1U6E1R2F1D6G1L2H1BR6" '0ã P$(49) = "BD1BR2U7BL1E1D1BD6BR3" '1ã P$(50) = "BR1BU6E1R2F1D2G4D1R4BU1BR3" '2ã P$(51) = "BU6E1R2F1D2G1L2R2F1D2G1L2H1BR7" '3ã P$(52) = "BU3E4D8U4L4R5BD3BR3" '4ã P$(53) = "BR1BU3U4R4L4D4E1R2F1D3G1L2H1BR7" '5ã P$(54) = "BR1BD1BU4U3E1R2F1H1L2G1D6F1R2E1U3H1L2G1BD3BR6" '6ã P$(55) = "BR1BU7R4D3G4D1BU1BR7" '7ã P$(56) = "BR1BU6E1R2F1D2G1L2R2F1D2G1L2H1U2E1H1U2BD6BR7" '8ã P$(57) = "BR1BU4U2E1R2F1D6G1L2H1BU4F1R3BD3BR3" '9ã P$(58) = "BR1U1BU2U1BD4BR3" ':ã P$(59) = "BD1BR1BU1U1BU2U1BD4G1BU1BR6" ';ã P$(60) = "BU3E3G3F3BR3" '<ã P$(61) = "BU3R4BD2L4BR7BD1" '=ã P$(62) = "BU6BR1F3G3BR5" '>ã P$(63) = "BR1BU5U1E1R2F1D2G1D1BD2D1BU1BR3" '?ã P$(64) = "BD1BU1U6E1R3F1D5L2H1U2E1R1D3BD3L3H1F1R3E1BR3" '@ã P$(65) = "BD1U7E1R3F1D3L5R5D4BR4BU1" 'Aã P$(66) = "BD1U8R4F1D2G1L4R4F1D2G1L4BU1BR9" 'Bã P$(67) = "BD1BU1U6E1R3F1BD6G1L3H1F1R3BR4BU1" 'Cã P$(68) = "BD1U8R4F1D6G1L4BR9BU1 " 'Dã P$(69) = "BD1U8R4L4D4R3L3D4R4BU1BR4" 'Eã P$(70) = "BD1U8R5L5D4R4L4D4BR8BU1" 'Fã P$(71) = "BD1BU1U6E1R3F1BD6G1L3H1F1R3E1U3L2R2D3BR4" 'Gã P$(72) = "BD1U8D4R4U4D8BR4BU1" 'Hã P$(73) = "BD1BR3U8L1R2L1D8L1R2BR4BU1" 'Iã P$(74) = "BD1BU1F1R2E1U7L1R2L1D7BR5" 'Jã P$(75) = "BD1BU8D8U4R1E4G4F4BR4BU1" 'Kã P$(76) = "BD1BU8D8R4BU1BR4" 'Lã P$(77) = "BD1U7E1R2F1D7U7E1R2F1D7BU1BR4" 'Mã P$(78) = "BD1U8F7D1U8D8BR4BU1" 'Nã P$(79) = "BD1BU1U6E1R3F1BD6G1L3H1BR5U6D6BR4" 'Oã P$(80) = "BD1U8R4F1D2G1L4D4BR9BU1" 'Pã P$(81) = "BD1BU1U6E1R3F1BD6G1L3H1BR5U6BL3BD5F3BG3BR7BU5" 'Qã P$(82) = "BD1U8R4F1D2G1L4R1F4BR4BU1" 'Rã P$(83) = "BD1BU5U2E1R3F1BD2BL5F1R3F1D2G1L3H1BR9" 'Sã P$(84) = "BR3BD1BU8L4R6L3D8BR6BU1" 'Tã P$(85) = "BD1BU1U7D7F1R3E1U7D7BR4" 'Uã P$(86) = "BD1BU8D5F2D1U1E2U5D5BR5BD2" 'Vã P$(87) = "BD1BU1U7D7F1R2E1U7D7F1R2E1U7D7BD1BR4BU1" 'Wã P$(88) = "BD1BU8D1F3E3U1D1G6D1U1E3F3D1BU1BR5" 'Xã P$(89) = "BL1BU5U2D2F3E3U2D2G3D3BU1BR7" 'Yã P$(90) = "BU7R5D2G5D1R5BR4BU1" 'Zã P$(91) = "BR1BD1BR3L3U8R3BR3BD7" '[ã P$(92) = "BU5F5BR3" '\ã P$(93) = "BD1R3U8L3BR2BD7BR4" ']ã P$(94) = "BR1BU5E2F2BD5BR2" '^ã P$(95) = "BD1R4BU1BL2BR5" '_ã P$(96) = "BR2BU7D1F1BD5BR2" '`ã P$(97) = "U2E1R3U1H1L2G1E1R2F1D4G1L2H1F1BR2E1U2D3BR4BU1" 'aã P$(98) = "BD1U8D8R3E1U4H1L2G1D4BR8" 'bã P$(99) = "BR0U4E1R2F1BD4G1L2H1F1R2E1BR4" 'cã P$(100) = "U4E1R2F1H1L2G1D4F1R2E1U7D7D1BU1BR4" 'dã P$(101) = "U4E1R2F1D2L4D2F1R2E1BR4" 'eã P$(102) = "BR1BD1U7E1R2F1H1L2G1D3L1R3BD3BR5" 'fã P$(103) = "U4E1R2F1D4G1L2H1BD3F1R2E1U3BR4" 'gã P$(104) = "BU7D8U5E1R2F1D5BU1BR4" 'hã P$(105) = "BR3BD1U6BU2BD7BR4" 'iã P$(106) = "BR1BD1U6BU2BD7D3G1L2BU4BR8" 'jã P$(107) = "BD1BU8D8U3E3G3F3BU1BR3" 'kã P$(108) = "BR1BD1U8L1R1D8L1R2BR4BU1" 'lã P$(109) = "BD1U6D1E1R1F1D5U5E1R1F1D5BU1BR4" 'mã P$(110) = "BD1U6D1E1R2F1D5U4BD3BR4" 'nã P$(111) = "U4E1R2F1D4G1L2H1BR8" 'oã P$(112) = "U4E1R2F1D4G1L2H1D4U4BR8" 'pã P$(113) = "U4E1R2F1D4G1L2H1BR4D4L1R2L1U4BR5" 'qã P$(114) = "BD1U6D1E1R2F1H1L2G1U1D6BU1BR7" 'rã P$(115) = "BU3U1E1R2F1H1L2G1D1F1R2F1D1G1L2H1BR8" 'sã P$(116) = "BR1BU7D2L2R4L2D5F1R1E1BR4" 'tã P$(117) = "U5D5F1R2E1U5D5BR4" 'uã P$(118) = "BD1BU6D3F2D1U1E2U3D3BD2BR4" 'vã P$(119) = "BD1BU6D5F1R1E1U4D4F1R1E1U5D5BR4" 'wã P$(120) = "BD1BU6D1F2E2U1D1G4D1U1E2F2D1BU1BR4" 'xã P$(121) = "BU5D5F1R2E1U5D8G1L2H1BU3BR8" 'yã P$(122) = "BU5R4D1G4D1R4BU1BR4" 'zãEND SUBããSUB NORMAL0ãPSET (PFL + 0, PFT + 0), BGC: DRAW C1$ + P$ãEND SUBããSUB NORMAL1ã PSET (PFL + 0, PFT + 1), BGC: DRAW C2$ + P$ã PSET (PFL + 1, PFT + 0), BGC: DRAW C1$ + P$ã PSET (PFL + 2, PFT + 0), BGC: DRAW C1$ + P$ãEND SUBããSUB OPENINTROãCOLOR 7, 0ãSCREEN 9 'SET SCREEN MODE TO 9ãCLSãLINE (1, 1)-(590, 72), 13, BãLINE (3, 3)-(588, 70), 7, BFãWord$ = "What Day Was It ?"ãSPACING$ = "L1"ãSIZE$ = "20"ãDOT$ = "N"ãBGC = 7ãCALL TRANSLATEãC1$ = "C 5": C2$ = "C 8": C3$ = "C 8": C4$ = "C 8"ãPFT = 52: PFL = 16: CALL LAYER1ãPFT = 52: PFL = 14: CALL LAYER1ãPFT = 52: PFL = 12: CALL LAYER1ãC1$ = "C 5": C2$ = "C 0": C3$ = "C 0": C4$ = "C15"ãPFT = 50: PFL = 18: CALL LAYER1ãPFT = 50: PFL = 17: CALL LAYER1ãColorpref = 1ãFancyCls Colors(2, Colorpref), Colors(1, Colorpref)ããLINE (158, 100)-(390, 116), 7, BãLINE (159, 101)-(389, 115), 15, BFãWord$ = "Display Any Day of the Week for"ãSPACING$ = "R0"ãSIZE$ = " 4"ãDOT$ = "N"ãBGC = 15ãCALL TRANSLATEãC1$ = "C 1"ãC2$ = "C 9"ãPFT = 110: PFL = 163: CALL NORMAL1ãLINE (158, 122)-(390, 138), 7, BãLINE (159, 123)-(389, 137), 15, BFãWord$ = " Any Date Between 1753 - 2030"ãSPACING$ = "R0"ãSIZE$ = " 4"ãDOT$ = "N"ãBGC = 15ãCALL TRANSLATEãC1$ = "C 1"ãC2$ = "C 9"ãPFT = 132: PFL = 163: CALL NORMAL1ããHITENTER:ãLINE (228, 337)-(340, 350), 7, BFãWord$ = "Press any Key"ãSPACING$ = "R1"ãSIZE$ = " 4"ãDOT$ = "N"ãBGC = 15ãCALL TRANSLATEãC1$ = "C 0"ãC2$ = "C 8"ãPFT = 346: PFL = 231: CALL NORMAL1ãINKEY1:ãC1$ = "C 0"ãC2$ = "C 8"ãPFT = 346: PFL = 231: CALL NORMAL1ãSLEEP 1ãC1$ = "C 4"ãC2$ = "C 8"ãPFT = 346: PFL = 231: CALL NORMAL1ãSLEEP 1ãA$ = INKEY$: IF A$ = "" THEN GOTO INKEY1ãEND SUBããSUB PAUSEãLINE (248, 337)-(360, 350), 7, BFãWord$ = "Press any Key"ãSPACING$ = "R1"ãSIZE$ = " 4"ãDOT$ = "N"ãBGC = 15ãCALL TRANSLATEãC1$ = "C 0"ãC2$ = "C 8"ãPFT = 346: PFL = 251: CALL NORMAL1ãINKEY2:ãC1$ = "C 0"ãC2$ = "C 8"ãPFT = 346: PFL = 251: CALL NORMAL1ãSLEEP 1ãC1$ = "C 4"ãC2$ = "C 8"ãPFT = 346: PFL = 251: CALL NORMAL1ãSLEEP 1ãA$ = INKEY$: IF A$ = "" THEN GOTO INKEY2ãEND SUBããSUB TRANSLATEã SPACING$ = "B" + UCASE$(SPACING$)ã SIZE$ = "S" + UCASE$(SIZE$)ã P$(105) = "BR0BD1U6BU2BD7BR4" 'iã P$(106) = "BR1BD1U6BU2BD7D3G1L2BU4BR8" 'jã IF DOT$ = "Y" THEN P$(105) = "BR0BD1U6BU1U1BD7BR4" 'DOT OVER iã IF DOT$ = "Y" THEN P$(106) = "BR1BD1U6BU1U1BD7D3G1L2BU4BR8" 'DOT OVER jã P$ = SIZE$ã FOR J = 1 TO LEN(Word$)ã P$ = P$ + P$(ASC(MID$(Word$, J, 1))) + SPACING$ã NEXT JãEND SUBãEgbert Zijlema SEVERAL DATE & TIME ROUTINES E.Zijlema@uni4nn.iaf.nl 06-14-96 (13:33) PB 494 15137 TIMEDATE.BAS$LIB ALL OFFã$ERROR ALL OFFã$OPTIMIZE SIZEã$COMPILE EXE ' compile it to let the daylight saving part runãã' TIMEDATE.BAS - Routines for date and time processingãã' Author : Egbert Zijlema ã' Date : June 14, 1996ã' Copyright status: Public Domainãã' TIMEDATE.BAS contains several routines to manipulate date and timeã' It includes a test for Daylight Saving:ã' On first use it stores the actual half year ("SUMMER" or "WINTER") atã' the end of the file. Therefore the DLS-part of this demo does not workã' in the IDE, in order to make sure PB.EXE itself will not become affected.ãã' If you include TIMEDATE.EXE in your AUTOEXEC.BAT file, it will checkã' for Daylight Saving on every startup. In that case leave the demo'sã' out and rewrite the main module before compiling, as follows:ãã' CLSã' DayLightSavingã' ENDãã' Credit: The routine to detect the file's own path (FUNCTION MySelf)ã' comes from Thomas Gohel, the maintainer of the PBSound WebSiteã' in Germany. Thank you, Thomas!ããDEFINT A - Zããdaydata:ã DATA Monday, Tuesday, Wednesday, Thursday, Friday, Saturday, Sundayãmonthdata:ã DATA January, February, March, April, May, June, July, Augustã DATA September, October, November, Decemberãdaysinmonthdata:ã DATA 31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31ãã' Trim all spaces from both ends of a stringãFUNCTION TRIM(BYVAL text AS STRING) AS STRINGã FUNCTION = LTRIM$(RTRIM$(text))ãEND FUNCTIONãã' Right align a stringãFUNCTION rgtALIGN(BYVAL text AS STRING, BYVAL length) AS STRINGã FUNCTION = RIGHT$(SPACE$(length) + text, length)ãEND FUNCTIONããFUNCTION MySelf AS STRINGãã ' from Thomas Gohel, Germanyã ' detects the full pathname of the running executableãã ! mov ax, &H6200ã ! int &H21ã ! mov es, bxã ! mov ax, WORD PTR es:[&H2C]ã ! mov pbvDefSeg, ax ; undocumented in PowerBASIC 3.0ãã count = 0ã DOã INCR countã LOOP UNTIL PEEK$(count, 4) = CHR$(0, 0, 1, 0)ãã DO WHILE PEEK(count + 4) <> 0ã temp$ = temp$ + CHR$(PEEK(count + 4))ã INCR countã LOOPãã DEF SEGãã FUNCTION = temp$ãEND FUNCTIONããFUNCTION Julian& (InDate$)ãã ' converts a date into it's Julian numberã IF LEN(InDate$) < 10 THEN EXIT FUNCTION ' format "mm-dd-[-]yyyy"ã Y& = VAL( MID$(InDate$, 7) ) ' year (maybe negative = b.C.)ã M& = VAL( LEFT$(InDate$, 2) ) ' monthã D& = VAL( MID$(InDate$, 4, 2) ) ' dayã temp& = (M& - 14) \ 12ã JulPart& = D& - 32075 + (1461 * (Y& + 4800 + temp&) \ 4)ã JulPart& = JulPart& + (367 * (M& - 2 - temp& * 12) \ 12)ãã FUNCTION = JulPart& - (3 * ((Y& + 4900 + temp&) \ 100) \ 4)ãEND FUNCTIONããSUB JulToDate (JN&, ResultDate$)ãã ' converts the Julian number of a date into it'sã ' date form ("mm-dd-[-]yyyy")ã JulNumber& = JN& + 68569ã help& = 4 * JulNumber& \ 146097ã JulNumber& = JulNumber& - (146097 * help& + 3) \ 4ã TempYear& = 4000 * (JulNumber& + 1) \ 1461001ã JulNumber& = JulNumber& - (1461 * TempYear& \ 4) + 31ã TempMonth& = 80 * JulNumber& \ 2447ã day = CINT(JulNumber& - (2447 * TempMonth& \ 80))ã month = CINT(TempMonth& + 2 - (12 * (TempMonth& \ 11)))ã year = CINT(100 * (help& - 49) + TempYear& + (TempMonth& \ 11))ã month$ = rgtALIGN(STR$(month), 2) + "-"ã day$ = rgtALIGN(STR$(day), 2) + "-"ã year$ = rgtALIGN(STR$(ABS(year)), 4) ' maybe negativeã REPLACE CHR$(32) WITH "0" IN year$ã IF year < 0 THEN year$ = "-" + year$ã ResultDate$ = month$ + day$ + year$ã REPLACE CHR$(32) WITH "0" IN ResultDate$ãEND SUBããFUNCTION LeapYear (TestYear$)ãã ' tests if a given year is a leap yearã JulNumber& = Julian&("02-28-" + TestYear$)ã INCR JulNumber& ' the next day we need!ã JulToDate JulNumber&, Result$ ' convert to stringformatãã IF LEFT$(Result$, 5) = "02-29" THENã FUNCTION = 1ã ELSEã FUNCTION = 0ã END IFãEND FUNCTIONããFUNCTION DayWeek (InDate$)ã ' returns a number for each day of the weekã ' range 1...7 = Monday up to Sundayãã month = VAL( LEFT$(InDate$, 2) )ã day = VAL( MID$(InDate$, 4, 2) )ã year = VAL( MID$(InDate$, 7) )ãã DECR month, 2ã IF month < 1 OR month > 10 THENã INCR month, 12 : DECR yearã END IFã century = year \ 100ã year = year MOD 100ã temp = INT(2.6 * month - .19) + day + year + (year \ 4)ã result = (temp + (century \ 4) - (century * 2)) MOD 7ã IF result = 0 THEN result = 7 ' Sunday = 7ãã FUNCTION = resultãEND FUNCTIONããSUB LastSunday(month$, sunday&)ã day = 32ã DOã DECR dayã InDate$ = month$ + TRIM(STR$(day)) + MID$(DATE$, 6)ã number = DayWeek(InDate$)ã LOOP UNTIL number = 7ã sunday& = Julian&(InDate$)ãEND SUBããFUNCTION DayLightBegin&ã ' returns last Sunday of March as Julianãã LastSunday "03-", temp&ã FUNCTION = temp&ãEND FUNCTIONããFUNCTION DayLightEnd&ã ' returns last Sunday of October as Julianãã LastSunday "10-", temp&ã FUNCTION = temp&ãEND FUNCTIONããSUB DayLightSavingã TestDate& = Julian&(DATE$)ã SELECT CASE TestDate&ã CASE < DayLightBegin&, > DayLightEnd&ã clock = -1ã CASE DayLightBegin&ã IF VAL( LEFT$(TIME$, 2) ) < 2 THEN clock = -1 ELSE clock = 1ã CASE DayLightEnd&ã IF VAL( LEFT$(TIME$, 2) ) > 2 THEN clock = -1 ELSE clock = 1ã CASE ELSEã clock = 1ã END SELECTã IF clock = 1 THEN dlsFlag$ = "SUMMER" ELSE dlsFlag$ = "WINTER"ã handle = FREEFILEã OPEN "B", #handle, MySelfã SEEK #handle, LOF(1) - 6ã GET$ #handle, 6, setting$ãã ' if newly installed:ã IF setting$ <> "SUMMER" AND setting$ <> "WINTER" THENã CLOSE #handleã InstallActualSetting dlsFlag$ã EXIT SUBã END IFãã IF setting$ <> dlsFlag$ THENã SEEK #handle, LOF(handle) - 6ã PUT$ #handle, dlsFlag$ã AdjustTime clockã END IFã CLOSE #handleãEND SUBããSUB InstallActualSetting(flag$)ã handle = FREEFILEã OPEN "B", #handle, MySelfã SEEK #handle, LOF(handle)ã PUT$ #handle, flag$ã CLOSE #handleãEND SUBããSUB AdjustTime(clock)ãã ' change the clock by 1 hour + or -ã ' adjust date, if necessaryã hour = VAL( LEFT$(TIME$, 2) )ã INCR hour, clock ' clock = -1 or +1ã IF hour > 23 THENã DECR hour, 24ã JulToDate Julian&(DATE$) + 1, ResultDate$ã DATE$ = ResultDate$ã ELSEIF hour < 0 THENã INCR hour, 24ã JulToDate Julian&(DATE$) - 1, ResultDate$ã DATE$ = ResultDate$ã END IFã hour$ = TRIM(STR$(hour))ã IF hour < 10 THEN hour$ = "0" + hour$ã TIME$ = hour$ + MID$(TIME$, 3)ãEND SUBããFUNCTION MonthName(InDate$) AS STRINGã RESTORE monthdataã number = VAL( LEFT$(InDate$, 2) )ã FOR count = 1 TO numberã READ temp$ã NEXTã FUNCTION = temp$ + CHR$(32)ãEND FUNCTIONããFUNCTION DayName(InDate$) AS STRINGã RESTORE daydataã number = DayWeek(InDate$)ã FOR count = 1 TO numberã READ temp$ã NEXTã FUNCTION = temp$ + CHR$(32)ãEND FUNCTIONããFUNCTION DaysInMonth(InDate$) AS INTEGERã RESTORE daysinmonthdataã number = VAL(LEFT$(InDate$, 2))ã FOR count = 1 TO numberã read totalã NEXTã IF number = 2 THEN total = total + LeapYear(MID$(InDate$, 7))ã FUNCTION = totalãEND FUNCTIONããFUNCTION DateText(InDate$) AS STRINGã day$ = MID$(InDate$, 4, 2) + CHR$(32)ã IF ASC(day$) = 48 THEN day$ = MID$(day$, 2) ' skip leading zeroã year = VAL(MID$(InDate$, 7)) ' perhaps < 1ã IF year < 1 THENã DECR yearã year$ = rgtALIGN(STR$(ABS(year)), 4)ã REPLACE CHR$(32) WITH "" IN year$ã year$ = year$ + " b.C."ã ELSEã year$ = MID$(InDate$, 7)ã END IFã FUNCTION = DayName(InDate$) + day$ + MonthName(InDate$) + year$ãEND FUNCTIONããFUNCTION DateNumeric(InDate$) AS STRINGã year = VAL(MID$(InDate$, 7)) ' perhaps < 1ã IF year < 1 THENã DECR yearã year$ = rgtALIGN(STR$(ABS(year)), 4)ã REPLACE CHR$(32) WITH "0" IN year$ã year$ = "-" + year$ã ELSEã year$ = MID$(InDate$, 7)ã END IFã ' uses slash for "-" to avoid "--" in negative yearã FUNCTION = LEFT$(InDate$, 2) + "/" + MID$(InDate$, 4, 2) + "/" + year$ãEND FUNCTIONãã' ******************************************************************ã' the following routines only serve this demoã' let them out if you intend tot implement the above in your libraryã' ******************************************************************ããSUB JulianTextã CLSã PRINT "The Julian& (to define as a LONG INTEGER) is a unique number"ã PRINT "for each day, starting November 25, 4714 before Christ; which"ã PRINT "date is Julian (or daynumber) 1."ã PRINT "Keep always in mind that this scientific method to cumpute"ã PRINT "days and dates, is based upon our modern (so called Gregorian)"ã PRINT "calendar. Due to the fact that this calendar is rather young,"ã PRINT "the results may not always mirror historical reality, simply"ã PRINT "because ";CHR$(34);"they";CHR$(34);" used a different ";ã PRINT "calendar in those days."ã PRINT "Additionally, the same must be said of Zeller's method to find the"ã PRINT "name of the day for a given date (FUNCTION DayWeek)."ã PRINTã PRINT "For computing reasons the Julian method includes the year 0 (zero)"ã PRINT "which was non-existing, they say. That's why the FUNCTIONs DateText"ã PRINT "and DateNumeric have been added in order to correct the result of"ã PRINT "SUB JulToDate by 1 year, if necessary."ã PRINT "If you intend to let the user input dates, your input routine must"ã PRINT "in fact do the opposite. Take care that the routine does not accept"ã PRINT "year zero and no dates older than 11/25/-4714. Before starting"ã PRINT "computational routines your program must INCREASE every input"ã PRINT "older than annum 1 by one year."ã PRINTã PRINT "more"ã DOã LOOP UNTIL LEN(INKEY$)ã PRINTã PRINT "E.g. if the user types ";CHR$(34);"01/01/-0001";CHR$(34);ã PRINT " (January 1st, 1 b.C.) your"ã PRINT "program must modify this into ";CHR$(34);"01/01/0000";CHR$(34);ã PRINT " before passing it"ã PRINT "through any of the above mentioned routines. Afterwards"ã PRINT "FUNCTION DateText or FUNCTION DateNumeric will re-convert it"ã PRINT "to 1 b.C. This sounds rather complicated, but the alternative"ã PRINT "is worse: leave the conversion out and learn your customer/user"ã PRINT "to input zero if he/she means 1 b.C. (etcetera)"ã DOã LOOP UNTIL LEN(INKEY$)ãEND SUBããSUB MenuTextã CLSã PRINT "Date and time manipulations you'll ever need"ã PRINT "Donated to the Public Domain by Egbert Zijlema"ã PRINTã PRINT "F1 = Info on Julian and Zeller's method"ã PRINT "F2 = Demo leap year"ã PRINT "F3 = Demo Julian"ã PRINT "F4 = Demo ";CHR$(34);"date before Christ";CHR$(34)ã PRINT "F5 = Daylight Saving demo"ã PRINT "Esc = Stop this demonstration"ã PRINTã PRINT "Re-enter this menu by pressing any key"ãEND SUBããSUB LeapYearDemoã CLSã TestDate$ = "02-01-1996"ã PRINT "1996 is a leap year, so "; MonthName(TestDate$);ã PRINT "counted ";TRIM(STR$(DaysInMonth(TestDate$)));" days"ãã TestDate$ = "02-01-1995"ã PRINT "1995 was not, so "; MonthName(TestDate$);"of that year had ";ã PRINT TRIM(STR$(DaysInMonth(TestDate$)));" days"ãã DOã LOOP UNTIL LEN(INKEY$)ãEND SUBããSUB JulianDemoã CLSã PRINT "Today's Julian number is"; Julian&(DATE$)ã PRINTãã TermToPay& = 14ã JulToDate Julian&(DATE$) + TermToPay&, payday$ã PRINT "Pay your bill before "; DateText(payday$)ã PRINTãã JulToDate Julian&(DATE$) - 1, result$ã PRINT "Yesterday was "; DayName(result$); DateNumeric(result$)ã PRINTãã JulToDate 1, oldest$ã PRINT "The oldest date Julian can find is "; DateText(oldest$)ã PRINT "which has been";Julian&(DATE$) - 1; "days ago!"ã PRINTãã PRINT "Dates beyond "; DateText("12-31-9999"); " need computers with the"ã PRINT "capability to store 5-digit years"ã PRINT "Engineers still have plenty of time to invent them:";ã PRINT Julian&("12-31-9999") - Julian&(DATE$); "days"ã DOã LOOP UNTIL LEN(INKEY$)ãEND SUBããSUB BeforeChristDemoã CLSã TestDate$ = "01-01--0001" ' = the year 2 before Christã JulToDate Julian&(TestDate$), result$ãã PRINT "The year zero did not exist. Probably."ã PRINT "However, for correct computations with Julians you do need it!"ã PRINT "Therefore the FUNCTIONs DateText(InDate$) / DateNumeric(InDate$)"ã PRINT "decrease an annum under 1 (= before Christ) by 1 year."ã PRINT "DateText adds the extension ";CHR$(34);"b.C.";CHR$(34);" as well."ã PRINTã PRINT "This is the computational date: "; result$ã PRINT "And here are 3 ways to write it: "; DateText(result$)ã PRINT " "; DayName(result$);ã PRINT DateNumeric(result$)ã PRINT " ";DateNumeric(result$)ã PRINTã PRINT "BTW: 2 before Christ was ";ã IF NOT LeapYear("0001") THEN PRINT "not";ã PRINT " a leap year"ã DOã LOOP UNTIL LEN(INKEY$)ãEND SUBããSUB DayLightDemoã CLSã IF BIT(pbvHost, 5) <> 0 THENã PRINT "Don't try this in the IDE! It will affect PB.EXE"ã PRINT "Compile this program to an EXE first"ã ELSEã PRINT "Now we do the daylight saving test"ã PRINTãã JulToDate DayLightBegin&, start$ã JulToDate DayLightEnd&, finish$ã PRINT "The daylight saving half year started "; DateText(start$); " and"ã PRINT "wil end "; DateText(finish$)ã PRINTã DayLightSaving ' install setting on first useãã OldDate$ = DATE$ ' save actual dateã PRINT "Today: "; DateText(OldDate$);ã PRINT " ("; TIME$; ")"ã PRINTãã JulToDate DayLightBegin& - 1, result$ ' try the day beforeã DATE$ = result$ã DayLightSavingã PRINT "No daylight saving: ";ã PRINT DateText(DATE$); " ("; TIME$; ")"ã PRINTãã JulToDate DayLightBegin& + 1, result$ ' 2 days laterã DATE$ = result$ã DayLightSavingã PRINT "Daylight saving: ";ã PRINT DateText(DATE$); " ("; TIME$; ")"ã PRINTãã DATE$ = OldDate$ ' finally restore actual dateã DayLightSavingã PRINT "Date restored: ";ã PRINT DateText(DATE$); " ("; TIME$; ")"ã END IFã DOã LOOP UNTIL LEN(INKEY$)ãEND SUBããFUNCTION GetKeyã DOã KeyIn$ = INKEY$ã LOOP UNTIL LEN(KeyIn$)ã FUNCTION = CVI(KeyIn$ + CHR$(0) )ãEND FUNCTIONããSUB MainMenuã DOã KeyIn = GetKeyã SELECT CASE KeyInã CASE 59 * 256 ' F1ã JulianTextã MenuTextã CASE 27 ' Escapeã CLS : SYSTEMã CASE 60 * 256 ' F2ã LeapYearDemoã MenuTextã CASE 61 * 256 ' F3ã JulianDemoã MenuTextã CASE 62 * 256 ' F4ã BeforeChristDemoã MenuTextã CASE 63 * 256 ' F5ã DayLightDemoã MenuTextã END SELECTã LOOPãEND SUBããCLSã MenuTextã MainMenuãENDãJames McMurrin RAINBOW CLOCK FidoNet QUIK_BAS Echo 06-13-96 (19:09) QB, QBasic, PDS 152 3979 RBCLOCK.BAS DIM PAL(512) AS LONG, CO(7, 3), SC(2, 60), MC(2, 60), HQ(2, 60), HC(2, 12)ãSCREEN 13ãRANDOMIZE TIMERãPAL(0) = 0ã'PAL(L) = A * 65536 + B * 256 + CãB = 29.4: R = 52.333333#ãPAL(1) = CINT(B) * 65536 + CINT(G) * 256 + CINT(R)ãPC = 2ãFOR L = 1 TO 13ãB = B - 2.1: R = R - 2 / 3ãPAL(PC) = CINT(B) * 65536 + CINT(G) * 256 + CINT(R)ãPC = PC + 1ãNEXT LãB = 0: R = 43ãPAL(PC) = CINT(B) * 65536 + CINT(G) * 256 + CINT(R)ãPC = PC + 1ãFOR L = 1 TO 29ãG = G + 1 / 3: R = R + 2 / 3ãPAL(PC) = CINT(B) * 65536 + CINT(G) * 256 + CINT(R)ãPC = PC + 1ãNEXT LãG = 10: R = 63ãPAL(PC) = CINT(B) * 65536 + CINT(G) * 256 + CINT(R)ãPC = PC + 1ãFOR L = 1 TO 29ãG = G + 53 / 30ãPAL(PC) = CINT(B) * 65536 + CINT(G) * 256 + CINT(R)ãPC = PC + 1ãNEXT LãG = 63ãPAL(PC) = CINT(B) * 65536 + CINT(G) * 256 + CINT(R)ãPC = PC + 1ãFOR L = 1 TO 29ãR = R - 2.1ãPAL(PC) = CINT(B) * 65536 + CINT(G) * 256 + CINT(R)ãPC = PC + 1ãNEXT LãR = 0ãPAL(PC) = CINT(B) * 65536 + CINT(G) * 256 + CINT(R)ãPC = PC + 1ãFOR L = 1 TO 29ãB = B + 2.1: G = G - 2.1ãPAL(PC) = CINT(B) * 65536 + CINT(G) * 256 + CINT(R)ãPC = PC + 1ãNEXT LãB = 63: G = 0ãPAL(PC) = CINT(B) * 65536 + CINT(G) * 256 + CINT(R)ãPC = PC + 1ãFOR L = 1 TO 29ãR = R + 2.1ãPAL(PC) = CINT(B) * 65536 + CINT(G) * 256 + CINT(R)ãPC = PC + 1ãNEXT LãR = 63ãPAL(PC) = CINT(B) * 65536 + CINT(G) * 256 + CINT(R)ãPC = PC + 1ãFOR L = 1 TO 15ãB = B - 2.1: R = R - 2 / 3ãPAL(PC) = CINT(B) * 65536 + CINT(G) * 256 + CINT(R)ãPC = PC + 1ãNEXT LãPALETTE USING PAL(0)ãT$ = "RAINBOW CLOCK"ãB$ = "BY:úJAMES MCMURRIN"ãFOR L = 1 TO 40ãLOCATE 1, LãCOLOR (L MOD 6) * 30 + 15ãPRINT MID$(T$, L, 1);ãLOCATE 24, LãPRINT MID$(B$, L, 1);ãNEXT LãCIRCLE (160, 99), 119, 1ãPAINT (160, 99), 1, 1ãFOR L = 0 TO 359 STEP 6ãIF (L / 30) = INT(L / 30) THENã FOR Q = -.5 TO .5 STEP .1ã ROW = 99 + COS((L + Q) * 3.14159 / 180) * 100ã COL = 160 + SIN((L + Q) * 3.14159 / 180) * 119ã LINE (160, 100)-(COL, ROW), 0ã NEXT Qã 'ROW = 99 + COS(L * 3.14159 / 180) * 95ã 'COL = 160 + SIN(L * 3.14159 / 180) * 110ã 'PAINT (COL, ROW), 0, 0ãELSEã ROW = 99 + COS(L * 3.14159 / 180) * 100ã COL = 160 + SIN(L * 3.14159 / 180) * 119ã BROW = 99 + COS(L * 3.14159 / 180) * 41ã BCOL = 160 + SIN(L * 3.14159 / 180) * 49ã LINE (BCOL, BROW)-(COL, ROW), 0ãEND IFãNEXT LãLINE (159, 99)-(159, 101), 0ãCIRCLE (160, 99), 119, 0ãCIRCLE (160, 99), 98, 0ãCIRCLE (160, 99), 69, 0ãCIRCLE (160, 99), 49, 0ãFOR L = 3 TO 360 STEP 6ãROW = 99 - COS(L * 3.14159 / 180) * 95ãSC(1, (L - 3) / 6 + 1) = ROWãROW = 99 - COS((L) * 3.14159 / 180) * 77ãMC(1, (L - 3) / 6 + 1) = ROWãROW = 99 - COS((L) * 3.14159 / 180) * 55ãHQ(1, (L - 3) / 6 + 1) = ROWãCOL = 160 + SIN(L * 3.14159 / 180) * 114ãSC(2, (L - 3) / 6 + 1) = COLãCOL = 160 + SIN((L) * 3.14159 / 180) * 95ãMC(2, (L - 3) / 6 + 1) = COLãCOL = 160 + SIN(L * 3.14159 / 180) * 65ãHQ(2, (L - 3) / 6 + 1) = COLãIF (L - 3) / 30 = INT((L - 3) / 30) THENã ROW = 99 - COS((L + 15) * 3.14159 / 180) * 25ã COL = 160 - SIN((L + 15) * 3.14159 / 180) * 25ã HC(1, (L - 3) / 30 + 1) = ROWã HC(2, (L - 3) / 30 + 1) = COLã CIRCLE (COL, ROW), 1, 8ãEND IFãNEXT LãOOFM = -1: OOHQ = -1: OOFH = -1ãDOãOT$ = TIME$ãOFS = VAL(MID$(OT$, 7, 2))ãOFM = VAL(MID$(OT$, 4, 2))ãOFH = VAL(MID$(OT$, 1, 2))ãOHQ = INT(OFM / 12)ãFOR L = 1 TO 60ãPC = ((60 - OFS) + L - 1) MOD 60 + 1ãPAINT (SC(2, L), SC(1, L)), PC, 0ãNEXT LãIF OFH <> OOFH THENã OOFH = OFH: OFS = OFH MOD 12ã FOR L = 0 TO 11ã PC = (11 - ((OFS + L) MOD 12)) * 5 + 121ã PAINT (HC(2, L + 1), HC(1, L + 1)), PC, 0ã NEXT LãEND IFãIF OFM <> OOFM THENã OOFM = OFMã FOR L = 1 TO 60ã PC = ((60 - OFM) + L - 1) MOD 60 + 61ã PAINT (MC(2, L), MC(1, L)), PC, 0ã NEXT LãEND IFãIF OHQ <> OOHQ THENã OOHQ = OHQã OS = (OFH MOD 12) * 5 + OHQ + 1ã FOR L = 1 TO 60ã PC = ((60 - OS) + L) MOD 60 + 121ã PAINT (HQ(2, L), HQ(1, L)), PC, 0ã NEXT LãEND IFãDO: LOOP WHILE TIME$ = OT$ãLOOP WHILE INKEY$ = ""ãEdward Di Geronimo Jr. CHANGE FREQ OF SYSTEM TIMER FidoNet QUIK_BAS Echo 07-07-96 (00:00) QB, QBasic, PDS 68 2347 INTCLOCK.BAS'Here's some almost working code to get more precise timing inã'QuickBasic. It works by changing the internal timer to generate anã'interrupt more often than 18.2 times per second. To use this code, callã'the ChangeTimer function, and to get the desired frequency use thisã'formula:ãã' 1.19318mhzã'-----------------ã'desired freuqencyãã'18.2 comes about by dividing by 65535 (highest 16bit number).ãã'If you look at the code, you'll notice there are COUNTER0, 1, and 2ã'constants. Counter 0 is the frequency of the system timer (which weã'change), counter 1 is the ram refresh rate (don't change!), and counterã'2 is related to the pc speaker (I doubt you should touch it).ãã'I know this works in C, but I don't know how well it will work in QB.ã'It should effect the TIMER value. It would be great for games if weã'could write our own ISR's to accompany this, but QB doesn't haveã'pointers, let alone sub/function pointers, so we can't. Oh well. But ONã'TIMER should be effected by this, so I guess we don't need one. I'llã'leave it to you guys to figure it out.ãã'Code to change the frequency of the 8253 clock chip's interruptã'generation. Public domain (C) by Edward Di Geronimo Jr. 7/7/96ããDEFINT A-ZããDECLARE SUB ChangeTimer (NewCount%)ããCONST CONTROL8253 = &H43 ' the 8253's control registerãCONST CONTROLWORD = &H3C ' the control word to set mode 2ã ' binary least/mostãCONST COUNTER0 = &H40 ' counter 0ãCONST COUNTER1 = &H41 ' counter 1ãCONST COUNTER2 = &H42 ' counter 2ããCONST TIMER60HZ = &H4DAE ' 60 hzãCONST TIMER50HZ = &H5D37 ' 50 hzãCONST TIMER40HZ = &H7486 ' 40 hzãCONST TIMER30HZ = &H965C ' 30 hzãCONST TIMER20HZ = &HE90B ' 20 hzãCONST TIMER18HZ = &HFFFF ' 18.2 hz (the standard count and the slowest possible)ãChangeTimer TIMER60HZããDO WHILE INKEY$ = ""ã A# = TIMERã PRINT A#,ã WHILE A# = TIMER: WENDãLOOPããChangeTimer TIMER18HZããSUB ChangeTimer (NewCount)ã' send the control word, mode 2, binary, least/most load sequenceããOUT CONTROL8253, CONTROLWORDãã' now write the least significant byte to the counter registerããOUT COUNTER0, NewCount AND &HFF ' LOWBYTE(newcount)ãã' and now the the most significant byteããOUT COUNTER0, (NewCount AND &HFF00) / 256 ' HIGHBYTE(newcount)ããEND SUBãKevin J. Krumwiede LINEAR DATE FidoNet QUIK_BAS Echo 07-12-96 (01:22) QB, QBasic, PDS 64 1834 LIN_DATE.BAS' Hello everybody! This program reports the current linear date, ã' expressed as the number of seconds since 00:00 on 01-01-1970. ã' This could be used the same way you might use TIMER to create ã' delays, but without the complications of midnight rollover. ã' This seems to be pretty fast, though I'm sure there's room for ã' optimization. I think I corected properly for all the special ã' cases (leap years, etc.), but if you spot any errors, please ã' let me know! Here it is: ã ã' ********************************************************************* ã' lin_date.bas ã' Written and released to the PUBLIC DOMAIN by Kevin J Krumwiede ã' Calculates the linear date from 01-01-1970 as per the Unix convention ã' ********************************************************************* ã ãDECLARE FUNCTION linearDate& () ãDECLARE FUNCTION leapDays% (year%) ã ãCLS ãPRINT "Current Linear Date:"; ãPRINT linearDate& ã ãEND ã ãFUNCTION leapDays% (year%) ã ãIF (year% MOD 100 = 0) AND (year% MOD 4 <> 0) THEN ã leapDays% = 0 ãELSEIF (year% MOD 4 = 0) THEN ã leapDays% = 1 ãELSE ã leapDays% = 0 ãEND IF ã ãEND FUNCTION ã ãFUNCTION linearDate& ã ãdt$ = DATE$ ãm% = VAL(LEFT$(dt$, 2)) ãd% = VAL(MID$(dt$, 4, 2)) ãy% = VAL(RIGHT$(dt$, 4)) ã ãDIM days(1 TO 12) AS INTEGER ãdays(1) = 31: days(2) = 28: days(3) = 31: days(4) = 30 ãdays(5) = 31: days(6) = 30: days(7) = 31: days(8) = 31 ãdays(9) = 30: days(10) = 31: days(11) = 30: days(12) = 31 ã ãlin& = 0 ãFOR i% = 1970 TO y% - 1 ã lin& = lin& + 86400 * (365 + leapDays(y%)) ãNEXT i% ã ãFOR i% = 1 TO m% - 1 ã lin& = lin& + 86400 * days(m%) ãNEXT ãIF m% > 2 THEN lin& = lin& + 86400 * leapDays(y%) ã ãlin& = lin& + 86400 * (d% - 1) ãlin& = lin& + TIMER ã ãlinearDate& = lin& ã ãEND FUNCTION ãEgbert Zijlema CONTINUALLY DISPLAY ACTUAL TIMEE.Zijlema@uni4nn.iaf.nl 07-21-96 (22:02) PB 225 7164 SHOWTIME.BAS' SHOWTIME.BAS ---- continuatedly displays the actual timeã' Author : Egbert Zijlema (E.Zijlema@uni4nn.iaf.nl)ã' Date : July 21, 1996ã' Language : Power Basic 3.2ã' Copyright status: Public Domainãã' Info:ã' Most of the time a program is just waiting for user activityã' (e.g. keyboard input). These "pauses" are the most excellentã' moments to display the actual time. For instance at the menu bar.ã' There is only 1 restriction: the Basic commands LOCATE and/or PRINTã' should ALWAYS serve the user, so your program must write (POKE) theã' time information directly to video memory.ãã' In this demo a sample menu lets you toggle between different formats:ã' hh:mm:ss (the default TIME$)ã' hh:mm (including a blinking colon)ã' 12/24 hrs system, adding AM or PM for 12 hrsãã' For computers with vga card there is an extra font to displayã' the time in 'digital' form. These font (earlier released asã' "LOADFONT.BAS") includes the characters 0 - 9, A, P and M. Theyã' will temporaryly replace the characters 224 throug 238 of theã' default ASCII set. It is to be restored while quitting.ã' ---------------------------------------------------------------------ããDEFINT A - Zãã%NO = 0 : %YES = NOT %NO ' equates true/false (0/-1)ãã%AX = 1 : %BX = 2 : %CX = 3 ' equates for ...ã%DX = 4 : %BP = 7 : %ES = 9 ' ... registersããTYPE CLOCKFLAGSã twelve AS INTEGER ' 12 hrs clockã secs AS INTEGER ' show secondsã font AS INTEGER ' use special fontãEND TYPEããTYPE FLAGSã mono AS INTEGER ' monochrome screenã vga AS INTEGER ' ega/vga card presentãEND TYPEããDIM clok AS SHARED CLOCKFLAGSãDIM flg AS SHARED FLAGSãDIM VideoAddress AS SHARED INTEGERããIF (pbvScrnCard AND 1) = 0 THEN ' test card typeã VideoAddress = &HB800 ' color cardãELSEã VideoAddress = &HB000 ' monochromeã flg.mono = %YESãEND IFããIF BIT(pbvScrnCard, 4) THEN ' is it a vga-card as well?ã LoadFont ' load special charsã flg.vga = %YES ' vga modifications done!ãEND IFããSUB LoadFontã cred$ = CHR$(126, 129, 189, 165, 161, 165, 189, 129, 126)ã phon$ = CHR$( 0, 0, 0, 126, 255, 153, 60, 126, 126)ã zero$ = CHR$( 56, 198, 198, 198, 0, 198, 198, 198, 56)ã one$ = CHR$( 24, 24, 24, 24, 0, 24, 24, 24, 24)ã two$ = CHR$( 56, 198, 6, 6, 56, 192, 192, 192, 62)ã thre$ = CHR$( 56, 198, 6, 6, 56, 6, 6, 198, 56)ã four$ = CHR$(198, 198, 198, 198, 56, 6, 6, 6, 6)ã five$ = CHR$( 62, 192, 192, 192, 56, 6, 6, 198, 56)ã six$ = CHR$(192, 192, 192, 192, 56, 198, 198, 198, 56)ã sevn$ = CHR$(248, 6, 6, 6, 0, 6, 6, 6, 6)ã eigt$ = CHR$( 56, 198, 198, 198, 56, 198, 198, 198, 56)ã nine$ = CHR$( 56, 198, 198, 198, 56, 6, 6, 198, 56)ã a$ = CHR$( 56, 198, 198, 198, 56, 198, 198, 198, 198)ã p$ = CHR$( 56, 198, 198, 198, 56, 192, 192, 192, 192)ã m$ = CHR$(126, 219, 219, 219, 0, 219, 219, 195, 195)ãã start$ = STRING$(3, 0) ' align topã tail$ = STRING$(4, 0) ' align tailã between$ = STRING$(7, 0) ' align prev. and next charãã ' NOTE: if the characters don't bottom align versus defaultã ' font characters (e.g. the colon) then unmark the next line:ãã ' SWAP start$, tail$ãã pattern$ = start$ + cred$ + between$ + phon$ + between$ + zero$ + _ã between$ + one$ + between$ + two$ + between$ + thre$ + _ã between$ + four$ + between$ + five$ + between$ + six$ + _ã between$ + sevn$ + between$ + eigt$ + between$ + nine$ + _ã between$ + a$ + between$ + p$ + between$ + m$ + tail$ãã REG %AX, &H1100 ' functionã REG %BX, 16 * 256 ' 16 bytes per char in BHã REG %CX, 15 ' number of charactersã REG %DX, 224 ' first char in ASCII-set to modifyã REG %ES, STRSEG(pattern$)ã REG %BP, STRPTR(pattern$)ã CALL INTERRUPT &H10ã REG %AX, &H1103 ' functionã REG %BX, 0ã CALL INTERRUPT &H10ãEND SUBãã' Trim all spaces from both ends of a stringãFUNCTION TRIM(BYVAL text AS STRING) AS STRINGã FUNCTION = LTRIM$(RTRIM$(text))ãEND FUNCTIONããFUNCTION TimeToDisplay AS STRINGã temp$ = TIME$ã IF NOT clok.secs THEN temp$ = LEFT$(temp$, 5) ' skip secondsã hour = VAL(LEFT$(temp$, 2))ã extension$ = SPACE$(3)ãã IF clok.twelve THENã SELECT CASE hourã CASE => 12ã IF hour > 12 THEN DECR hour, 12ã extension$ = " PM"ã CASE ELSEã IF hour = 0 THEN hour = 12ã extension$ = " AM"ã END SELECTã END IFãã temp$ = TRIM(STR$(hour)) + MID$(temp$, 3) + extension$ã temp$ = temp$ + SPACE$(11 - LEN(temp$) ) ' fixed length = 11 charsãã IF clok.font THENã FOR count = 48 TO 57ã REPLACE CHR$(count) WITH CHR$(count + 178) IN temp$ã NEXTã REPLACE CHR$(65) WITH CHR$(236) IN temp$ã REPLACE CHR$(80) WITH CHR$(237) IN temp$ã REPLACE CHR$(77) WITH CHR$(238) IN temp$ã END IFãã FUNCTION = temp$ãEND FUNCTIONããSUB TimeInfoã STATIC colonã IF flg.mono THENã attri = 112 ' black on whiteã ELSEã attri = 121 ' blue on whiteã END IFãã Info$ = TimeToDisplayã IF colon = %NO AND clok.secs = %NO THENã REPLACE ":" WITH CHR$(32) IN Info$ã colon = %YESã ELSEã colon = %NOã END IFãã NextChar = 1ãã DEF SEG = VideoAddressã FOR offset = 102 TO 122 STEP 2 ' 11 characters + 11 colorsã character = ASC(MID$(Info$, NextChar, 1))ã POKE offset, characterã POKE offset + 1, attriã INCR NextCharã NEXTã DEF SEGãEND SUBããFUNCTION GetKeyã STATIC lastTime$ãã DOãã IF TIME$ <> lastTime$ THEN ' every secondã lastTime$ = TIME$ã TimeInfoã END IFãã LOOP UNTIL INSTATãã FUNCTION = CVI( INKEY$ + CHR$(0) )ãEND FUNCTIONããSUB DemoMenuãã ' menu textã COLOR 7, 0ã IF flg.vga THENã LOCATE 3, 4ã PRINT "F1 = toggle fonts"ã END IFã LOCATE 4, 4 : PRINT "F2 = toggle seconds"ã LOCATE 5, 4 : PRINT "F3 = toggle 12/24 hrs"ã LOCATE 6, 4 : PRINT "Esc = end of this demo"ãã DOã KeyIn = GetKeyã SELECT CASE KeyInã CASE 27ã IF flg.vga THEN SCREEN 0, 0, 0, 0 ' restore default fontã CLSã SYSTEMã CASE 59 * 256 ' F1ã IF NOT flg.vga THEN EXIT SELECTã IF clok.font THEN clok.font = %NO ELSE clok.font = %YESã CASE 60 * 256 ' F2ã IF clok.secs THEN clok.secs = %NO ELSE clok.secs = %YESã CASE 61 * 256 ' F3ã IF clok.twelve THEN clok.twelve = %NO ELSE clok.twelve = %YESã END SELECTã LOOPãEND SUBããã' demo mainããCLSã COLOR 0, 7ã LOCATE 1, 1 : PRINT SPACE$(80); ' dummy menu barã LOCATE 1, 4 : PRINT "Sample Menu Bar"ãã clok.secs = %YES ' start with default TIME$ã CALL DemoMenuãENDãEgbert Zijlema TRAP KEYBOARD INACTIVITY E.Zijlema@uni4nn.iaf.nl 08-19-96 (19:53) PB 99 2673 NOKEY.BAS ' NOKEY.BAS - how to trap keyboard inactivityã' Author : Egbert Zijlema (E.Zijlema@uni4nn.iaf.nl)ã' (up)Date : August 19, 1996ã' Language : Power Basic 3.2ã' Copyright : Public Domainãã' This routine does not demonstrate a sophisticated screen saver.ã' Its main purpose is to show the most simple method to trap keyboardã' inactivity for a certain period of time.ã' As a sample screen saver it turns the screen black, just to proofã' that it really works.ãã' Most programmers use the TIMER FUNCTION to calculate the number ofã' seconds before screen saver launch. This works. I used it myselfã' until an hour ago. There is 1 small problem however: as soon asã' the computer's clock passes midnight, TIMER is (re)set to zeroã' which will cause an infinite loop - unless you correct it byã' adding 86400 seconds every round, e.g.:ãã' start# = TIMERã' DOã' now# = TIMERã' IF now# < start# THEN INCR now#, 86400 [ adjust for midnight]ã' IF now# - start# => .... THENã' (command to start screen saver)ã' END IFã'ã' (code for keyboard trapping)ã' LOOP UNTIL ........ãã' ---------------------------- begin code ---------------------------ããDEFINT A - ZãFUNCTION GetKey AS INTEGERã STATIC t$ ' alias for TIME$ã DOãã IF seconds = 30 THEN ' half a minute for this demoã CALL BlackScreen ' start screen saverã EXIT FUNCTIONã END IFãã IF t$ <> TIME$ THEN ' TIME$ changes every secondã t$ = TIME$ã LOCATE 1, 72 : PRINT t$ ' you may leave this outã INCR seconds ' add 1ã END IFãã KeyIn$ = INKEY$ã LOOP UNTIL LEN(KeyIn$) ' until keypressãã FUNCTION = CVI( KeyIn$ + CHR$(0) )ãEND FUNCTIONããSUB BlackScreenã DEF SEG = &HB800 ' color card - use &HB000 for monochromeã OldScreen$ = PEEK$(0, 4000)ã COLOR 7, 0ã LOCATE , , 0 ' hide cursorã CLSã DOã LOOP UNTIL LEN(INKEY$)ã POKE$ 0, OldScreen$ã DEF SEGãEND SUBããSUB MainMenuã DOã KeyIn = GetKeyã SELECT CASE KeyInã CASE 27ã CLSã SYSTEMã CASE ELSEã ' other keys not supported hereã END SELECTã LOOPãEND SUBãã' mainããCLSã COLOR 15, 0ã LOCATE 2, 4ã PRINT "NOKEY.BAS - traps keyboard inactivity"ã LOCATE 3, 4ã PRINT "Author : Egbert Zijlema"ã LOCATE 4, 4ã PRINT "Copyright status: Public Domain"ã LOCATE 10, 4ã PRINT "This screen will turn black after 30 seconds"ã LOCATE 11, 4ã PRINT "Press any key to restore it"ã COLOR 7ã LOCATE 14, 4ã PRINT "(or press Esc to finish this demo)"ãã MainMenuãENDãAndrew K. Dart CONVERT UNIX TIME STAMP FidoNet QUIK_BAS Echo 10-14-96 (17:32) QB, QBasic, PDS 70 2436 UNIXTIME.BAS'Note: My real name is Andrew K. Dart. (Required by the rules!)ãã'I'm sure by now you've been flooded with replies to your question aboutã'UNIX time stamps, where the date and time is represented by a longã'integer indicating the number of seconds past midnight, 1/1/1970.ã'I would have replied sooner, but there was ideal kite-flying weatherã'yesterday! Here's what I've pieced together for you:ããREM Program converts UNIX-style date code into day and time.ãREM The date code is expressed in the number of seconds sinceãREM midnight, January 1, 1970.ããREM Written 10/14/96 by Andrew K. Dart PUBLIC DOMAINãREM Provided as a public service, with no guarantees.ãREM If you're still using UNIX after 12/31/99,ãREM you'll need to make a few modifications.ããDIM LastDay(69 TO 99)ãLastDay(69) = 0ãFOR x = 70 TO 99ã LastDay(x) = 365 + LastDay(x - 1)ã IF x MOD 4 = 0 THEN LastDay(x) = LastDay(x) + 1ãNEXT xããDIM mo(12)ãFOR x = 1 TO 12ã READ mo(x)ãNEXT xãDATA 0,31,59,90,120,151,181,212,243,273,304,334ããINPUT "What is the date code"; Code&ãREM maximum allowable date code is LastDay(99) * 86400ãREM which is 946,684,800 seconds after 00:00 on 1/1/70.ããDays = Code& \ 86400ãFOR x = 70 TO 99ã IF Days <= LastDay(x) THEN EXIT FORãNEXT xã'PRINT USING "Apparently this was sometime in 19##."; xããFOR y = 1 TO 11ã IF Days < (LastDay(x - 1) + mo(y + 1)) THENã PRINT "The date was "; STR$(y); "/";ã PRINT RIGHT$(STR$(100 + Days - LastDay(x - 1) - mo(y) + 1), 2);ã PRINT "/"; RIGHT$(STR$(100 + x), 2)ã EXIT FORã END IFãNEXT yããREM Now let's figure out what the time of day was:ãRawSeconds = Code& MOD 86400ãHour = RawSeconds \ 3600ãMinute = (RawSeconds - (Hour * 3600)) \ 60ãSecond = RawSeconds MOD 60ãPRINT "The time was ";ãPRINT USING "##:"; Hour;ãPRINT RIGHT$(STR$(100 + Minute), 2); ":";ãPRINT RIGHT$(STR$(100 + Second), 2)ãENDãã'============== END ===============ãã'I presume that you do not want to account for Leap Seconds,ã'because the computer clock (on the system running UNIX) probably doesã'not count them. However if you wanted to use a program like this toã'figure the exact number of seconds between two times, on two differentã'dates, you would need to find out whether one or more leap seconds hadã'occurred between the two dates. For details on leap seconds,ã'E-Mail me atã' andrew.dart@chrysalis.orgãEgbert Zijlema PRINT COUNTRY SPECIFIC DATE E.Zijlema@uni4nn.iaf.nl 11-02-96 (16:40) PB 55 1766 DATES.BAS ' CTRYDATE.BAS - prints a date on the screen, using country specificã' separator - e.g.: dot in Germany, slash in UK & Japan,ã' hyphen in USA etc.ãã' Author : Egbert Zijlema (E.Zijlema@uni4nn.iaf.nl)ã' (up)Date : November 22, 1996ã' Language : Power Basic 3.2ã' Copyright status: Public Domainãã' Notification : Result depends of correct COUNTRY settingã' in your CONFIG.SYS file!ãã' ------------- begin code --------------ãDEFINT A - ZããSUB GetCountryInfo(format, seperator$)ã buffer$ = SPACE$(64) ' information bufferã REG 8, STRSEG(buffer$) ' DS = segment of bufferã REG 4, STRPTR(buffer$) ' DX = offset of bufferã REG 1, &H3800 ' AX = serviceã CALL INTERRUPT &H21ãã ' after the call buffer$ = filled:ã format = ASC(buffer$) ' date format (1 out of 3) = 1st byteã seperator$ = MID$(buffer$, 12, 1) ' delimiter = 12th byteãEND SUBããFUNCTION CountrySpecificDate(InputDate$) AS STRINGãã ' InputDate$ as MM-DD-YYYY (= default format)ãã IF InputDate$ = "" THEN InputDate$ = DATE$ã MM$ = MID$(InputDate$, 1, 2)ã DD$ = MID$(InputDate$, 4, 2)ã YY$ = MID$(InputDate$, 7)ãã GetCountryInfo form, delim$ã SELECT CASE formã CASE 0ã FUNCTION = InputDate$ ' USA (Basic's default)ã CASE 1ã FUNCTION = DD$ + delim$ + _ã MM$ + delim$ + YY$ ' EURã CASE 2ã FUNCTION = YY$ + delim$ + _ã MM$ + delim$ + DD$ ' JAPã END SELECTãEND FUNCTIONãã' demo callãCLSã PRINT "To-day's date is: "; CountrySpecificDate("") ' use actual dateãENDãã' ----- end code ------------------------------ãEgbert Zijlema MULTI-LANGUAGE CALENDAR ROUTINEe.zylema@castel.nl 01-13-97 (13:05) PB 512 18235 CELEBRAT.BAS$LIB ALL OFFã$ERROR ALL OFFã$OPTIMIZE SIZEã$FLOAT NPX ' for machines with math processorã$CPU 80386 ' 386 and higherãã' $COMPILE EXE "FEESTDGN.EXE" ' dutch }ã' $COMPILE EXE "FEIERTAG.EXE" ' german } un-REM filename of choiceã' $COMPILE EXE ' english }ããã' CELEBRAT.BAS - a multi-language calendar routineã' Author : Egbert Zijlema (E.Zijlema@uni4nn.iaf.nl)ã' (up)Date : 13 January 1997 (Julian 2450462)ã' Status : Public Domainã' Compiler : Power Basic 3.2 for DOSãã' CELEBRAT.BAS displays the dates of the celebration days for a given year.ã' Additionally it performs a browsable monthly calendar.ãã' Screen text is either in English, German or Dutch, which dependsã' of a correct COUNTRY setting in your CONFIG.SYS file.ã' German text will be shown in Germany and Austria, Dutch in Theã' Netherlands. In any other country the program defaults to English.ã' When writing a date to the screen, it uses the correctã' delimiters (e.g. dot for Germany, slash for the UK, hyphen forã' the USA and The Netherlands)ãã' Note: ASCII characters > 127 are written as: CHR$(). This hasã' no special reason, except to avoid that Window's Notepad willã' change them when copying the code to my Internet mailer (e.g.:ã' the German name for March, the Dutch florin sign)ããDEFINT A - Z ' all variables integer, unless taggedãDIM SevenDays(1 : 7) AS SHARED STRINGãDIM TwelveMonths (1 : 12) AS SHARED STRINGãDIM DaysInMonth(1 : 12) AS SHARED INTEGERãDIM ScreenText(1 : 15) AS SHARED STRINGããSUB FillDaysInMonthã DaysInMonth( 1) = 31 : DaysInMonth( 2) = 28ã DaysInMonth( 3) = 31 : DaysInMonth( 4) = 30ã DaysInMonth( 5) = 31 : DaysInMonth( 6) = 30ã DaysInMonth( 7) = 31 : DaysInMonth( 8) = 31ã DaysInMonth( 9) = 30 : DaysInMonth(10) = 31ã DaysInMonth(11) = 30 : DaysInMonth(12) = 31ãEND SUBããSUB GetCountryInfo(format, buffer$)ã ' results depend on correct COUNTRY settings in CONFIG.SYSãã buffer$ = SPACE$(64) ' information bufferã REG 8, STRSEG(buffer$) ' DS = segment of bufferã REG 4, STRPTR(buffer$) ' DX = offset of bufferã REG 1, &H3800 ' AX = serviceã CALL INTERRUPT &H21 ' fill buffer$ã format = ASC(buffer$) ' date format (1 out of 3) = 1st byteãEND SUBããSUB FillDutchArraysã SevenDays(1) = "maandag" : SevenDays(2) = "dinsdag"ã SevenDays(3) = "woensdag" : SevenDays(4) = "donderdag"ã SevenDays(5) = "vrijdag" : SevenDays(6) = "zaterdag"ã SevenDays(7) = "zondag"ãã TwelveMonths( 1) = "januari" : TwelveMonths( 2) = "februari"ã TwelveMonths( 3) = "maart" : TwelveMonths( 4) = "april"ã TwelveMonths( 5) = "mei" : TwelveMonths( 6) = "juni"ã TwelveMonths( 7) = "juli" : TwelveMonths( 8) = "augustus"ã TwelveMonths( 9) = "september" : TwelveMonths(10) = "oktober"ã TwelveMonths(11) = "november" : TwelveMonths(12) = "december"ãã ScreenText( 1) = "Datum: " : ScreenText( 2) = "Tijd : "ã ScreenText( 3) = " = afsluiten" : ScreenText( 4) = " = maand"ã ScreenText( 5) = " = jaar" : ScreenText( 6) = "FEESTDAGEN"ã ScreenText( 7) = "Nieuwjaar : " : ScreenText( 8) = "Goede vrijdag: "ã ScreenText( 9) = "Pasen : " : ScreenText(10) = "Hemelvaart : "ã ScreenText(11) = "Pinksteren : " : ScreenText(12) = "Kerstdagen : "ã ScreenText(13) = " v.C." : ScreenText(14) = " = eeuw"ã ScreenText(15) = "Tijd- en datumroutines door: "ãEND SUBããSUB FillEnglishArraysã SevenDays(1) = "Monday" : SevenDays(2) = "Tuesday"ã SevenDays(3) = "Wednesday" : SevenDays(4) = "Thursday"ã SevenDays(5) = "Friday" : SevenDays(6) = "Saturday"ã SevenDays(7) = "Sunday"ãã TwelveMonths( 1) = "January" : TwelveMonths( 2) = "February"ã TwelveMonths( 3) = "March" : TwelveMonths( 4) = "April"ã TwelveMonths( 5) = "May" : TwelveMonths( 6) = "June"ã TwelveMonths( 7) = "July" : TwelveMonths( 8) = "August"ã TwelveMonths( 9) = "September" : TwelveMonths(10) = "October"ã TwelveMonths(11) = "November" : TwelveMonths(12) = "December"ãã ScreenText( 1) = "Date : " : ScreenText( 2) = "Time : "ã ScreenText( 3) = " = Quit" : ScreenText( 4) = " = Month"ã ScreenText( 5) = " = Year" : ScreenText( 6) = "CELEBRATION DAYS"ã ScreenText( 7) = "New Year : " : ScreenText( 8) = "Good Friday : "ã ScreenText( 9) = "Easter : " : ScreenText(10) = "Ascension day: "ã ScreenText(11) = "Whit days : " : ScreenText(12) = "Christmas : "ã ScreenText(13) = " b.C." : ScreenText(14) = " = Century"ã ScreenText(15) = "Time & date routines by: "ãEND SUBããSUB FillGermanArraysã SevenDays(1) = "Montag" : SevenDays(2) = "Dienstag"ã SevenDays(3) = "Mittwoch" : SevenDays(4) = "Donnerstag"ã SevenDays(5) = "Freitag" : SevenDays(6) = "Samstag"ã SevenDays(7) = "Sonntag"ãã TwelveMonths( 1) = "Januar" : TwelveMonths( 2) = "Februar"ã TwelveMonths( 3) = "M" + CHR$(132) + "rz"ã TwelveMonths( 4) = "April"ã TwelveMonths( 5) = "Mai" : TwelveMonths( 6) = "Juni"ã TwelveMonths( 7) = "Juli" : TwelveMonths( 8) = "August"ã TwelveMonths( 9) = "September" : TwelveMonths(10) = "Oktober"ã TwelveMonths(11) = "November" : TwelveMonths(12) = "Dezember"ãã ScreenText( 1) = "Datum: " : ScreenText( 2) = "Zeit : "ã ScreenText( 3) = " = Ende" : ScreenText( 4) = " = Monat"ã ScreenText( 5) = " = Jahr" : ScreenText( 6) = "FEIERTAGE"ã ScreenText( 7) = "Neu Jahr : " : ScreenText( 8) = "Karfreitag : "ã ScreenText( 9) = "Ostern : " : ScreenText(10) = "Himmelfahrt : "ã ScreenText(11) = "Pfingsten : " : ScreenText(12) = "Weihnachten : "ã ScreenText(13) = " v.C." : ScreenText(14) = " = Jahr100"ã ScreenText(15) = "Zeit und Datum Routinen durch: "ãEND SUBããSUB DisplayCalendar(page, annum)ã FirstDay$ = DayOfTheWeek(annum, page, 1) ' 1st day of the monthãã Y = VAL(MID$(DATE$, 7)) ' }ã M = VAL(LEFT$(DATE$, 2)) ' } actual dateã D = VAL(MID$(DATE$, 4, 2)) ' } we need this to testã ToDay& = Julian(Y, M, D) ' } for inverse displayingãã days = DaysInMonth(page) ' number of daysã IF page = 2 THEN ' Februaryã days = days + LeapYear(annum) ' 28 + 1 ?ã END IFãã COLOR 0, 1 ' calendar's background blueã FOR row = 1 TO 8ã LOCATE row, 1ã PRINT SPACE$(55)ã NEXTãã COLOR 15ã FOR count = 1 TO 7ã header$ = header$ + LEFT$(SevenDays(count), 3) + SPACE$(3)ã NEXTã LOCATE 1, 16 : PRINT RTRIM$(header$)ãã COLOR 11ã LOCATE 2, 2 : PRINT YearToDisplay(annum)ã LOCATE 3, 2 : PRINT TwelveMonths(page) ' name of the monthãã ' display calendar:ã col = INSTR(header$, LEFT$(FirstDay$, 3)) + 16ã row = 3ã FOR count = 1 TO daysã fore = 7ã TestDate& = Julian(annum, page, count)ã IF col = 53 OR _ã count = 1 AND page = 1 OR _ ' NewYearã count = 25 AND page = 12 OR _ ' Christmas Dayã count = 26 AND page = 12 OR _ ' Boxing Dayã TestDate& = GoodFriday(annum) OR _ã TestDate& = EasterMonday(annum) OR _ã TestDate& = AscensionDay(annum) OR _ã TestDate& = WhitMonday(annum) THEN INCR fore, 7 ' yellowãã IF TestDate& = ToDay& THENã IF fore = 14 THEN COLOR 14, 7 ELSE COLOR 1, fore ' inverseã ELSEã COLOR fore, 1ã END IFã LOCATE row, colã IF annum = -4713 AND page = 11 AND count < 25 THENã PRINT SPACE$(2) ' skip Julians < 1ã ELSEã PRINT RIGHT$(SPACE$(2) + LTRIM$(RTRIM$(STR$(count))), 2)ã END IFã INCR col, 6ã IF col = 59 THENã col = 17 : INCR rowã END IFã NEXTãEND SUBããSUB DisplayCelebrations(year)ã COLOR 7, 0ã FOR row = 13 TO 16ã LOCATE row, 18 : PRINT SPACE$(63) ' clear fieldsã NEXTã temp$ = JulToDate(GoodFriday(year))ã LOCATE 13, 18ã PRINT LTRIM$(MID$(temp$, 4, 2), ANY "0"); CHR$(32);ã PRINT TwelveMonths(VAL(LEFT$(temp$, 2)))ã TwoDays EasterSunday(year), EasterMonday(year), temp$ã LOCATE 14, 18 : PRINT temp$ã temp$ = JulToDate(AscensionDay(year))ã LOCATE 15, 18ã PRINT LTRIM$(MID$(temp$, 4, 2), ANY "0"); CHR$(32);ã PRINT TwelveMonths(VAL(LEFT$(temp$, 2)))ã TwoDays WhitSunday(year), WhitMonday(year), temp$ã LOCATE 16, 18 : PRINT temp$ãEND SUBããSUB TwoDays(first&, second&, result$)ã temp1$ = JulToDate(first&)ã temp2$ = JulToDate(second&)ã month1$ = TwelveMonths(VAL(LEFT$(temp1$, 2)))ã month2$ = TwelveMonths(VAL(LEFT$(temp2$, 2)))ã result$ = LTRIM$(MID$(temp1$, 4, 2), ANY "0")ã IF month1$ = month2$ THENã result$ = result$ + ", " + LTRIM$(MID$(temp2$, 4, 2), ANY "0") + _ã CHR$(32) + month2$ã ELSEã result$ = result$ + CHR$(32) + month1$ + ", " + _ã LTRIM$(MID$(temp2$, 4, 2), ANY "0") + CHR$(32) + month2$ã END IFãEND SUBããFUNCTION GetKey AS INTEGERã STATIC t$ã DOã IF t$ <> TIME$ THENã t$ = TIME$ã COLOR 15, 0ã LOCATE 2, 65 : PRINT CountrySpecificTimeã LOCATE 3, 65 : PRINT TwelveTimeã END IFã LOOP UNTIL INSTATã FUNCTION = CVI(INKEY$ + CHR$(0))ãEND FUNCTIONããSUB InitialScreenã COLOR 12, 0ã LOCATE 5, 58 : PRINT "Esc"ã LOCATE 6, 58 : PRINT CHR$(27, 32, 26)ã LOCATE 7, 58 : PRINT CHR$(25, 32, 24)ã LOCATE 8, 58 : PRINT "PgUp/Dn"ã LOCATE 9, 58 : PRINT "Home"ãã COLOR 15ã LOCATE 1, 65 : PRINT CountrySpecificDate(DATE$)ã LOCATE 9, 1 : PRINT TextualDate(DATE$)ã LOCATE 9, 1 : PRINT UCASE$(LEFT$(TextualDate(DATE$), 1)) ' dutchã LOCATE 11, 1 + LEN(ScreenText(6))ã PRINT " IN "; YearToDisplay(VAL(MID$(DATE$, 7)))ã LOCATE 11, 1 : PRINT ScreenText(6)ã LOCATE 12, 3 : PRINT ScreenText(7)ã LOCATE 13, 3 : PRINT ScreenText(8)ã LOCATE 14, 3 : PRINT ScreenText(9)ã LOCATE 15, 3 : PRINT ScreenText(10)ã LOCATE 16, 3 : PRINT ScreenText(11)ã LOCATE 17, 3 : PRINT ScreenText(12)ã LOCATE 25, 1 + LEN(ScreenText(15)) : PRINT "Egbert Zijlema";ãã COLOR 7ã LOCATE 1, 58 : PRINT ScreenText(1)ã LOCATE 2, 58 : PRINT ScreenText(2)ã LOCATE 5, 65 : PRINT ScreenText(3)ã LOCATE 6, 65 : PRINT ScreenText(4)ã LOCATE 7, 65 : PRINT ScreenText(5)ã LOCATE 8, 65 : PRINT ScreenText(14)ã LOCATE 12, 18: PRINT "1 "; TwelveMonths(1)ã LOCATE 17, 18: PRINT "25, 26 "; TwelveMonths(12)ã LOCATE 25, 1 : PRINT ScreenText(15);ãEND SUBããSUB Menuã page = VAL(LEFT$(DATE$, 2))ã annum = VAL(MID$(DATE$, 7))ã DisplayCalendar page, annumã DisplayCelebrations annumãã DOã KeyIn = GetKeyã calendar = 0 : celebrat = 0ã SELECT CASE KeyInã CASE 77 * 256 ' right arrowã IF annum = 9999 AND page = 12 THEN EXIT SELECT ' highest 4 digityrã INCR pageã IF page > 12 THENã page = 1ã INCR annumã celebrat = -1ã END IFã calendar = -1ã CASE 75 * 256 ' left arrowã IF annum = -4713 AND page < 12 THEN EXIT SELECT ' Julian < 1ã DECR pageã IF page < 1 THENã page = 12ã DECR annumã celebrat = -1ã END IFã calendar = -1ã CASE 81 * 256 ' PgDnã IF annum > 9899 THEN EXIT SELECTã INCR annum, 100ã calendar = -1ã celebrat = -1ã CASE 71 * 256 ' Homeã yr = VAL(MID$(DATE$, 7))ã mth = VAL(LEFT$(DATE$, 2))ã IF annum = yr AND page = mth THEN EXIT SELECTã IF annum <> yr THENã annum = yrã celebrat = -1ã END IFã page = mthã calendar = -1ã CASE 72 * 256 ' up arrowã IF annum = 9999 THEN EXIT SELECTã INCR annumã calendar = -1ã celebrat = -1ã CASE 73 * 256 ' PgUpã IF annum < -4612 THEN EXIT SELECTã DECR annum, 100ã calendar = -1ã celebrat = -1ã CASE 80 * 256 ' down arrowã IF annum = -4712 THEN EXIT SELECTã DECR annumã calendar = -1ã celebrat = -1ã END SELECTã IF celebrat THEN DisplayCelebrations annumã IF calendar THEN DisplayCalendar page, annumã LOOP UNTIL KeyIn = 27ã COLOR 7, 0ã CLSã SYSTEMãEND SUBããFUNCTION CountrySpecificDate(InDate$) AS STRINGã ' InDate$ as MM-DD-[-]YYYY (= default format)ãã year = VAL(MID$(InDate$, 7))ã YY$ = YearToDisplay(year)ã GetCountryInfo form, buffer$ã delimiter$ = MID$(buffer$, 12, 1) ' 12th byteã REPLACE "-" WITH delimiter$ IN InDate$ãã SELECT CASE formã CASE 0 : FUNCTION = LEFT$(InDate$, 6) + YY$ ' USAã CASE 1ã FUNCTION = MID$(InDate$, 4, 3) + LEFT$(InDate$, 3) + YY$ ' EURã CASE 2ã FUNCTION = LEFT$(YY$, 4) + delimiter$ + LEFT$(InDate$, 3) + _ã MID$(InDate$, 4, 2) + MID$(YY$, 5) ' JAPã END SELECTãEND FUNCTIONããFUNCTION TextualDate(InDate$) AS STRINGã ' InDate$ as MM-DD-[-]YYYY (= default format)ã ' output (sample): Saturday, 4 January 1997ãã year = VAL(MID$(InDate$, 7))ã month = VAL(MID$(InDate$, 1, 2))ã day = VAL(MID$(InDate$, 4, 2))ãã FUNCTION = DayOfTheWeek(year, month, day) + ", " + _ã LTRIM$(STR$(day)) + CHR$(32) + _ã TwelveMonths(month) + CHR$(32) + _ã LTRIM$(YearToDisplay(year), ANY "0") ' no zeros hereãEND FUNCTIONããFUNCTION CountrySpecificTime AS STRINGã ' Are there countries anyway, NOT using the default delimiterã ' in TIME$? Not sure! Did'nt find any, but you never can tell.ã ' Therefore this harmless but perhaps also useless routine.ãã t$ = TIME$ã GetCountryInfo dummy, buffer$ã REPLACE ":" WITH MID$(buffer$, 14, 1) IN t$ ' time delimiter = 14th byteãã FUNCTION = t$ãEND FUNCTIONããFUNCTION TwelveTime AS STRINGã temp$ = CountrySpecificTimeã hour = VAL(LEFT$(temp$, 2))ã SELECT CASE hourã CASE > 11ã IF hour > 12 THEN DECR hour, 12ã extension$ = " PM"ã CASE ELSEã IF hour = 0 THEN hour = 12ã extension$ = " AM"ã END SELECTã FUNCTION = RIGHT$(SPACE$(2) + LTRIM$(RTRIM$(STR$(hour))), 2) + _ã MID$(temp$, 3) + extension$ãEND FUNCTIONããFUNCTION YearToDisplay(year) AS STRINGã CountYear = yearã IF CountYear < 1 THENã DECR CountYearã extension$ = ScreenText(13)ã END IFã FUNCTION = RIGHT$("0000" + LTRIM$(RTRIM$(STR$(ABS(CountYear)))), 4) + _ã extension$ãEND FUNCTIONããFUNCTION EasterSunday(year) AS LONGã temp1 = ((8 * (year \ 100)) + 13) \ 25 : DECR temp1, 2ã leap = (year \ 100) - (year \ 400) - 2ã temp2 = (15 + leap - temp1) MOD 30ã temp3 = (6 + leap) MOD 7ã days = ( temp2 + 19 * (year MOD 19) ) MOD 30ã IF (days = 29) OR (days = 28 AND year MOD 19 >= 11) THEN DECR daysã factor = ( 2 * (year MOD 4) + 4 * (year MOD 7) + 6 * days + temp3 ) MOD 7ã INCR days, factor + 21ã FUNCTION = Julian(year, 3, 1) + days ' 1 March + nbr of daysãEND FUNCTIONããFUNCTION EasterMonday(year) AS LONGã FUNCTION = EasterSunday(year) + 1ãEND FUNCTIONããFUNCTION GoodFriday(year) AS LONGã FUNCTION = EasterSunday(year) - 2ãEND FUNCTIONããFUNCTION AscensionDay(year) AS LONGã FUNCTION = EasterSunday(year) + 39ãEND FUNCTIONããFUNCTION WhitSunday(year) AS LONGã FUNCTION = EasterSunday(year) + 49ãEND FUNCTIONããFUNCTION WhitMonday(year) AS LONGã FUNCTION = EasterSunday(year) + 50ãEND FUNCTIONããFUNCTION Julian(year, month, day) AS LONGã temp& = (month - 14) \ 12ã JulPart& = day - 32075 + (1461 * (year + 4800 + temp&) \ 4)ã JulPart& = JulPart& + (367 * (month - 2 - temp& * 12) \ 12)ã FUNCTION = JulPart& - (3 * ((year + 4900 + temp&) \ 100) \ 4)ãEND FUNCTIONããFUNCTION JulToDate (Jul&) AS STRINGã ' converts a Julian number into a computational date ("MM-DD-[-]YYYY")ãã INCR Jul&, 68569ã help& = 4 * Jul& \ 146097ã DECR Jul&, (146097 * help& + 3) \ 4ã TempYear& = 4000 * (Jul& + 1) \ 1461001ã DECR Jul&, 1461 * TempYear& \ 4ã INCR Jul&, 31ã TempMonth& = 80 * Jul& \ 2447ãã day& = Jul& - (2447 * TempMonth& \ 80)ã day$ = RIGHT$("00" + LTRIM$(RTRIM$(STR$(day&))), 2)ãã month& = TempMonth& + 2 - (12 * (TempMonth& \ 11))ã month$ = RIGHT$("00" + LTRIM$(RTRIM$(STR$(month&))), 2)ãã year& = 100 * (help& - 49) + TempYear& + (TempMonth& \ 11)ã year$ = RIGHT$("0000" + LTRIM$(RTRIM$(STR$(ABS(year&)))), 4)ã IF year& < 0 THEN year$ = "-" + year$ã FUNCTION = month$ + "-" + day$ + "-" + year$ãEND FUNCTIONããFUNCTION LeapYear(year)ã OutDate$ = JulToDate(Julian(year, 2, 28) + 1) ' 28 Feb + 1 dayã IF LEFT$(OutDate$, 5) = "02-29" THENã FUNCTION = 1 ' 1 extra day for Febã ELSEã FUNCTION = 0ã END IFãEND FUNCTIONããFUNCTION DayOfTheWeek(BYVAL year, BYVAL month, BYVAL day) AS STRINGã ' returns the name for each day of the weekãã DECR month, 2ã IF month < 1 OR month > 10 THENã INCR month, 12 : DECR yearã END IFã century = year \ 100ã year = year MOD 100ã temp = INT(2.6 * month - .19) + day + year + (year \ 4)ã result = (temp + (century \ 4) - (century * 2)) MOD 7ã IF result < 1 THEN INCR result, 7ã FUNCTION = SevenDays(result)ãEND FUNCTIONããCLSã FillDaysInMonthã GetCountryInfo dummy, buff$ã country$ = EXTRACT$(MID$(buff$, 3, 2), ANY CHR$(0))ã SELECT CASE LTRIM$(RTRIM$(country$))ã CASE CHR$(159) : FillDutchArrays ' Netherlandsã CASE "DM" : FillGermanArrays ' Germanyã CASE "S"ã IF MID$(buff$, 12, 1) = "." THEN ' Austriaã FillGermanArraysã END IFã CASE ELSE : FillEnglishArrays ' other countriesã END SELECTã InitialScreenã MenuãENDãGary N. Wilkerson, Jr. ANALOG/DIGITAL CLOCK DISPLAY comp.lang.basic.misc 04-01-97 (12:00) QB, QBasic, PDS 438 11306 CLOCK2.BAS ' Analog/Digital Clockã' by Gary N. Wilkerson Jr.ãã' ConstantsãCONST ClockH = 130ãCONST ClockV = 120ãCONST Left = 1ãCONST Right = 3ãCONST TRUE = -1ãCONST FALSE = NOT TRUEãCONST TwoPI# = 2 * 3.141592654#ãã' Sub and Function modulesãDECLARE SUB OnOff (cond)ãDECLARE SUB Box (cond)ãDECLARE SUB Center (row, text$)ãDECLARE SUB KeyPause ()ãDECLARE SUB FuncKeyOn ()ãDECLARE SUB FuncKeyOff ()ãDECLARE SUB RunClock ()ãDECLARE SUB DrawScreen ()ãDECLARE SUB ClockBells ()ãDECLARE SUB TimeDate (row)ãDECLARE SUB GetCurrTime (Hour, Min, Sec, a$)ãDECLARE SUB ScreenSaver ()ãDECLARE SUB DisplayAlarmStatus ()ãDECLARE SUB DisplayChimeStatus ()ãDECLARE SUB DisplayClockStatus ()ãDECLARE FUNCTION Hplot (Length, ClockPos)ãDECLARE FUNCTION Vplot (Length, ClockPos)ãã' Converts clock face position into RadiensãDEF FnRad (x) = -(x - 30) * TwoPI# / 60ãã' Set up the Function Key trapsãKEY OFFãON KEY(1) GOSUB SetTimeãON KEY(2) GOSUB SetDateãON KEY(3) GOSUB SetAlarmãON KEY(4) GOSUB ToggleAlarmãON KEY(5) GOSUB ToggleChimeãON KEY(6) GOSUB Switch12or24ãã' Global variablesãDIM SHARED Military, Chime, Alarm, Alarm$, AlarmOn, ScreenSaveãMilitary = FALSE: Chime = TRUE: Alarm = FALSE: Alarm$ = "12:00:00"ãAlarmOn = FALSE: ScreenSave = FALSEãã' The main routineã DrawScreenã FuncKeyOnã RunClockã SYSTEMãã' Function Key trapsãSetTime:ã FuncKeyOffã RESTORE TimeSetã Box Leftã LOCATE 13, 26ã LINE INPUT a$ ' Get new timeã a$ = LTRIM$(a$): a$ = RTRIM$(a$) ' Remove excess spacesã IF a$ <> "" THENã ON ERROR GOTO TimeErrorã TIME$ = a$ ' Reset system timeã ON ERROR GOTO 0ã END IFã DrawScreenã FuncKeyOnã RETURNããTimeSet:ãDATA Enter new time,"In 24 hour [##:##:##] format"," ",ZZããTimeError:ã Center 19, " Invalid Time "ã KeyPauseã RESUME NEXTããSetDate:ã FuncKeyOffã RESTORE DateSetã Box Leftã LOCATE 13, 30ã LINE INPUT a$ã a$ = LTRIM$(a$): a$ = RTRIM$(a$)ã IF a$ <> "" THENã ON ERROR GOTO DateErrorã DATE$ = a$ ' Reset System Dateã ON ERROR GOTO 0ã END IFã DrawScreenã FuncKeyOnã RETURNããDateSet:ãDATA Enter new date,"In ##-##-#### format"," ",ZZããDateError:ã Center 19, " Invalid Date "ã KeyPauseã RESUME NEXTããSetAlarm:ã FuncKeyOffã RESTORE AlarmSetã Box Leftã LOCATE 13, 26ã LINE INPUT a$ã a$ = LTRIM$(a$): a$ = RTRIM$(a$)ã IF a$ <> "" THENã ' Sets the alarmã ON ERROR GOTO AlarmErrorã b$ = TIME$ã Alarm$ = a$ã TIME$ = a$ã TIME$ = b$ã ON ERROR GOTO 0ã END IFã ' Set alarm to system formatã a$ = TIME$ã TIME$ = Alarm$ã Alarm$ = TIME$ã TIME$ = a$ã DrawScreenã FuncKeyOnã RETURNããAlarmSet:ãDATA Enter time for alarm,"In 24 hour [##:##:##] format"," ",ZZããAlarmError:ã Center 20, " Invalid Time "ã KeyPauseã Alarm$ = "12:00:00"ã RESUME NEXTããToggleAlarm:ã IF AlarmOn THEN AlarmOn = FALSE: RETURN ' If alarm is active, shut it offã Alarm = NOT Alarmã IF NOT ScreenSave THEN DisplayAlarmStatusã RETURNããToggleChime:ã Chime = NOT Chimeã IF NOT ScreenSave THEN DisplayChimeStatusã RETURNããSwitch12or24:ã Military = NOT Militaryã IF NOT ScreenSave THEN DisplayClockStatusã RETURNããClockMenu:ãDATA [F1] -- Sets Time,[F2] -- Sets Date,[F3] -- Sets AlarmãDATA [F4] -- Toggles Alarm,[F5] -- Toggles Chime,[F6] -- Switch 12/24 hourãã' Boxã' Draws a box around the DATA for the READ statements until it reaches ZZãSUB Box (cond)ãDIM temp$(5)ããu = 0 ' Variable will equal length of longest string in BOXãã' Variable will equal the number of strings in BOXãFOR t = 0 TO 15ã READ temp$(t)ã IF temp$(t) = "ZZ" THEN EXIT FORã IF LEN(temp$(t)) > u THEN u = LEN(temp$(t))ãNEXT t: IF t = 0 THEN EXIT SUBããy = 39 - u / 2: LOCATE 11 - t / 2, y ' Center the BOX on screenãCOLOR 14, 0ãPRINT "É"; STRING$(u, 205); "»" ' Top border of BOXãFOR x = 0 TO t - 1ã a = cond ' Set variable to current conditionã LOCATE CSRLIN, yã COLOR 14, 0ã IF temp$(x) = "Í" THENã PRINT "Ì"; STRING$(u, 205); "¹" ' BOX concecratorã ELSEã PRINT "º"; SPACE$(u); "º"; ' BOX side bordersã ' First character of string may override conditionã SELECT CASE LEFT$(temp$(x), 1)ã CASE "®"ã a = Left: temp$(x) = MID$(temp$(x), 2)ã CASE ""ã a = 2: temp$(x) = MID$(temp$(x), 2)ã CASE "¯"ã a = Right: temp$(x) = MID$(temp$(x), 2)ã END SELECTã ' Justify according to conditionã SELECT CASE aã CASE Left ' Left justifyã LOCATE CSRLIN, y + 1ã CASE 2 ' Centerã LOCATE CSRLIN, 40 - LEN(temp$(x)) / 2ã CASE Right ' Right justifyã LOCATE CSRLIN, y + u + 1 - LEN(temp$(x))ã END SELECTã COLOR 15, 0ã PRINT temp$(x);ã LOCATE CSRLIN + 1, yã END IFãNEXT xãCOLOR 14, 0ãPRINT "È"; STRING$(u, 205); "¼" ' BOX bottom borderãCOLOR 15, 0ãEND SUBãã' Centerã' Centers the text$ at a given rowãSUB Center (row, text$)ãLOCATE row, 40 - LEN(text$) / 2ãPRINT text$ãEND SUBãã'ClockBellsã' Sounds the Alarm and Chime at the correct timeãSUB ClockBellsã' Hourly ChimeãIF Chime THENã IF RIGHT$(TIME$, 5) = "00:00" THENã PLAY "MBo3L8ED+ED+Eo2Bo3DCL2o2A"ã END IFãEND IFãIF Alarm THEN IF TIME$ = Alarm$ THEN AlarmOn = 16ãã' Clock's AlarmãIF AlarmOn THENã AlarmOn = AlarmOn - 1ã PLAY "MBo4L16BBBB"ãEND IFãEND SUBããSUB DisplayAlarmStatusã COLOR 14ã LOCATE 14, 40: PRINT "Alarm"; : OnOff AlarmãEND SUBããSUB DisplayChimeStatusã COLOR 11ã LOCATE 11, 40: IF Chime THEN PRINT "{Hourly Chime}" ELSE PRINT SPACE$(14)ãEND SUBããSUB DisplayClockStatusã COLOR 9ã LOCATE 16, 40: PRINT "Time reads at ";ã IF Military THEN PRINT "24"; ELSE PRINT ; "12";ã PRINT " hour mode"ãEND SUBãã' DrawScreenã' Draws the screen with the clock on itãSUB DrawScreenã 'Initialize Screenã IF ScreenSave THEN CLS : EXIT SUBã SCREEN 9ã COLOR 15, 0ã CLSãã ' Draw Borderã PRINT "É"; STRING$(78, 205); "»"ã FOR Count = 1 TO 22ã PRINT "º"; TAB(80); "º";ã NEXT Countã PRINT "È"; STRING$(78, 205); "¼";ãã 'Draw clock faceã CIRCLE (130, 120), 110, 15, , , .87ã CIRCLE STEP(0, 0), 115, 15, , , .87ã FOR Count = 0 TO 59ã LINE (Hplot(105, Count), Vplot(90, Count))-(Hplot(110, Count), Vplot(95, Count)), 15ã IF Count MOD 5 = 0 THENã LINE -(Hplot(100, Count), Vplot(85, Count)), 11ã END IFã NEXT Countãã COLOR 4ã RESTORE ClockMenuã FOR Count = 4 TO 9ã LOCATE Count, 40ã READ a$: PRINT a$ã NEXT Countãã DisplayChimeStatusã COLOR 14ã LOCATE 13, 40: PRINT "Alarm Set At "; Alarm$ã DisplayAlarmStatusã DisplayClockStatusãã COLOR 13ã Center 20, "Analog / Digital Clock"ã Center 21, "1994 by Gary N. Wilkerson Jr."ã Center 22, "Press [ESC] to quit"ãEND SUBãã' FuncKeyOffã' Turns all the Function Key traps OFFãSUB FuncKeyOffãFOR Count = 1 TO 6ã KEY(Count) OFFãNEXT CountãEND SUBãã'FuncKeyOnã' Turns all Function Key traps ONãSUB FuncKeyOnãFOR Count = 1 TO 6ã KEY(Count) ONãNEXT CountãEND SUBãã' GetCurrTimeã' Gets the current TIME from the system TIMEãSUB GetCurrTime (Hour, Min, Sec, a$)ãa$ = TIME$ãMin = VAL(MID$(a$, 4, 2)): Sec = VAL(RIGHT$(a$, 2))ãHour = (VAL(LEFT$(a$, 2)) MOD 12) * 5 + (Min / 12)ãEND SUBãã' Hplotã' Converts the hand length and clock face positionã' into an X coordinateãFUNCTION Hplot (Length, ClockPos)ãHplot = Length * SIN(FnRad(ClockPos)) + ClockHãEND FUNCTIONãã' KeyPauseã' Suspends program activity until key is pressedãSUB KeyPauseãCenter CSRLIN, " -->Press any key to continue<-- "ãWHILE INKEY$ <> "": WEND ' Clear keyboardãSLEEPãEND SUBãã' OnOffã' PRINTs ON if cond is TRUE, OFF is cond is FALSEãSUB OnOff (cond)ãPRINT " -- ";ãIF cond THENã PRINT " [ON]"ãELSEã PRINT "[OFF]"ãEND IFãEND SUBãã' This is the main routine for theã' graphics style analog / digital clockãSUB RunClockã DO UNTIL INKEY$ = CHR$(27)ã GetCurrTime Hour, Min, Sec, a$ãã ' Second Handã LINE (Hplot(90, Sec), Vplot(75, Sec))-(ClockH, ClockV), 4ã ' Minute Handã LINE -(Hplot(80, Min), Vplot(65, Min)), 14ã ' Hour Handã LINE (ClockH, ClockV)-(Hplot(50, Hour), Vplot(35, Hour)), 3ãã TimeDate 18ã ClockBellsãã ' At a 5 minute interval, activate ScreenSaverã IF Min MOD 5 = 0 AND Sec = 0 THEN ScreenSaverãã ' Pause for a second to passã WHILE a$ = TIME$: WENDãã ' Erase the handsã LINE (Hplot(90, Sec), Vplot(75, Sec))-(ClockH, ClockV), 0ã LINE -(Hplot(80, Min), Vplot(65, Min)), 0ã LINE (ClockH, ClockV)-(Hplot(50, Hour), Vplot(35, Hour)), 0ã LOOPãEND SUBãã' ScreenSaverã' Deletes the graphics clock and display a smallã' moving text clock to save the screenãSUB ScreenSaverã ScreenSave = TRUEã RowPos = 1 'Beginning clock positionã SCREEN 0: COLOR 15, 0: CLSãã DO UNTIL INKEY$ = " "ã GetCurrTime Hour, Min, Sec, a$ãã ' At every 2 minute interval, move the text clockã IF Min MOD 2 = 0 AND Sec = 0 THEN RowPos = (RowPos + 4) MOD 16: CLSãã Center RowPos, "Clock has been erased to preserve screen"ã Center RowPos + 1, "Press to restore clock"ã TimeDate RowPos + 3ãã ClockBellsã WHILE a$ = TIME$: WENDã LOOPãã ScreenSave = FALSEã DrawScreenãEND SUBãã' TimeDateã' Writes the digital Date and Time for the regular and Screen Saver screensãSUB TimeDate (row)ã COLOR 15ã ' Display the system dateã LOCATE row, 10: PRINT DATE$;ãã ' Get and display the system time according to display modeã a$ = TIME$ã LOCATE row, 60ã IF Military THENã ' 24 hour display modeã PRINT a$ã ELSEã ' 12 hour display modeã y = VAL(LEFT$(a$, 2))ã ' Let's determine the hourã IF y >= 12 THENã ' The hour is noon or laterã b$ = " pm"ã IF y > 12 THEN y = y - 12ã ELSEã ' Hour is morningã b$ = " am"ã IF y = 0 THEN y = 12 'Burning the midnight oil!ã END IFã PRINT STR$(y); RIGHT$(a$, 6); b$;ã END IFãEND SUBãã' Vplotã' Converts the hand length and clock faceã' position into a Y coordinateãFUNCTION Vplot (Length, ClockPos)ãVplot = Length * COS(FnRad(ClockPos)) + ClockVãEND FUNCTIONãNick Kochakian PRECISE DELAY NickK@worldnet.att.net 05-20-97 (15:00) QB, QBasic, PDS 60 1005 GOODELAY.BASDECLARE SUB halfpause ()ãDECLARE SUB secpause ()ãDECLARE SUB initdelay ()ã'Good delayã'ã'5/20/97 By: - Nick Kochakian -ã'ã'This program should help programmers out alot by making delays (or pauses)ã'ALOT more accurate! I hope most of you will use this code in your games,ã'demos, etc.ã'ã'If you have any comments or questions e-mail me at: nickk@worldnet.att.netããDIM SHARED cpusecãDIM SHARED ok$ããCALL initdelayã'CALL secpause 'Pause for a secondã'CALL halfpause 'Pause for a half of a secondããENDãã'You have to add these 3 lines of code for the delay init to workãok:ãok$ = "ok"ãRETURNããSUB halfpauseã'Pause for a half of a secondããcntend = cpusec * .5ãcnt = 0ãDOãcnt = cnt + 1ãLOOP UNTIL cnt >= cntendãEND SUBããSUB initdelayã'Init the delayããok$ = ""ããTIMER ONãON TIMER(1) GOSUB ok:ãcpusec = 0ãDOãcpusec = cpusec + 1ãLOOP UNTIL ok$ = "ok"ããEND SUBããSUB secpauseã'Pause for a secondããcnt = 0ãDOãcnt = cnt + 1ãLOOP UNTIL cnt >= cpusecããEND SUBãAndras Hoeffken BAVARIAN CLOCK FidoNet QUIK_BAS Echo 06-16-97 (10:39) QB, QBasic, PDS 72 2533 FUNCLOCK.BAS'A German idiom says:ãã' "In Bavaria, clocks run differently"ãã'Have fun with the following code, it demonstrates some principles ã'of the DRAW statement:ãã'BAYUHR.BAS - Bayrische Uhr auf dem PC-BildschirmããSCREEN 12: CLSããxm = 320: ym = 240 'Mittelpunkt des ZiffernblattsããFOR x = -200 TO 839 STEP 40 'blaues Rautengitterã LINE (x, 0)-(x + 200, 479), 1ã LINE (x, 0)-(x - 200, 479), 1ãNEXTãFOR y = 1 TO 6 'bayer. Farben hineinã ord = y * 95.5 - 48ã FOR x = 24 TO 656 STEP 39.5ã PAINT (x, ord - 48), 15, 1 'weissã PAINT (x - 20, ord), 1, 1 'blauã NEXT xãNEXT yãCIRCLE (xm, ym), 180, 14 'grosser Uhrenkreis, Radius 180 dotsãPAINT (xm, ym), 7, 14 'innenfarbe 7 = grauã 'Skala:ãFOR n = 6 TO 360 STEP 6 '360 Grad, 60 Minuten -> 6ø/minã wi = (n / 180) * 3.1415926#ã x = xm + SIN(wi) * 180 'Radiuspunktã y = ym + COS(wi) * 180ã f = 7: l = 5 'l/f = kleine Strichlaenge / grauã IF n MOD 30 = 0 THEN 'bei 5 min Punkten:ã f = 15: l = 14 ' grosse Strichlaenge / weissã s = xm + SIN(wi) * 195 'Printpositionã z = ym - COS(wi) * 180ã LOCATE z \ 14 - 1, s \ 8ã v = 360 - n 'Winkel rechtsrum -> linksrumã IF v = 0 THEN v = 360ã PRINT v \ 30; 'Zahl printenã END IFã PSET (x, y), f 'vom Radiuspunkt ausã DRAW "ta"+STR$(n)+"u"+STR$(l) 'Strich nach innen ziehenãNEXT nããLOCATE 29,2: PRINT "In Bavaria, clocks run differently";ããPSET (xm, ym)ãasw$="10":amw$="10":ahw$="10" '"alte" Werte initialisierenããDO 'Zeiger animieren:ã x$ = TIME$ã h = VAL(LEFT$(x$, 2)) MOD 12ã m = VAL(MID$(x$, 4, 2))ã s = VAL(RIGHT$(x$, 2))ã hw$ = STR$(INT(h * 30 + m * .5)) 'h Wertã mw$ = STR$(INT(m * 6 + s * .1)) 'm Wertã sw$ = STR$(s * 6) 's Wertã IF asw$ <> sw$ THENã DRAW "c7ta" + ahw$ + "nu130" 'alter Stundenzeiger wegã DRAW "c7ta" + amw$ + "nu162" ' " Minuten " "ã DRAW "c7ta" + asw$ + "nu162" ' " Sekunden " "ã DRAW "c0ta" + hw$ + "nu130" 'neue Stunden / Minuten = schwarzã DRAW "c0ta" + mw$ + "nu162"ã DRAW "c14ta" + sw$ + "nu162" 'neue Sekunden = gelbã asw$=sw$:amw$=mw$:ahw$=hw$ 'alte Werte merkenã END IFã A$ = INKEY$ãLOOP UNTIL A$ <> "" 'Tastendruck = EndeãSCREEN 0ãCLSãENDãBrian Mahocker CALCULATE SECONDS Kain121182@aol.com 07-03-97 (12:01) QB, QBasic, PDS 46 1248 CALCSEC.BAS CLSãINPUT "How many seconds? : ", Secc#ãLOCATE , , 0ãCLSãPRINT "Seconds :" + STR$(Sec) + " "ãPRINT "Minutes :" + STR$(Min) + " "ãPRINT " Hours :" + STR$(Hour) + " "ãPRINT " Days :" + STR$(Day) + " "ãPRINT " Years :" + STR$(Year&) + " "ãPRINT "Secconds left : " + LTRIM$(STR$(Secc#))ãDOãLET num = num + 1ãIF Secc# > 60 THENã LET Min = Min + 1ã IF Min = 60 THENã LET Min = 0ã LET Hour = Hour + 1ã IF Hour = 24 THENã Hour = 0ã LET Day = Day + 1ã IF Day = 365 THENã LET Day = 0ã LET Year& = Year& + 1ã END IFã END IFã END IFãEND IFãLET Secc# = Secc# - 60ãIF num = 5000 THENã LOCATE 1, 1ã PRINT "Seconds :" + STR$(Sec) + " "ã PRINT "Minutes :" + STR$(Min) + " "ã PRINT " Hours :" + STR$(Hour) + " "ã PRINT " Days :" + STR$(Day) + " "ã PRINT " Years :" + STR$(Year&) + " "ã PRINT "Secconds left : " + LTRIM$(STR$(Secc#))ã LET num = 0ãEND IFãLOOP UNTIL Secc# < 60ãLET Sec = Secc#ãLOCATE 1, 1ãPRINT "Seconds :" + STR$(Sec) + " "ãPRINT "Minutes :" + STR$(Min) + " "ãPRINT " Hours :" + STR$(Hour) + " "ãPRINT " Days :" + STR$(Day) + " "ãPRINT " Years :" + STR$(Year&) + " "ãMichael G. Stewart DIGITAL CLOCK/TIMER mikegs@juno.com 07-11-97 (12:37) QB, QBasic, PDS 384 10001 TIMER.BAS DECLARE SUB showdate ()ãDECLARE SUB quit ()ã'TIMER.BASã'DIGITAL CLOCK/TIMER v. 1.0ã'Copyright (C) 1997 Arrowhead Corporationã'PUBLIC DOMAINã'ã'If You Use This Program In Your Own Program,ã'Give Me (Mike Stewart) Credit.ã'ã'Have Fun! |:-)ãDECLARE SUB setime ()ãDECLARE SUB display (hr%, mn%, sc%, mode$, las%)ãDECLARE SUB drawwatch ()ãDECLARE SUB runwatch ()ãDIM SHARED modeãCONST up = 1ãCONST down = 0ãCLSãSCREEN 12ãdrawwatchãmode = 1ãrunwatchããSUB display (hr%, mn%, sc%, mode$, las%)ãhra% = CINT((hr% / 10) - .5)ãhrb% = hr% - (CINT((hr% / 10) - .5) * 10)ãmna% = CINT((mn% / 10) - .5)ãmnb% = mn% - (CINT((mn% / 10) - .5) * 10)ãsca% = CINT((sc% / 10) - .5)ãscb% = sc% - (CINT((sc% / 10) - .5) * 10)ãFOR a% = 1 TO 8ã IF a% = 1 THEN l% = hra%: c% = 20ã IF a% = 2 THEN l% = hrb%: c% = 26ã IF a% = 4 THEN l% = mna%: c% = 34ã IF a% = 5 THEN l% = mnb%: c% = 40ã IF a% = 7 THEN l% = sca%: c% = 48ã IF a% = 8 THEN l% = scb%: c% = 54ã IF a% = 3 OR a% = 6 THEN l% = 10ã IF a% = 3 THEN c% = 32ã IF a% = 6 THEN c% = 46ã SELECT CASE l%ã CASE 0ã a$ = "ÜßßßÜ"ã b$ = "Û Û"ã c$ = "Ü Ü"ã d$ = "Û Û"ã e$ = " ßßß "ã CASE 1ã a$ = " Ü"ã b$ = " Û"ã c$ = " Ü"ã d$ = " Û"ã e$ = " "ã CASE 2ã a$ = " ßßßÜ"ã b$ = " Û"ã c$ = "Üßßß "ã d$ = "Û "ã e$ = " ßßß "ã CASE 3ã a$ = " ßßßÜ"ã b$ = " Û"ã c$ = " ßßßÜ"ã d$ = " Û"ã e$ = " ßßß "ã CASE 4ã a$ = "Ü Ü"ã b$ = "Û Û"ã c$ = " ßßßÜ"ã d$ = " Û"ã e$ = " "ã CASE 5ã a$ = "Üßßß "ã b$ = "Û "ã c$ = " ßßßÜ"ã d$ = " Û"ã e$ = " ßßß "ã CASE 6ã a$ = "Üßßß "ã b$ = "Û "ã c$ = "ÜßßßÜ"ã d$ = "Û Û"ã e$ = " ßßß "ã CASE 7ã a$ = " ßßßÜ"ã b$ = " Û"ã c$ = " Ü"ã d$ = " Û"ã e$ = " "ã CASE 8ã a$ = "ÜßßßÜ"ã b$ = "Û Û"ã c$ = "ÜßßßÜ"ã d$ = "Û Û"ã e$ = " ßßß "ã CASE 9ã a$ = "ÜßßßÜ"ã b$ = "Û Û"ã c$ = " ßßßÜ"ã d$ = " Û"ã e$ = " ßßß "ã CASE 10ã IF las% = 1 THENã a$ = " "ã b$ = "Ü"ã c$ = " "ã d$ = "ß"ã e$ = " "ã ELSEã a$ = " "ã b$ = " "ã c$ = " "ã d$ = " "ã e$ = " "ã END IFã END SELECTã LOCATE 12, c%: PRINT a$ã LOCATE 13, c%: PRINT b$ã LOCATE 14, c%: PRINT c$ã LOCATE 15, c%: PRINT d$ã LOCATE 16, c%: PRINT e$ãNEXT a%ãFOR b% = 1 TO 5ã let$ = MID$(mode$, b%, 1)ã LOCATE b% + 11, 61: PRINT let$ãNEXT b%ããããEND SUBããSUB drawwatchãCLSãPAINT (320, 240), 3ãCIRCLE (320, 240), 200, 15ãPAINT (320, 240), 0, 15ãLINE (151, 175)-(489, 256), 15, BãCIRCLE (200, 140), 30, 15ãPAINT (200, 140), 8, 15ãCIRCLE (440, 140), 30, 15ãPAINT (440, 140), 8, 15ãCIRCLE (200, 291), 30, 15ãPAINT (200, 291), 8, 15ãCIRCLE (440, 291), 30, 15ãPAINT (440, 291), 8, 15ãCOLOR 14: LOCATE 8, 30: PRINT "End(1)"ãLOCATE 20, 30: PRINT "Mode(2)"ãLOCATE 8, 39: PRINT "(3)Start/Stop"ãLOCATE 20, 44: PRINT "(4)Reset/Date"ãEND SUBããSUB quitãCLSãPRINT "TIMER.BAS"ãPRINT "DIGITAL CLOCK/TIMER v. 1.0"ãPRINT "Copyright (C) 1997 Arrowhead Corporation"ãPRINT "PUBLIC DOMAIN"ãPRINTãPRINT "If You Use This Program In Your Own Program, "ãPRINT "Give Me (Mike Stewart) Credit."ãPRINTãPRINT "Good-Bye"ãENDãEND SUBããSUB runwatchãSELECT CASE modeã CASE 1ã DOã hr% = VAL(LEFT$(TIME$, 2))ã mn% = VAL(MID$(TIME$, 4, 2))ã sc% = VAL(RIGHT$(TIME$, 2))ã mode$ = "CLOCK"ã display hr%, mn%, sc%, mode$, 1ã kbd$ = ""ã kbd$ = INKEY$ã IF kbd$ = "1" THEN quitã IF kbd$ = "2" THEN mode = 2: runwatchã IF kbd$ = "3" THEN BEEPã IF kbd$ = "4" THEN showdateã LOOPã CASE 2ã resets = 1ã display 0, 0, 0, "TIMER", 1ã mode$ = "TIMER"ã DOã IF resets = 1 THENã a% = 0ã b% = 0ã c% = 0ã resets = 0ã END IFã DOã kbd$ = ""ã kbd$ = INKEY$ã IF kbd$ = "1" THEN quitã IF kbd$ = "2" THEN mode = 1: runwatchã IF kbd$ = "3" THEN EXIT DOã IF kbd$ = "4" THEN a% = 0: b% = 0: c% = 0: display 0, 0, 0, mode$, 1ã LOOPã DOã display a%, b%, c%, mode$, 1ã a$ = TIME$ã b$ = TIME$ã WHILE a$ = b$ã a$ = TIME$ã kbd$ = ""ã kbd$ = INKEY$ã IF kbd$ = "1" THEN quitã IF kbd$ = "2" THEN mode = 1: runwatchã IF kbd$ = "3" THEN resets = 1: a$ = ""ã IF kbd$ = "4" THEN start = 1: a$ = ""ã WENDã IF resets = 1 THEN EXIT DOã c% = c% + 1ã IF c% = 60 THENã c% = 0ã b% = b% + 1ã IF b% = 60 THENã b% = 0ã a% = a% + 1ã IF a% = 100 THENã BEEP: BEEPã a% = 0ã b% = 0ã c% = 0ã END IFã END IFã END IFã LOOPã LOOPãEND SELECTãEND SUBããSUB setimeãCLS : ENDããEND SUBããSUB showdateãa% = VAL(LEFT$(DATE$, 2))ãb% = VAL(MID$(DATE$, 4, 2))ãc% = VAL(RIGHT$(DATE$, 2))ãdisplay a%, b%, c%, "DATE", 0ãSLEEP 2ãEND SUBãã'(stat!(i) - meanMi!) ^ 2): NEXTãsdMi! = sdMi! / 10ãPRINT sdMi!; "("; 100 * sdMi! / meanMi!; " % )"; : COLOR 7, 0: PRINTãPRINT : PRINT "Normally the most tight test is at 1 %"ãPRINT "Press a key to compare deviations with DO LOOP SOLUTION deviations";ãSLEEPãFOR k = 0 TO 9ã i = -30000ã c! = TIMERã DOã i = i + 1ã LOOP UNTIL i > 30000ã d! = TIMERãstat!(k) = d! - c!ãNEXTãCOLOR 7, 0: PRINT "DO LOOP TESTVALUES":ãFOR i = 0 TO 9: sumL! = sumL! + stat!(i): COLOR 0, 7:ãPRINT stat!(i); : COLOR 7, 0: PRINT "", : NEXT:ãmeanL! = sumL! / 10ãPRINT "LOOP MEAN : "; : COLOR 0, 7: PRINT meanL!; : COLOR 7, 0ãPRINT " SD LOOP : "; : COLOR 0, 7:ãFOR i = 0 TO 9: sdL! = sdL! + ((stat!(i) - meanL!) ^ 2): NEXTãsdL! = sdL! / 10ãPRINT sdL!; "("; 100 * sdL! / meanL!; " % )"; : COLOR 7, 0: PRINTãã'In general all timerroutines can at least match up to the deviationã'which the DO LOOP solutions are returning. Furthermore i have noticedã'that the distance of one variation for DO LOOP is most times bigger thenã'the single differences for the timers. Even better: it is well knownã'that for the do loop solution it makes a great difference if you runã'under plain dos or not, while the timer routines seems not to makeã'a difference. Also they should be consistent on different machines,ã'a thing which is certainly not so for DO LOOPãã'If someone has results that are way out of line then I would appreciateã'some mail, stating if you are using plain dos/ dosbox, and what kindã'of deviations you got..ããã'Rick(rick@tip.nl)ãããDEFSTR A-ZãFUNCTION millitimer$ã'-----------------------------------------------ã'Making use of the toggling of bit 4 of port &h61ã'every ~/10000 second..ãã'To maintain reliability we can not go any closerã'then a ~ 1.18 msec.ãã'------------------------------------------------ããASM = ASM + CHR$(&HE4) + CHR$(&H61) 'in al,61ãASM = ASM + CHR$(&H24) + CHR$(&H10) 'and al,10ãASM = ASM + CHR$(&HB9) + CHR$(&HFF) + CHR$(&HFF) 'mov cx,ffff 1/100ãASM = ASM + CHR$(&HBA) + CHR$(&H2) + CHR$(0) 'mov dx,2ãASM = ASM + CHR$(&H88) + CHR$(&HC4) 'mov ah,alã'timerloop:ãASM = ASM + CHR$(&HE4) + CHR$(&H61) 'in al,61ãASM = ASM + CHR$(&H24) + CHR$(&H10) 'and al,10ãASM = ASM + CHR$(&H38) + CHR$(&HC4) 'cmp ah,alãASM = ASM + CHR$(&H75) + CHR$(&HF8) 'jnz -8 timerloopãASM = ASM + CHR$(&H49) 'dec cxãASM = ASM + CHR$(&H88) + CHR$(&HC4) 'mov ah,alãASM = ASM + CHR$(&H75) + CHR$(&HF3) 'jnz -13 timerloopãASM = ASM + CHR$(&H4A) 'dec dxãASM = ASM + CHR$(&H75) + CHR$(&HF0) 'jnz -16ããã'and return to qbasicãASM = ASM + CHR$(&HCB) 'retfããmillitimer = ASMããEND FUNCTIONããFUNCTION minitimerã'-----------------------------------------------ã'Making use of the toggling of bit 4 of port &h61ã'every ~/10000 second..ãã'To maintain reliability we can not go any smallerã'then aproximataly~ 1.18 msec.ãã'------------------------------------------------ããASM = ASM + CHR$(&HE4) + CHR$(&H61) 'in al,61ãASM = ASM + CHR$(&H24) + CHR$(&H10) 'and al,10ãASM = ASM + CHR$(&HB9) + CHR$(&HFF) + CHR$(&HFF) 'mov cx,ffff 1/100ãASM = ASM + CHR$(&H88) + CHR$(&HC4) 'mov ah,alã'timerloop:ãASM = ASM + CHR$(&HE4) + CHR$(&H61) 'in al,61ãASM = ASM + CHR$(&H24) + CHR$(&H10) 'and al,10ãASM = ASM + CHR$(&H38) + CHR$(&HC4) 'cmp ah,alãASM = ASM + CHR$(&H75) + CHR$(&HF8) 'jnz -8 timerloopãASM = ASM + CHR$(&H49) 'dec cxãASM = ASM + CHR$(&H88) + CHR$(&HC4) 'mov ah,alãASM = ASM + CHR$(&H75) + CHR$(&HF3) 'jnz -13 timerloopããã'and return to qbasicãASM = ASM + CHR$(&HCB) 'retfããminitimer = ASMãããEND FUNCTIONããFUNCTION Tenthtimerã'-----------------------------------------------ã'Making use of the toggling of bit 4 of port &h61ã'every microsecond..ãã'------------------------------------------------ããASM = ASM + CHR$(&HE4) + CHR$(&H61) 'in al,61ãASM = ASM + CHR$(&H24) + CHR$(&H10) 'and al,10ãASM = ASM + CHR$(&HB9) + CHR$(&HFF) + CHR$(&HFF) 'mov cx,ffff 1/100ãASM = ASM + CHR$(&HBA) + CHR$(&H11) + CHR$(&H0) 'mov dx,11h 1/100 secãASM = ASM + CHR$(&H88) + CHR$(&HC4) 'mov ah,alã'timerloop:ãASM = ASM + CHR$(&HE4) + CHR$(&H61) 'in al,61ãASM = ASM + CHR$(&H24) + CHR$(&H10) 'and al,10ãASM = ASM + CHR$(&H38) + CHR$(&HC4) 'cmp ah,alãASM = ASM + CHR$(&H75) + CHR$(&HF8) 'jnz -8 timerloopãASM = ASM + CHR$(&H49) 'dec cxãASM = ASM + CHR$(&H88) + CHR$(&HC4) 'mov ah,alãASM = ASM + CHR$(&H75) + CHR$(&HF3) 'jnz -13 timerloopãASM = ASM + CHR$(&H4A) 'dec dxãASM = ASM + CHR$(&H75) + CHR$(&HF0) 'jnz -16 timerloopã'and return to qbasicãASM = ASM + CHR$(&HCB) 'retfããTenthtimer = ASMãEND FUNCTIONãBrian Bacon DELAY ACROSS MIDNIGHT ROLL-OVERkyberteknik@geocities.com 07-21-97 (13:44) QB, QBasic, PDS 27 1136 MDELAY.BAS 'MDELAY.BAS - delays across the midnight roll-overã'written by Brian Bacon.. No warrenty - period.ã'If you want to pay me for this(yeah right) visit my web page.ã' http://home.jinko.com/brian/ã'or at least write me mail: kyberteknik@geocities.comã'You can use this is any way you want, just give me a little bit of credit.ãã'NOTE - Check out these delay values you probably don't want to use...ã'if you use .01 it wont change, if you use .02 to .04 it takes .06 secondsã'sometimes .05 takes .06 seconds too, not all the time thoughã'if you use anything above or equal to .06 it usually works fine.ã'I've concluded that this routine takes .05-.06 seconds to run MINIMUM.ãdelay! = .02ããPRINT TIMER 'This just prints the timer..ãã'---The Actual Timing Routine---ãCur! = 0ãStart! = TIMERãEndt! = Start! + delay!ãWHILE Cur! < Endt! - .02 'I subtract .02 because this is usuallyã Cur! = TIMER '.02 seconds off, BASIC is slow.ã IF Cur! < Start! THEN Start! = 0: Endt! = Endt! - 86400ãWENDã'-------------------------------ããPRINT TIMER 'This confirms it is the first one +delay! seconds.ãNigel Traves MANY DATE/TIME FUNCTIONS FidoNet QUIK_BAS Echo 09-01-97 (04:55) QB, PDS 128 8475 DATETIME.BASDEFINT A-Z:DIM SHARED K,S,B&,Z&:V1 'Created by PostIt! 7.2ãSUB V1:OPEN "O",1,"DATETIME.ZIP",4^6:Z&=6088:?STRING$(50,177);ãU"%up()%9%%%#-%6=RLHnQ'iR4.7%%4$%%%-%%%%yn%rjSgRfxN*9hxT]=?wG1ExRãU"SbM-bPAU.TfED*g.X=xU_,/\rp$-t>0SBBA][W\;0.$o>dBqa4bn_:([6]gBD)cãU"*mahXtBK:uj5fGVUbD$fl0HwujeYEYL74rXclVxrSeG0t>OJf2uãU"Opa'lTq/+jbwKb0iM=B,0K_RNGJ(OL'.pW(f=z0aswsu4LXHj?[]0_rWcRTtMr+sjXLUtrP[i8f'lãU"z4Oz+pouRoZp]Ig-LUosG;*vd1aGA.1r4OQ3B-VNlvPl;GDo<7uk1hBw\DwVB>lãU"hhjA>c13'*vD7YnaMk6dcUdQ4=6'd()$mrJN>)4gL:,#Uy7SRs'#dqdFmUD:E=hãU"#>Thg1Z$LbKjk5BCa\[XOuZJ,VPle]kk_j/[j^H'$Gi,Gp.dHFo$U76W_Ac,o+ls4j$G;=q1q1CTcrãU"iC[d2Pud9HM[1_8]wNv$xy5FIKG5<9K/GKZT&7#\SI:fca(CGBeeY&-bO\TUrUeãU"RY7C[R2&xFp=hGA2q_lCsUqdaacw&DI,WoM9OuM](l#W>mK_S6jHl>^L0d%tn4BãU"WW2c:.n+_5RMhG]p&2_mi7tOKBcD%7()5rZ^QN7COf-sH81P31aVCif(GvZiB5oeUC[qy[rh[je7gMDR7FN(gc5bc.PVr'ADX/M/doeMG44$P8bnOãU"TDf*[X#MaLsi^hp&3,w?jz\JDiTaE/>7#5^3N&^VM7/,-l+?jFKGB;5\G;[&p;mvSC,a>6*P);rãU"g?^GpS;Tg0K_rpE:/QfVEbmeEk/AUeTK.qg%#;P'eZX2:lj)3\fRpW6/wI(<:$:ãU"$rikZ>SF#YNra^#O2L*']XUDi[e(DgiNpVl#lCw1f[o_;.IlA(UH-#.AWB+yi2XZt\wePd;NU]yh^/MRN19f8=csdãU"c3\$S%0nO(52Y(^4:-,*))%Q3u[Ym4'oo>KL*--h0$ãU"Ek/GW$UVX8P*7I]>OxVGx[Zo>k;:N'm/s:HB1g^h9UFND9'=BG],yd*iA'])Yz[ãU",U+yptayasQc9m&0VyyGfO89&ugE_4>IOa+j4?Dm+8m>;xn,OG6^IEyS7\EGak>ãU"C+3>(D2T5m=,ZZy#r&uOa>H<=;\=;lrAsZ3aEYm]#ãU"<5]BOOGS'G&P1R*0ckNU).Y&hn\2[YdK.2KAIh2NiL1K&W6%d\#;KHtFD?4zdMmãU"gm3#GL<#,4I),Nv,3fkcJ7=X&WBk/H5GE.^B=DO$eCaTe+x%(up(%)9%%[%-%N&ãU"T]O7w-orx0)aFFGf#CHvnjj%v_ãU"_ktj=ei];64Q6>Lo,t*ry#G*wYh:/$XAMAwee4JEUUrc[][-1nJg1nH_STH+FiOãU"PNwZ&jsd2dTBC&psU%#]'mHb[FFL0r*V9DD)akS^goc,taC>QR\;kBb9cO;NGqCãU"D%\gEb/-;+uwZJ'14^\gW/V0+JBNk;qBFpL-_+\n_gr[+qj\2eVbG7%5A%'ASrWãU"lE'r=H=LMEZIX(E#0Jwu:V&HDcN\3k4m%I0b]n$v=>5G;14f3]4cMj&e,L1i&uYãU"xoYu3r*B(5JZ)?;VmA5u&e$OsC58g?;SjQ,+nUg/uVSy[g_f1*GU64TYy?[VZ)_ãU"LZvc]yoTD9rrj4xeFDi6ERb=m=6e^]tfxDK6(cRT8j9(.F6$e2ECj7T^?tIg3fGãU"cnnpog/wPQV5B$x?FJ9ZGDx/5hX0VhxuAJ\i:>aFj*jfTNj&kbijF'pJuw\s8L*ãU"skYHOC,_/)tVm40q:Nvx4Q-KjeuCnoQH6RL1PI?un$JQd54p*:6Ed8VC7MnQc_1ãU"l]Q[XQ>AP$DbbjR6c92+sw)JZEW30i2g-CF/6Y)_xK%_>18qC-59ãU"2>%O6Kaz.5E)TONY=oV5NEKs3X3:f3Nh[c[bG-\'A5(Hcl.61fz919PQdk-#%L5ãU"&fu.LJHZ9ZtHsLS^J6ZI8r3?q_3R,CCi/=2aCN%*&J$S;d8:32mb(2Xa0;C=a=7ãU"B:7b$lbUf-ic)VRi^Yto3Za:BiUC1w6#FnK#Tj=)Dp$F)M*$*u#]#k7W&ikCf[9ãU"dmM[sY(4oDxA>uE9/8\,SN,3S%$H6cT+D8KZ5Uk+^/bejQm#5'R0aON\fk1;Nd?ãU"8v)pO/oKl';N+=g4\mOlgZ0,5%Pm43sxqQ>992*Wa=XGh?42/H1v^-HH*R0?RGvãU"Y_^O7D7[=CyL8\07B5sG+#%tb/g?wr\1H=m4/606bBeR9PLQ8'16Bq5uU2q+mGgãU"FMnW,K*E?LGAUd,Ew=0*y%jXS/Ib-R'QIBa.xH^7cMLBK*_h(73oFFjwOM/wm(iãU"ncHA;YD6GYQG$Xr-ILCR0l.P9Dc2?S9*-\iUOyGUANrn;Wdr_#77zq.b3;B>Cp$ãU"gX^_QU,(fcM>PoOC8$aJ=H%W=K1aj0Q[)pTeZDSQFr[z(h(-%JGPrZpwE\at_[[ãU"=hsE%PqXJU-5x:VN/WcXy_.Zn6Kg\20XhHCv%=d/a/1X#F#HSA+L6jl\]qp>uZ03o/ãU"bQ3QTSU/';901NTHmh5:t(xãU"]]z(DQ9*D_c21MNe\oS1JTlp#4zYuT)z(Scjpu3nS6LI8U.4j$H7wpKiM3)#/r_U1/>H_QãU"lkq5.Yst/'$B3:%^c;yK]oedEm'K1I/?rZWR9?R:Q1CvehX1eUTjHD(j^VFCuKmãU"cEGbPi&d]EBkhFbUoc7?_8Aa(K*=x(//H[Afh'BMfCa#aJl7T#$s(eI$e+o8frOãU"dUVJea)$q-%HeãU"(>^AA1yagH0s5Ut>\qfV;5\vB;zrGrG&k\.T=IfnMc(\3#_2M/IvMS_yHf4&CdVãU"t'TzaFOPoSu?-(oepJ)scY-GL]%9C1WtCbr\qGmF'8.D%du/k]Odz1<'9&d?S-lãU"7ZrtbY\_WN3P>sz4eK2;ksLLwt=pc11]c)CyVz:8mDz\GGN?[J]lvKwWqiNiCyGãU"uU7r\C>%8m\=:t0\wf[uD;]ZKTq-v[Lg;J<[AcBH0NHG;mRm

o^:C->3fz:8mãU"dz&G_^-TT\s=M_)m3gfNVh+bwa9Ug[QYãU"bnt2i1S++xRq#=J*swTlq#&*a#sye3*bE^LPL2x/[IN-k=V*bCJQ22d:fj9j2_*ãU",^VlSaJ'jK4M8uX0Ul3MkMMEl-8m[Tza/c)$*<<_i:hsDEt&^<(,xt'LP^V?M9.ãU"s;r[uuN'hA17z8jj9M3PfPzD%6itYYnz.H8=D>,GWb:;r5m4]bAkjTm$hFz4kYvãU">1H40^-l?rN8(4HQ%H8,]XeYTjKuggkwgdj>UicrlsEuDcGR(DZfE4j$NjEf&LQãU"V9r2fai09aZfkXG,WBJfI+T-gH]0lnf,n]#l&kp:bAFt_)N9HsXRn>YmMaXNEq_ãU"O/6viDA)9lBulfn>M5JR85l>CzEahT%Hr7_^0Fz#/B,2lzg/B<$,%GlPh*eYduuãU"OJ4]VIKhFzHTA\.c2HgXkjx%S[e5,iK4JNVM$Tc%IrHT2&7P>dG/:4[kf$t+j?0o/&E*ãU"k6ItvXke**80XSGqGDBXOrNQSBH/FewBm8?ãU"vP\D8AEz3Y[z/Q7c)8Nu=Mmj:454QX-9Zt#TCKIS9R+KoC2dwe4wC%o#^oN&%NZwo)\dwg%NZvoCrdwmXwCx&ZcNIIoNxcJ)Ot%:ox.wh9rcSZwx6f$p&bV+ea+gm\5Wg1ãU"ewNi/Chp#a/Vua/Ug:MbC893GpI2T#\d9kr9ulNtflOcH1H3z)FIj6IBgW/3c;IãU"z9N0<>[Q'N5.7dL&\rc0=;LCfT%up()%9%%%I-%1=#LH'/-a:z'.%%1)%%%-%%%ãU"%yn%rjSy&'yrx0cmR7EKaV>$i*T:kkAe*u[.I/ãU"-8Mjrd^d9=Z2hi<7[zwWG0;[\?C/axGgm02Yg6Gu<:7%/MssLf5w)bI(JI=r>SBãU"5[&kta/8sVYP+K1w/9[sdnJPM\>c[ãU"ig5*mJ.F3X2+hAkCl[%2pH^ZE_>GGY/FrLm5X2A+R]&7a?hW/hv8:I8F;(S7_k8ãU"gtmJU:Dbwp)U:DZ;HTlq_lDfU2a>kip'?GwkI/&2d7w,Rk/FCMDEpVf2.5)_&nGãU"8djMxV<(aU\l+R>Q.z.Emt&hk^vllwiCKZ*>C+n2 3 THEN YR$ = RIGHT$(DT$, 4) ELSE YR$ = STR$(VAL("19" + RIGHT$(DT$, 2)))ã300 GOTO 320ã310 IF LL - P1 > 3 THEN YR$ = RIGHT$(DT$, 4): DA = 1 ELSE YR$ = CY$: DA = VAL(RIGHT$(DT$, LL - P1))ã320 YR = VAL(YR$)ã330 IF LL < 5 AND YR$ = CY$ AND MO < 1 THEN YR = YR + 1: YR$ = LTRIM$(STR$(YR))ã340 IF YR < 1753 AND SW = 0 THEN GOSUB 1200ã350 IF MO > 12 OR MO < 1 THEN DA = 1: GOTO 1140ã360 IF DA < 1 THEN 1140ã370 LP = 0ã380 IF (YR / 100 - INT(YR / 100)) = 0 THEN I = INT(YR / 400) * 400 ELSE I = INT(YR / 4) * 4ã390 IF I = YR THEN LP = 1ã400 LD = 365 + LPã410 IF MO = 2 THEN 450ã420 IF MO = 4 OR MO = 6 OR MO = 9 OR MO = 11 THEN 480ã430 IF DA > 31 THEN YR$ = STR$(VAL("19" + STR$(DA)))ã440 LM = 31: GOTO 500ã450 LM = 28 + LPã460 IF DA > LM THEN 1140ã470 GOTO 500ã480 LM = 30ã490 IF DA > LM THEN 1140ã500 IF MO < 3 THEN LP = 0ã510 N = MO * 3ã520 JUL = VAL(MID$(DY$, N - 2, 3))ã530 JUL = JUL + DA + LPã540 N = MO * 9ã550 PM$ = MID$(MN$, N - 8, 9)ã560 DT = YR + INT((YR - 1) / 4) - INT((YR - 1701) / 100) + INT((YR - 1601) / 400) + JULã570 IF P1 = 0 OR (P2 = 0 AND LL > 5) THEN 710ã580 IF DA > 31 THEN 710ã590 DW = (DT / 7): WKDY = INT((DW - INT(DW)) * 7 + .5)ã600 O1 = WKDY * 10 + 1ã610 WKDY$ = MID$(AD$, O1, 10)ã620 CLS : PRINT : PRINT : PRINTã630 PRINT TAB(6); "THE DATE "; DT$; " = "; WKDY$ã640 IF LL > 5 THEN 650ã650 PRINT : JD$ = LTRIM$(YR$) + "." + LTRIM$(STR$(JUL))ã660 PRINT TAB(6); " THE JULIAN DATE = "; JD$ã670 PRINT : PRINT : PRINT TAB(6); "WOULD YOU LIKE TO SEE"ã680 PRINT TAB(6); "THE WHOLE MONTH? (Y OR N) "; : INPUT R$ã690 IF UCASE$(R$) = "Y" THEN 710ã700 IF UCASE$(R$) = "N" THEN 120 ELSE DT$ = R$: GOTO 210ã710 DD = 0: HS = 0ã720 MS = (DT - (DA - 1)) / 7ã730 D1 = INT((MS - INT(MS)) * 7 + .5)ã740 CLSã750 PRINT TAB(8); PM$; TAB(18); LTRIM$(YR$)ã760 PRINTã770 PRINT DZ$ã780 GOSUB 1010ã790 PL$ = ""ã800 FOR WK = 1 TO 7ã810 IF DD = D1 THEN DP = 1ã820 IF DP < 10 THEN DP$ = " " + STR$(DP) ELSE DP$ = " " + STR$(DP)ã830 IF DP = 0 THEN DP$ = " "ã840 HS = 1: IF HOL$(DP) <> "" THEN DP$ = " **"ã850 IF HOL$(DP) <> "" THEN DP$ = " " + DP$ã860 PL$ = PL$ + DP$ã870 DD = DD + 1ã880 IF DP <> 0 THEN DP = DP + 1ã890 IF DP > LM THEN DP = 0: DP$ = ""ã900 NEXT WKã910 PRINT PL$ã920 IF DP = 0 THEN 940ã930 GOTO 790ã940 PRINTã950 GOTO 1280ã970 DT$ = R$: GOTO 210ã980 IF HOL$(DP) <> "" THEN HOL$(DP) = "EASTER SUNDAY" + CHR$(13) + " & " + HOL$(DP) ELSE HOL$(DP) = "EASTER SUNDAY"ã990 ED = 99ã1000 RETURNã1010 'SET MONTHS HOLIDAYSã1020 GOSUB 1880ã1030 GOSUB 1480ã1040 RESTOREã1050 READ HDT$, HOL$ã1060 IF HDT$ = "END" THEN RETURNã1070 MT = VAL(LEFT$(HDT$, 2))ã1080 IF LEN(HDT$) > 5 AND YR <> VAL(RIGHT$(HDT$, 4)) THEN 1050ã1090 IF MT <> MO THEN 1050ã1100 HDT$ = LEFT$(HDT$, 5)ã1110 DX = VAL(RIGHT$(HDT$, 2))ã1120 IF HOL$(DX) = "" THEN HOL$(DX) = HOL$ ELSE HOL$(DX) = HOL$(DX) + CHR$(13) + " & " + HOL$ã1130 GOTO 1050ã1140 CLS : LOCATE 10, 14: PRINT "INVALID DATE"ã1150 IF DA > LM THEN PRINT TAB(8); "FORMATS ARE:MM/YYYY OR MM/DD ": PRINT TAB(13); " - NOT MM/YY!"ã1160 S9 = 1ã1170 Period! = 2: GOSUB 1921ã1180 IF DA > LM AND S9 < 2 THEN S9 = S9 + 1: GOTO 1170ã1190 GOTO 120ã1200 'TOO OLDã1210 CLS : LOCATE 2, 12: PRINT "*** CAUTION ***"ã1220 PRINT : PRINT : PRINT ; "OUR PRESENT CALENDAR WAS ADOPTED IN 1753- ACCURACY FOR DATES EARLIER THAN 1753"ã1230 PRINT "MAY REQUIRE CONVERSION."ã1240 PRINT : PRINT TAB(1); "*(MOST DATES IN AMERICAN HISTORY HAVE ALREADY BEEN CONVERTED)"ã1250 PRINT : PRINT : PRINT TAB(3); "PRESS TO CONTINUE "; : INPUT R$ã1260 SW = 1ã1270 RETURNã1280 ' PRINT HOLIDAYSã1290 IF HS = 0 THEN 1460ã1300 PRINT " IMPORTANT DATE(S) IN "; PM$ã1310 PRINT STRING$(30, "*")ã1320 FOR H = 1 TO LMã1330 IF HOL$(H) = "" THEN 1350ã1340 PRINT H; TAB(5); HOL$(H)ã1350 NEXT Hã1360 PRINT "";ã1370 R$ = "": PRINT : PRINT "ENTER DATE OR FOR NEXT MONTH "; : PRINTã1380 PRINT "NEXT DATE OR END "; : INPUT R$ã1390 X = 3ã1400 FOR I = 1 TO X: PRINT : NEXTã1410 IF R$ = "" THEN DT$ = STR$(VAL(DT$) + 1): MO = MO + 1ã1420 IF MO = 13 THEN MO = 1ã1430 IF VAL(DT$) = 13 THEN DT$ = STR$(1): YR$ = STR$((VAL(YR$) + 1))ã1440 IF R$ = "" THEN GOTO 210ã1450 DT$ = R$: GOTO 210ã1460 PRINT " NO HOLIDAYS, BIRTHDAYS, OR ANYTHING AT ALL IN"; PM$ã1470 GOTO 1360ã1480 'MOVABLE HOLIDAYSã1490 ON MO GOSUB 1500, 1510, 1780, 1780, 1540, 1630, 1500, 1500, 1670, 1750, 1700, 1500ã1500 RETURNã1510 IF D1 < 2 THEN HX = 16 - D1 ELSE HX = 23 - D1ã1520 HOL$(HX) = "WASHINGTON'S BIRTHDAY"ã1530 RETURNã1540 HX = 15 - D1ã1550 IF D1 = 0 THEN HX = 8ã1560 HOL$(HX) = "MOTHER'S DAY"ã1570 HX = 30 - D1ã1580 IF D1 = 6 THEN HX = 31ã1590 HOL$(HX) = "MEMORIAL DAY **"ã1600 HX = 21 - D1ã1610 HOL$(HX) = "ARMED FORCES DAY"ã1620 RETURNã1630 HX = 22 - D1ã1640 IF D1 = 0 THEN HX = 15ã1650 HOL$(HX) = "FATHER'S DAY"ã1660 RETURNã1670 IF D1 < 2 THEN HX = 2 - D1 ELSE HX = 9 - D1ã1680 HOL$(HX) = "LABOR DAY **"ã1690 RETURNã1700 IF D1 < 2 THEN HX = 3 - D1 ELSE HX = 10 - D1ã1710 HOL$(HX) = "ELECTION DAY"ã1720 IF D1 > 4 THEN HX = 33 - D1 ELSE HX = 26 - D1ã1730 HOL$(HX) = "THANKSGIVING DAY **"ã1740 RETURNã1750 IF D1 < 2 THEN HX = 9 - D1 ELSE HX = 16 - D1ã1760 HOL$(HX) = "COLUMBUS DAY"ã1770 RETURNã1780 'EASTER SUNDAYã1790 FM = YR / 19ã1800 PFM = INT((FM - INT(FM)) * 19 + .5)ã1810 PX = PFM * 4 + 1ã1820 PFM$ = MID$(MH$, PX, 4)ã1830 EM = VAL(LEFT$(PFM$, 2)): EH = VAL(RIGHT$(PFM$, 2))ã1840 IF EM = MO THEN ED = EH ELSE ED = 99ã1850 D2 = D1: IF D2 = 0 THEN D2 = 7ã1860 IF EM = 3 AND M0 = 4 AND EH > 31 - D1 THEN ED = 0ã1870 RETURNã1880 ' CLEAR HOLIDAYSã1890 FOR IX = 1 TO 31ã1900 HOL$(IX) = ""ã1910 NEXTã1920 RETURNã1921 BEGIN! = TIMER 'Delayã1922 DO UNTIL (TIMER - BEGIN! > Period!) OR (TIMER - BEGIN! < 0)ã1923 LOOPã1924 RETURNã1930 'add any fixed day holidays here.ã1940 DATA 01/01, NEW YEARS DAY **ã1941 DATA 02/12, LINCOLN'S BIRTHDAYã1942 DATA 02/14, VALENTINE'S DAYã1943 DATA 03/17, ST. PATRICK'S DAYã1944 DATA 03/20, FIRST DAY OF SPRINGã1950 DATA 04/15, INCOME TAXES DUE !!!ã1951 DATA 06/14, FLAG DAYã1952 DATA 06/21, FIRST DAY OF SUMMERã1960 DATA 07/04, INDEPENDENCE DAYã1961 DATA 09/22, FIRST DAY OF AUTUMNã2020 DATA 10/31, HALLOWEENã2030 DATA 11/11, VETERAN'S DAYã2070 DATA 12/07, PEARL HABOR DAYã2080 DATA 12/21, FIRST DAY OF WINTERã2081 DATA 12/25, CHRISTMAS DAY **ã ' DON'T change then following line at all !ã2090 DATA END, ***ãHauke Daempfling DATE MODIFYING PROCEDURES hcd@berlin.snafu.de 11-11-97 (11:43) QB, QBasic, PDS 75 1958 DATE.BAS TYPE DateTypeã Day AS INTEGERã Month AS INTEGERã Year AS INTEGERãEND TYPEãã' by Hauke Daempflingã' hcd@berlin.snafu.deã'ã'(c)1996 Hauke Daempflingã'ã' Give me credit if used!... thanx! :)ã'ã' Date-modifiying procedures:ã' ValidDate: returns -1 if the Date (of DateType) is validã' DateString: convert DateType back to string formatã' DaysPerMonth: returns the number of days in a certain monthã' AddDays: adds days to a DateType, keeps months & years "in mind"ã' ReadDate: convert a date string (QB DATE$ variable!) to a DateTypeããDEFINT A-ZãSUB AddDays (Date AS DateType, Days AS INTEGER)ãDate.Day = Date.Day + DaysãAddDaysCheckThis:ãIF Date.Day > DaysPerMonth(Date.Month) THENã Date.Day = Date.Day - DaysPerMonth(Date.Month)ã Date.Month = Date.Month + 1ã GOTO AddDaysCheckThisãEND IFãIF Date.Month > 12 THENã Date.Month = Date.Month - 12ã Date.Year = Date.Year + 1ã GOTO AddDaysCheckThisãEND IFãEND SUBããFUNCTION DateString$ (Date AS DateType)ã x$ = LTRIM$(RTRIM$(STR$(Date.Month)))ã m$ = "00"ã MID$(m$, 3 - LEN(x$)) = x$ã x$ = LTRIM$(RTRIM$(STR$(Date.Day)))ã d$ = "00"ã MID$(d$, 3 - LEN(x$)) = x$ã x$ = LTRIM$(RTRIM$(STR$(Date.Year)))ã y$ = "0000"ã MID$(y$, 5 - LEN(x$)) = x$ã DateString$ = m$ + "-" + d$ + "-" + y$ãEND FUNCTIONããFUNCTION DaysPerMonth (Month AS INTEGER)ãSELECT CASE Monthã CASE 1, 3, 5, 7, 8, 10, 12ã d = 31ã CASE 4, 6, 9, 11ã d = 30ã CASE 2ã d = 28ã CASE ELSEã d = 30ãEND SELECTãDaysPerMonth = dãEND FUNCTIONããSUB ReadDate (DateStr$, Date AS DateType)ãDate.Month = VAL(MID$(DateStr$, 1, 2))ãDate.Day = VAL(MID$(DateStr$, 4, 2))ãDate.Year = VAL(MID$(DateStr$, 7, 4))ãEND SUBããFUNCTION ValidDate (Date AS DateType)ãIF Date.Month < 1 OR Date.Month > 12 THEN EXIT FUNCTIONãIF Date.Day < 1 OR Date.Day > DaysPerMonth(Date.Month) THEN EXIT FUNCTIONãIF Date.Year < 1 OR Date.Year > 9999 THEN EXIT FUNCTIONãValidDate = -1ãEND FUNCTIONãJohn P. Brown PRINTS OUT A CALENDAR J.P.Brown@bradford.ac.uk 11-25-97 (12:30) QB, QBasic, PDS 170 5857 CAL.BAS ' File Name : CAL.BASã' Program Name : CALENDARã' Version : Ver 1.0ã' Type : Freewareã' Developed : 24/11/97ã' Author : John P. Brownã' Revised :ã'ã' Thanks for downloading Calendarã'ã' The author makes no warrenties about the operation of this program,ã' expressed or implied.ããDECLARE SUB out3 (Month AS INTEGER)ãDECLARE SUB fillM (day1 AS INTEGER, Month AS INTEGER, n AS INTEGER)ãDECLARE SUB init ()ãDECLARE FUNCTION leapyear (y AS INTEGER)ãDECLARE FUNCTION firstday (year AS INTEGER)ãã' program calendarã' prints a calendar for any year 1582 - 4902 using Rev. Zellers formulaããCONST Mo = 0, Tu = 1, We = 2, Th = 3, Fr = 4, Sa = 5, Su = 6ãã'global variablesãDIM SHARED mat3(1 TO 3, 1 TO 6, 0 TO 6) 'array variable to hold 3 monthsãDIM SHARED Mname(1 TO 12) AS STRING * 9 'holds the names of the monthsãDIM SHARED LastD(1 TO 12) AS INTEGER 'last day variable ie. month lenghããDIM Month AS INTEGER, day1 AS INTEGER, n AS INTEGER, year AS INTEGERãã'*** Main Program ***ãSCREEN 0: WIDTH 80: CLSãinit ' fills month data arrays (month name and month lengh)ãPRINT "Calendar maker (valid years 1582-4902)"ãPRINT "======================================"ãPRINT "For which year do you want a calendar?"ãINPUT yearãIF leapyear(year) THENã LastD(2) = 29 'adjust lengh of FebruaryãEND IFãday1 = firstday(year) 'calculate day of week for jan 1stãLPRINT " ******* CALENDAR FOR "; year; " *******"ãMonth = 1 'initialize month number to JanuaryãDOã FOR n = 1 TO 3 'n points to month in row of threeã CALL fillM(day1, Month, n) 'construct one monthã day1 = (day1 + LastD(Month)) MOD 7 'sets first day of next monthã Month = Month + 1 'next monthã NEXT nã CALL out3(Month - 1) 'prints out three Months in a rowãLOOP UNTIL Month > 12 'do until end of yearãEND 'main programããSUB fillM (day1 AS INTEGER, Mnth AS INTEGER, n AS INTEGER)ã' fills 3 X "6 week by 7" day table with day numbers or zeroãDIM i AS INTEGER, w AS INTEGER, d AS INTEGERãDIM k AS INTEGER, Mnd AS INTEGERãMnd = LastD(Mnth) 'LastD day of this month ie. how many days in this monthãw = 1 'points to week in this month ie. row of calendar blockãd = day1 'initialize day number count (Mo, Tu etc. etc.)ãk = 0 'point to first valid day in calendar blockãFOR i = 0 TO day1 - 1' fill leading elementsã mat3(n, 1, i) = 0 ' with zero mat3(month-position, week, day)ãNEXT iãDOã k = k + 1 'day numberã IF k <= Mnd THEN mat3(n, w, d) = k ELSE mat3(n, w, d) = 0 'leading daysã d = d + 1ã IF d > 6 THENã d = 0 ' point toã w = w + 1 ' to next weekã END IFãLOOP UNTIL w = 7 'all elements of this month filledãEND SUB 'fillMããFUNCTION firstday (year AS INTEGER)ã' uses Zellers formula correct for 1582-4092ã' calculates the day of week for 1st janã' returns 0..6 = mon..sun ããDIM y, M, day, DayNum, C, YinC AS INTEGERã y = year - 1 'jan & feb considered to be in previous year,ã M = 11 'jan is considered to be 11 for zellers formulaã day = 1ã C = y \ 100 'get a number for Century 1977 =19 for exampleã YinC = y MOD 100 'year in century 1977 will = 77 for exampleã'Zellers formula:-ãDayNum = (FIX(2.6 * M - .19) + day + YinC + C \ 4 + YinC \ 4 - 2 * C) MOD 7ã IF DayNum > 0 THEN 'adjust the day number for this programã DayNum = DayNum - 1ã ELSEã DayNum = 6ã END IFãfirstday = DayNumãEND FUNCTION 'firstdayããSUB initã' fills global vectors for 12 Monthsãã Mname(1) = "January ": LastD(1) = 31: 'LastD day of Month Noã Mname(2) = "February ": LastD(2) = 28ã 'leap year taken care of outside this subã Mname(3) = " March ": LastD(3) = 31ã Mname(4) = " April ": LastD(4) = 30ã Mname(5) = " May ": LastD(5) = 31ã Mname(6) = " June ": LastD(6) = 30ã Mname(7) = " July ": LastD(7) = 31ã Mname(8) = " August ": LastD(8) = 31ã Mname(9) = "September": LastD(9) = 30ã Mname(10) = " October ": LastD(10) = 31ã Mname(11) = "November ": LastD(11) = 30ã Mname(12) = "December ": LastD(12) = 31ã END SUB 'initããFUNCTION leapyear (y AS INTEGER)ã ' if a leap year returns trueã ãIF (y MOD 400 = 0) OR (y MOD 4 = 0) AND (y MOD 100 <> 0) THENã leapyear = 1ãELSEã leapyear = 0ãEND IFãEND FUNCTIONããSUB out3 (Month AS INTEGER)ã' lprints three Months side by sideãDIM w AS INTEGER, i AS INTEGER, d AS INTEGER, n AS INTEGERã'headings firstãLPRINT ' \/ lprint out the names of the MonthsãLPRINT " ";ãLPRINT Mname(Month - 2); " ";ãLPRINT Mname(Month - 1); " ";ãLPRINT Mname(Month)ãFOR i = 1 TO 72 ' lprint a line across the sheetã LPRINT "-";ãNEXT iãLPRINTã FOR i = 1 TO 3 'print the day names (3 months across the page)ã FOR dn = Mo TO Suã IF dn = Mo THEN LPRINT " Mo";ã IF dn = Tu THEN LPRINT " Tu";ã IF dn = We THEN LPRINT " We";ã IF dn = Th THEN LPRINT " Th";ã IF dn = Fr THEN LPRINT " Fr";ã IF dn = Sa THEN LPRINT " Sa";ã IF dn = Su THEN LPRINT " Su";ã NEXT dnã LPRINT " ";ã NEXT iã LPRINTã FOR w = 1 TO 6 'print the dates 1st 2nd etc. in six lines.ã FOR i = 1 TO 3 '3 Months across the pageã FOR d = 0 TO 6 '7 days of the weekã IF mat3(i, w, d) <= 0 THENã LPRINT " "; 'print a blank (3 spaces)ã ELSEã LPRINT USING "###"; mat3(i, w, d); 'print a date in field widthã END IFã NEXT d 'day loopã LPRINT " "; 'print gap between Monthsã NEXT i 'Month loopã LPRINTã NEXT w 'week loopãEND SUB 'out3ãã ã' ----- John P. Brown J.P.Brown@bradford.ac.uk ---- ã' \ 'Enjoy yourself, it's later than you think' /ã' --------------------------------------------------ãAlexander Meyer YEAR 2000 TEST Meyer.Karl@t-online.de 12-20-97 (10:33) QB, QBasic, PDS 186 5011 2000TEST.BAS' ////ã' 0(o o)0ã'-------------------------ooO (_) Ooo---------------------ã' 2000TEST.BAS -- Written in QuickBasic 4.5ã' ã' Name: Year 2000 Testã' Author: Alexander Meyerã' Date: 11-23-1997ã' Description: This program checks the computer forã' suitability for the year 2000.ã'ã'For questions or comments mail to: Meyer.Karl@t-online.deã'-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-ã'**** PLEASE READ FIRST: ****ã'It is heard: The problem with the year 2000. A lot of clocks in computersã'will leap back to 1900 at the turn of the century. Their can be manyã'problems with some programs.ã'This program will test the DOS clock for suitability for the nextã'century. Their are three tests. Two are for the turn of the century.ã'if both get well nothing will happen, if one gets worse errors will beã'possible and if both get worse you should do something.ã'Test 3 checks if the computer will get well with the leap year 2004.ããOPEN "REBOOT.DAT" FOR BINARY AS #1ã IF LOF(1) = 0 THENã CLOSE #1: KILL "REBOOT.DAT": GOTO NoRebootã ELSEã CLOSE #1: GOTO Rebootã END IFãCLOSE #1ãNoReboot:ãCLSãCOLOR 14ãPRINT "Year 2000 Test"ãPRINT "by Alexander Meyer -- 1997"ãPRINT : PRINTãCOLOR 7ãPRINT "WARNING:"ãPRINT "With this program the date and the time will be changed and then they have to be"ãPRINT "adjusted by hand."ãPRINT "Continue (Y/N)"; Weiter$ãWeiterMachen:ãDO: K$ = INKEY$: LOOP WHILE K$ = ""ãIF UCASE$(K$) = "Y" THEN GOTO MenuãIF UCASE$(K$) = "N" THEN ENDãGOTO WeiterMachenããMenu:ãCLSãPRINT "MENU"ãPRINT : PRINTãPRINT "1. Test 1 (Turn of the century 2000)"ãPRINT "2. Test 2 WITH REBOOT (Turn of the century 2000)"ãPRINT "3. Test 3 (Leap year 2004)"ãPRINT "4. Set date and time"ãPRINT "Q = Quit"ãPRINTãINPUT "What do you want"; Menu$ãIF Menu$ = "1" THEN GOTO Test1ãIF Menu$ = "2" THEN GOTO Test2ãIF Menu$ = "3" THEN GOTO Test3ãIF Menu$ = "4" THEN GOTO DatumZeitãIF Menu$ = "Q" OR Menu$ = "q" THEN GOTO Quitãã'**********************************************************************ããTest1:ã' ** Test 1 **ãCLSãDATE$ = "12-31-1999"ãTIME$ = "23:59:50"ãPRINT "Date was changed to "; DATE$ãPRINT "Time was changed to "; TIME$ãDOã LOCATE 4: PRINT DATE$ã LOCATE 5: PRINT TIME$ãLOOP UNTIL TIME$ = "00:00:01"ãIF DATE$ = "01-01-2000" THENã PRINT "It won't give problems."ãELSEã PRINT "Problems are possible."ãEND IFãDO WHILE INKEY$ = "": LOOPãGOTO Menuãã'***********************************************************************ããTest2:ã' ** Test 2 **ãCLSãPRINT "WARNING:"ãPRINT "This test will reboot your computer."ãPRINT "You will lose any unsaved work."ãPRINT "DON'T START THIS FROM WINDOWS"ãPRINT "Continue (Y/N)"; Weiter$ãWeiterMachen2:ãDO: K$ = INKEY$: LOOP WHILE K$ = ""ãIF UCASE$(K$) = "Y" THEN GOTO WeiterãIF UCASE$(K$) = "N" THEN ENDãGOTO WeiterMachen2ãWeiter:ãDATE$ = "12-31-1999"ãTIME$ = "23:59:00"ãLOCATE 10ãCOLOR 14ãPRINT "To see the result start this program again after the reboot."ãCOLOR 7ãLOCATE 11: PRINT "Press any key to cancel"ãDOã Seconds = VAL(MID$(TIME$, 7, 2))ã Seconds = 60 - Secondsã LOCATE 12ã PRINT "Still"; Seconds; "seconds"ã PRINT TIME$ã IF INKEY$ <> "" THEN ENDãLOOP UNTIL TIME$ = "00:00:00"ãOPEN "REBOOT.DAT" FOR OUTPUT AS #1ã PRINT #1, "2000TEST"ãCLOSE #1ãOUT &H64, &HFE 'Taken from an old ABC packetãã'*********************************************************************ããTest3:ã' ** Test 3 **ãCLSãDATE$ = "02-28-2004"ãTIME$ = "23:59:50"ãPRINT "Date was changed to "; DATE$ãPRINT "Time was changed to "; TIME$ãDOã LOCATE 4: PRINT DATE$ã LOCATE 5: PRINT TIME$ãLOOP UNTIL TIME$ = "00:00:01"ãIF DATE$ = "02-29-2004" THENã PRINT "It won't give problems."ãELSEã PRINT "Problems are possible."ãEND IFãDO WHILE INKEY$ = "": LOOPãGOTO Menuãã'************************************************************************ããDatumZeit:ãCLSãPRINT "Current date: "; DATE$ãINPUT "New date : ", Neu$ãIF Neu$ <> "" THEN DATE$ = Neu$ãPRINT "New date : "; DATE$ãPRINT : PRINTãPRINT "Current time: "; TIME$ãINPUT "New time : ", Neu$ãIF Neu$ <> "" THEN TIME$ = Neu$ãPRINT "New time : "; TIME$ãDO: LOOP WHILE INKEY$ = ""ãGOTO Menuãã'*************************************************************************ããReboot:ãCLSãPRINT "-- Result --"ãPRINT : PRINTãPRINT "After reboot the date is "; DATE$ãIF DATE$ = "01-01-1980" THENã PRINT "probably errors will appear."ãELSEIF MID$(DATE$, 7, 4) = "1980" THENã PRINT "It is possible that errors appear."ãELSEã PRINT "There will be no errors."ãEND IFãDO WHILE INKEY$ = "": LOOPãKILL "REBOOT.DAT"ãGOTO Menuãã'**********************************************************************ããQuit:ãCLSãCOLOR 14ãPRINT "Thanks for using Year 2000 Test"ãPRINTãENDãREM -- EOF --ã'***********************************************************************ãAndrew S. Gibson PERPETUAL CALENDAR V1.7 zapf_dingbat@juno.com 01-05-98 (00:10) QB, QBasic, PDS 241 9375 PERPCAL.BAS 'This perpetual calendar program was taken out of an old issueã'of TRS-80 MicroComputer News. I typed it in and adjusted it toã'work properly with PCs (text formatting problems..)ã'I believe all major basic languages can use this code.ã'Despite its size Auto Calendar *is* accurate even in leap years !ã'Also it 'sports' moving holidays !ã'Remeber if you have an Internet Connection or E-mail you can contactã'me at Zapf_DinBat@JUNO.COM. My real name is Andrew Gibson, Althoughã'I didn't write the code you'll probably find a workingã'true Perpetual Calendar very useful every day.ã' MM represents a month (numbers 1-12)ã' DD represents a day (numbers 1-31)ã' YY represents the year (only the last two digits i.e. 1/98)ã' YYYY the full year, i.e. 1/1998ã' Typing in a specific day such as 1/25/98 (or 1/25/1998) withã' cause the program to calculate the julian date.ã' The only valid separation character is the foward slash (/).ã' *Easter will only be displayed until the year 2009. After that it crashes.ã' I have no way to test the dates displayed after this year....ã10 DEFSNG A-Z: '<-Don't change ! / Auto Calendar Version 1.7á*ã20 'WIDTH 40, 25: 'uncomment this so you can strain your eyes :}ã30 CY$ = RIGHT$(DATE$, 4) ' EXTRACT CURRENT YEAR FROM SYSTEM CLOCKã40 YR$ = CY$ã50 DIM HOL$(31)ã60 ED = 99: LM = 31ã70 PRINT : 'NEVER ALTER LINES 71-110ã71 MH$ = "0414040303230411033104180408032804160405032504130402032204100330041704070327"ã80 DY$ = "000031059090120151181212243273304334"ã90 MN$ = "JANUARY FEBRUARY MARCH APRIL MAY JUNE JULY AUGUST SEPTEMBEROCTOBER NOVEMBER DECEMBER"ã100 AD$ = "SUNDAY MONDAY TUESDAY WEDNESDAY THURSDAY FRIDAY SATURDAY"ã110 DZ$ = " SUN MON TUE WED THU FRI SAT "ã120 CLSã130 PRINT : PRINT : PRINTã140 PRINT TAB(11); "PERPETUAL CALENDAR"ã150 PRINT TAB(14); "VERSION 1.7": PRINTã160 PRINT TAB(5); " ENTER A DATE (YEARS 1753- )"ã170 PRINT TAB(6); "(FORMATS: MM/DD, MM/DD/YYYY,"ã180 PRINT TAB(6); " MM/DD/YY, MM/YYY, OR JUST MM)"ã190 PRINTã200 PRINT TAB(10); "ENTER DATE OR END"; : INPUT DT$ã210 LL = LEN(DT$)ã220 IF UCASE$(DT$) = "END" THEN WIDTH 80, 25: ENDã230 IF LL = 0 THEN 120ã240 P1 = INSTR(1, DT$, "/"): P2 = INSTR(P1 + 1, DT$, "/")ã250 IF P1 = 0 THEN MO = VAL(DT$): DA = 1: GOTO 320ã260 MO = VAL(LEFT$(DT$, P1 - 1))ã270 IF P2 = 0 THEN 310ã280 DA = VAL(MID$(DT$, P1 + 1, (P2 - 1) - P1))ã290 IF LL - P2 > 3 THEN YR$ = RIGHT$(DT$, 4) ELSE YR$ = STR$(VAL("19" + RIGHT$(DT$, 2)))ã300 GOTO 320ã310 IF LL - P1 > 3 THEN YR$ = RIGHT$(DT$, 4): DA = 1 ELSE YR$ = CY$: DA = VAL(RIGHT$(DT$, LL - P1))ã320 YR = VAL(YR$)ã330 IF LL < 5 AND YR$ = CY$ AND MO < 1 THEN YR = YR + 1: YR$ = LTRIM$(STR$(YR))ã340 IF YR < 1753 AND SW = 0 THEN GOSUB 1200ã350 IF MO > 12 OR MO < 1 THEN DA = 1: GOTO 1140ã360 IF DA < 1 THEN 1140ã370 LP = 0ã380 IF (YR / 100 - INT(YR / 100)) = 0 THEN I = INT(YR / 400) * 400 ELSE I = INT(YR / 4) * 4ã390 IF I = YR THEN LP = 1ã400 LD = 365 + LPã410 IF MO = 2 THEN 450ã420 IF MO = 4 OR MO = 6 OR MO = 9 OR MO = 11 THEN 480ã430 IF DA > 31 THEN YR$ = STR$(VAL("19" + STR$(DA)))ã440 LM = 31: GOTO 500ã450 LM = 28 + LPã460 IF DA > LM THEN 1140ã470 GOTO 500ã480 LM = 30ã490 IF DA > LM THEN 1140ã500 IF MO < 3 THEN LP = 0ã510 N = MO * 3ã520 JUL = VAL(MID$(DY$, N - 2, 3))ã530 JUL = JUL + DA + LPã540 N = MO * 9ã550 PM$ = MID$(MN$, N - 8, 9)ã560 DT = YR + INT((YR - 1) / 4) - INT((YR - 1701) / 100) + INT((YR - 1601) / 400) + JULã570 IF P1 = 0 OR (P2 = 0 AND LL > 5) THEN 710ã580 IF DA > 31 THEN 710ã590 DW = (DT / 7): WKDY = INT((DW - INT(DW)) * 7 + .5)ã600 O1 = WKDY * 10 + 1ã610 WKDY$ = MID$(AD$, O1, 10)ã620 CLS : PRINT : PRINT : PRINTã630 PRINT TAB(6); "THE DATE "; DT$; " = "; WKDY$ã640 IF LL > 5 THEN 650ã650 PRINT : JD$ = LTRIM$(YR$) + "." + LTRIM$(STR$(JUL))ã660 PRINT TAB(6); " THE JULIAN DATE = "; JD$ã670 PRINT : PRINT : PRINT TAB(6); "WOULD YOU LIKE TO SEE"ã680 PRINT TAB(6); "THE WHOLE MONTH? (Y OR N) "; : INPUT R$ã690 IF UCASE$(R$) = "Y" THEN 710ã700 IF UCASE$(R$) = "N" THEN 120 ELSE DT$ = R$: GOTO 210ã710 DD = 0: HS = 0ã720 MS = (DT - (DA - 1)) / 7ã730 D1 = INT((MS - INT(MS)) * 7 + .5)ã740 CLSã750 PRINT TAB(8); PM$; TAB(18); LTRIM$(YR$)ã760 PRINTã770 PRINT DZ$ã780 GOSUB 1010ã790 PL$ = ""ã800 FOR WK = 1 TO 7ã810 IF DD = D1 THEN DP = 1ã820 IF DP < 10 THEN DP$ = " " + STR$(DP) ELSE DP$ = " " + STR$(DP)ã830 IF DP = 0 THEN DP$ = " "ã840 HS = 1: IF HOL$(DP) <> "" THEN DP$ = " **"ã850 IF HOL$(DP) <> "" THEN DP$ = " " + DP$ã860 PL$ = PL$ + DP$ã870 DD = DD + 1ã880 IF DP <> 0 THEN DP = DP + 1ã890 IF DP > LM THEN DP = 0: DP$ = ""ã900 NEXT WKã910 PRINT PL$ã920 IF DP = 0 THEN 940ã930 GOTO 790ã940 PRINTã950 GOTO 1280ã970 DT$ = R$: GOTO 210ã980 IF HOL$(DP) <> "" THEN HOL$(DP) = "EASTER SUNDAY" + CHR$(13) + " & " + HOL$(DP) ELSE HOL$(DP) = "EASTER SUNDAY"ã990 ED = 99ã1000 RETURNã1010 'SET MONTHS HOLIDAYSã1020 GOSUB 1880ã1030 GOSUB 1480ã1040 RESTOREã1050 READ HDT$, HOL$ã1060 IF HDT$ = "END" THEN RETURNã1070 MT = VAL(LEFT$(HDT$, 2))ã1080 IF LEN(HDT$) > 5 AND YR <> VAL(RIGHT$(HDT$, 4)) THEN 1050ã1090 IF MT <> MO THEN 1050ã1100 HDT$ = LEFT$(HDT$, 5)ã1110 DX = VAL(RIGHT$(HDT$, 2))ã1120 IF HOL$(DX) = "" THEN HOL$(DX) = HOL$ ELSE HOL$(DX) = HOL$(DX) + CHR$(13) + " & " + HOL$ã1130 GOTO 1050ã1140 CLS : LOCATE 10, 14: PRINT "INVALID DATE"ã1150 IF DA > LM THEN PRINT TAB(8); "FORMATS ARE:MM/YYYY OR MM/DD ": PRINT TAB(13); " - NOT MM/YY!"ã1160 S9 = 1ã1170 Period! = 2: GOSUB 1921ã1180 IF DA > LM AND S9 < 2 THEN S9 = S9 + 1: GOTO 1170ã1190 GOTO 120ã1200 'TOO OLDã1210 CLS : LOCATE 2, 12: PRINT "*** CAUTION ***"ã1220 PRINT : PRINT : PRINT ; "OUR PRESENT CALENDAR WAS ADOPTED IN 1753- ACCURACY FOR DATES EARLIER THAN 1753"ã1230 PRINT "MAY REQUIRE CONVERSION."ã1240 PRINT : PRINT TAB(1); "*(MOST DATES IN AMERICAN HISTORY HAVE ALREADY BEEN CONVERTED)"ã1250 PRINT : PRINT : PRINT TAB(3); "PRESS TO CONTINUE "; : INPUT R$ã1260 SW = 1ã1270 RETURNã1280 ' PRINT HOLIDAYSã1290 IF HS = 0 THEN 1460ã1300 PRINT " IMPORTANT DATE(S) IN "; PM$ã1310 PRINT STRING$(30, "*")ã1320 FOR H = 1 TO LMã1330 IF HOL$(H) = "" THEN 1350ã1340 PRINT H; TAB(5); HOL$(H)ã1350 NEXT Hã1360 PRINT "";ã1370 R$ = "": PRINT : PRINT "ENTER DATE OR FOR NEXT MONTH "; : PRINTã1380 PRINT "NEXT DATE OR END "; : INPUT R$ã1390 X = 3ã1400 FOR I = 1 TO X: PRINT : NEXTã1410 IF R$ = "" THEN DT$ = STR$(VAL(DT$) + 1): MO = MO + 1ã1420 IF MO = 13 THEN MO = 1ã1430 IF VAL(DT$) = 13 THEN DT$ = STR$(1): YR$ = STR$((VAL(YR$) + 1))ã1440 IF R$ = "" THEN GOTO 210ã1450 DT$ = R$: GOTO 210ã1460 PRINT " NO HOLIDAYS, BIRTHDAYS, OR ANYTHING AT ALL IN"; PM$ã1470 GOTO 1360ã1480 'MOVABLE HOLIDAYSã1490 ON MO GOSUB 1500, 1510, 1780, 1780, 1540, 1630, 1500, 1500, 1670, 1750, 1700, 1500ã1500 RETURNã1510 IF D1 < 2 THEN HX = 16 - D1 ELSE HX = 23 - D1ã1520 HOL$(HX) = "WASHINGTON'S BIRTHDAY"ã1530 RETURNã1540 HX = 15 - D1ã1550 IF D1 = 0 THEN HX = 8ã1560 HOL$(HX) = "MOTHER'S DAY"ã1570 HX = 30 - D1ã1580 IF D1 = 6 THEN HX = 31ã1590 HOL$(HX) = "MEMORIAL DAY **"ã1600 HX = 21 - D1ã1610 HOL$(HX) = "ARMED FORCES DAY"ã1620 RETURNã1630 HX = 22 - D1ã1640 IF D1 = 0 THEN HX = 15ã1650 HOL$(HX) = "FATHER'S DAY"ã1660 RETURNã1670 IF D1 < 2 THEN HX = 2 - D1 ELSE HX = 9 - D1ã1680 HOL$(HX) = "LABOR DAY **"ã1690 RETURNã1700 IF D1 < 2 THEN HX = 3 - D1 ELSE HX = 10 - D1ã1710 HOL$(HX) = "ELECTION DAY"ã1720 IF D1 > 4 THEN HX = 33 - D1 ELSE HX = 26 - D1ã1730 HOL$(HX) = "THANKSGIVING DAY **"ã1740 RETURNã1750 IF D1 < 2 THEN HX = 9 - D1 ELSE HX = 16 - D1ã1760 HOL$(HX) = "COLUMBUS DAY"ã1770 RETURNã1780 'EASTER SUNDAYã1781 FM = YR / 19ã1782 PFM = INT((FM - INT(FM)) * 19 + .5)ã1783 PX = PFM * 4 + 1ã1784 PFM$ = MID$(MH$, PX, 4)ã1785 EM = VAL(LEFT$(PFM$, 2)): EH = VAL(RIGHT$(PFM$, 2)): ' : PRINT EHã1786 IF EM = MO THEN ED = EH ELSE ED = 99ã1787 D2 = D1: IF D2 = 0 THEN D2 = 7ã1788 IF EM = 3 AND MO = 4 AND EH > 31 - D1 THEN ED = 0ã1789 IF EM = 3 AND MO = 3 AND EH = 31 THEN HOL$(EH) = "PASSOVER"ã1790 IF EM = 3 AND MO = 4 AND EH = 31 THEN HOL$(EH - 30) = "EASTER SUNDAY (U.S.)": HOL$((EH - 30) + 1) = "EASTER SUNDAY (CAN.)"ã1791 IF EH = 1 OR EH <= 30 AND EM = 3 AND MO = 4 THENã1792 HOL$(EH) = "PASSOVER": HOL$(EH + 1) = "EASTER SUNDAY (U.S.)": HOL$(EH + 2) = "EASTER SUNDAY (CAN.)"ã1793 END IFã1876 IF EH = 1 OR EH <= 30 AND EM = 4 AND MO = 4 THENã1877 HOL$(EH) = "PASSOVER": HOL$(EH + 1) = "EASTER SUNDAY (U.S.)": HOL$(EH + 2) = "EASTER SUNDAY (CAN.)"ã1878 END IFã1879 RETURNã1880 ' CLEAR HOLIDAYSã1890 FOR IX = 1 TO 31ã1900 HOL$(IX) = ""ã1910 NEXTã1920 RETURNã1921 BEGIN! = TIMER 'Delayã1922 DO UNTIL (TIMER - BEGIN! > Period!) OR (TIMER - BEGIN! < 0)ã1923 LOOPã1924 RETURNã1930 'add any fixed day holidays here.ã1940 DATA 01/01, NEW YEARS DAY **ã1941 DATA 02/12, LINCOLN'S BIRTHDAYã1942 DATA 02/14, VALENTINE'S DAYã1943 DATA 03/17, ST. PATRICK'S DAYã1944 DATA 03/20, FIRST DAY OF SPRINGã1950 DATA 04/15, INCOME TAXES DUE !!!ã1951 DATA 06/14, FLAG DAYã1952 DATA 06/21, FIRST DAY OF SUMMERã1960 DATA 07/04, INDEPENDENCE DAYã1961 DATA 09/22, FIRST DAY OF AUTUMNã2020 DATA 10/31, HALLOWEENã2030 DATA 11/11, VETERAN'S DAYã2070 DATA 12/07, PEARL HABOR DAYã2080 DATA 12/21, FIRST DAY OF WINTERã2081 DATA 12/25, CHRISTMAS DAY **ã ' DON'T change then following line at all !ã2090 DATA END, ***ãTony L. Damigo TEXT MODE CALENDAR SHELL kvdojo@lightspeed.net 03-24-98 (12:47) PB 255 7171 CALENDAR.BASCLSãDEFINT A-ZãSCREEN 0,0,0ãSHARED JUST.SHOW ' Neededãã' ************************************************************************ã' --------------------------- Readme / Disclaimer ------------------------ã' ************************************************************************ã' Lanuage: POWERBASIC 3.1ã'ã' Author : TONY L DAMIGO E-MAIL: kvdojo@lightspeed.netã' Lake Isabella Ca. PHONE : 760-379-1751ã'ã' This program is given as PUBLIC DOMAINE software. Do with it what youã' please. However, ! USE AT YOUR OWN RISK ! I will not be responsibleã' for damages to your system ( bla, bla, the standard disclaimer)ã' If you use it..you could memtion my name :-)ã' If you have suggstions or modification, please share them.ã'ã'ã' ******* What Is It / How Does It Works *******ã'ã' This is a .SHELL. for a Calendar program. It takes the informationã' that you provide, and converts it into one of two calendar types.ã' It is a RAW program, but is has many posibilities.ã'ã' You will need to provide the variables below:ã' .MAXDAYS. are the maximum days allowed in the monthã' .WEEKDAY. that the 1st falls on: 0=Sun, 1=Mon, 2=Tue, 3=Wed, etc.."ã' .DAY. is the current/desired day of the month"ã'ã' Be cautious when assigning WinRow & WinCol. See the Note inside theã' function for details:ã'ã' Call the function and assign the result to Cal.Num, or whatever....ã' That's it! The Calendar function does the rest.ã'ã' Example:ã' Cal.Num = MAKECALENDAR(WinRor, WinCol, MaxDays, WeekDay, Day, Box)ã'ã' ----------------------------------------------------------------------ããGOSUB DISPLAY.DEMO ' This calls the DEMO SCREENãããã' ***********************************************************************ã'--------------------- THE ACTUAL CALENDAR FUNCTION ---------------------ã' ***********************************************************************ããFUNCTION MAKECALENDAR(WINROW, WINCOL, MAXDAYS, WEEKDAY, DAY, BOX)ã' NOTEã' With Box turned on:ã' WinRow must not be larger than 5 -- WinCol must not be larger than 12ã' Larger numbers can crash the program or not give the room needed forã' a calendar with the WEEKDAY being equal to 6.ã'ã' With Box turned off:ã' You have more flexibility. If you crash...decrease WinCol or WinRow.ã' -------------------------------------------------ãã REDIM DAYS(44) AS SHARED STRINGã REDIM CALPOS(MAXDAYS,2)ã SHARED JUST.SHOWãã IF BOX THENã SPACER=2 : RGAP =1 : CGAP =2ã ELSEã SPACER=1 : RGAP =1 : CGAP =3ã END IFãã' 1,2,3-10ã' 2,1,3-5ãã LASTPTR=DAYã PTR=DAYã ROW=(1+WINROW)ãã' -------------------------------------------------ã' Set the day of the month then fill the arrays with theã' days, and fill 6 DAYS() arrays at front & back with blanksã' -------------------------------------------------ãã FOR X = 1 TO 43ã IF X <=6 OR X >(MAXDAYS+6) THENã DAYS(X)=" "ã ELSEã DAYS(X)=MID$(STR$(X-6),2)ã IF (X-6)<10 THEN DAYS(X)=(" "+DAYS(X))ã END IFã NEXT Xãã' -------------------------------------------------ã' Fill locations into CALPOS() for the wrap-aroundã' function and KEY-Press routineã' -------------------------------------------------ãã COLOR 7,0ã FOR X = (7-WEEKDAY) TO (43-(7-WEEKDAY))+1ã IF COL=7 THENã COL = 1ã INCR ROWã ELSEã INCR COLã END IFã LOCATE (ROW*RGAP*SPACER),((COL+WINCOL)*CGAP*SPACER)-1 : PRINT DAYS(X);ã IF X>6 AND (X-6) <= MAXDAYS THENã CALPOS(X-6,1)=FIX(ROW*RGAP*SPACER)ã CALPOS(X-6,2)=FIX(((COL+WINCOL)*CGAP*SPACER)-1)ã END IFã NEXT Xãã IF BOX THENã GOSUB SHOWBOXã ELSEã GOSUB SHOWHILITESã END IFãã DOã IF NOT JUST.SHOW THEN ' Allows the calendar to show then exitã DO : LOOP UNTIL INSTATã K$=INKEY$ã ELSEã K$=CHR$(13)ã END IFãã SELECT CASE K$ã CASE =CHR$(27)ã FUNCTION=0ã EXIT FUNCTIONã CASE =CHR$(13)ã FUNCTION=PTRã EXIT FUNCTIONã CASE =CHR$(0,75)ã DECR PTRã IF PTR < 1 THEN PTR=MAXDAYSã CASE chr$(0,77)ã INCR PTRã IF PTR > MAXDAYS THEN PTR=1ã CASE =CHR$(0,72) 'DNã DECR PTR,7ã IF PTR < 1 THENã PTR=(MAXDAYS-1)+(PTR-MAXDAYS MOD 7)ã INCR PTR,7ã IF PTR > MAXDAYS THEN DECR PTR, 7ã END IFã CASE chr$(0,80) 'DNã INCR PTR,7ã IF PTR > MAXDAYS THEN PTR=(PTR MOD 7)+1ã IF PTR = 0 THEN PTR=7ã CASE ELSEã END SELECTãã IF BOX THENã GOSUB SHOWBOXã ELSEã GOSUB SHOWHILITESã END IFãã LOOPããSHOWHILITES:ã ' Highlight the day of the monthã COLOR 7,0ã LOCATE CALPOS(LASTPTR,1),CALPOS(LASTPTR,2)ã PRINT DAYS(LASTPTR+6);ãã COLOR 15,7ã LOCATE CALPOS(PTR,1),CALPOS(PTR,2),0ã PRINT DAYS(PTR+6);ã COLOR 7,0ã LASTPTR=PTRãRETURNããSHOWBOX:ã COLOR 0,0ã LOCATE CALPOS(LASTPTR,1)-1,CALPOS(LASTPTR,2)-1ã PRINT CHR$(218,196,196,191);ã LOCATE CALPOS(LASTPTR,1),CALPOS(LASTPTR,2)-1ã PRINT CHR$(179)+DAYS(LASTPTR+6)+CHR$(179);ã LOCATE CALPOS(LASTPTR,1)+1,CALPOS(LASTPTR,2)-1ã PRINT CHR$(192,196,196,217);ãã COLOR 7,0ã LOCATE CALPOS(LASTPTR,1),CALPOS(LASTPTR,2)ã PRINT DAYS(LASTPTR+6);ãã COLOR 15,7ã LOCATE CALPOS(PTR,1)-1,CALPOS(PTR,2)-1ã PRINT CHR$(218,196,196,191);ã LOCATE CALPOS(PTR,1),CALPOS(PTR,2)-1ã PRINT CHR$(179)+DAYS(PTR+6)+CHR$(179);ã LOCATE CALPOS(PTR,1)+1,CALPOS(PTR,2)-1ã PRINT CHR$(192,196,196,217);ã COLOR 7,0ã LASTPTR=PTRãRETURNãEND FUNCTIONãããã' ************************************************************************ã' ------------------------- Demo Screen Mombo-Jumbo ----------------------ã' ************************************************************************ããDISPLAY.DEMO:ããPRINT "This is a .SHELL. for a Calendar program. It takes the information that you"ãPRINT "provide, and converts it into one of two calendar types."ãPRINTãCOLOR 15,0ãPRINT " Press ENTER to toggle between calendars / ESC to end the demo."ãPRINT " Navigate using the LEFT, RIGHT, UP, and DOWN arrow keys"ãããDAY1=22 ' Assign days to displayãDAY2=4ããJUST.SHOW=(-1)ã NUL=MAKECALENDAR(13,3,28,2,DAY1,0) ' Show Calenders withoutã NUL=MAKECALENDAR(5,10,31,6,DAY2,1) ' allowing user interactionãJUST.SHOW=(1) ' Set Calendars for interactionãããTAG=1ãDOã SELECT CASE TAGã CASE 1ã COLOR 1,0ã LOCATE 11,10ã PRINT " << OVER HERE >> "ã Selected = MAKECALENDAR(13,3,28,2,DAY1,0)ã LOCATE 25,10ã TAG=2ã CASE 2ã COLOR 1,0ã LOCATE 11,10ã PRINT " << OVER HERE >> "ã Selected = MAKECALENDAR(5,10,31,6,DAY2,1)ã LOCATE 25,43ã TAG=1ã CASE ELSEã END SELECTãã IF Selected THENã PRINT "You selected day number";Selected;" ";ã IF TAG=1 THEN DAY2=SELECTED ELSE DAY1=SELECTEDãã ELSEã LOCATE 25,1ã PRINT "You pressed Escape! This DEMO is terminated"+STRING$(35,32);ã BEEPã ENDã END IFãLOOPãAndrew S. Gibson PERPETUAL CALENDAR V1.75 zapf_dingbat@juno.com 04-08-98 (23:37) QB, QBasic, PDS 251 9604 PERPCAL.BAS 'This perpetual calendar program was taken out of an old issueã'of TRS-80 MicroComputer News. I typed it in and adjusted it toã'work properly with PCs (text formatting problems..)ã'I believe all major basic languages can use this code.ã'Despite its size Auto Calendar *is* accurate even in leap years !ã'Also it 'sports' moving holidays !ã'Remeber if you have an Internet Connection or E-mail you can contactã'me at Zapf_DinBat@JUNO.COM. My real name is Andrew Gibson, Althoughã'I didn't write the code you'll probably find a workingã'true Perpetual Calendar very useful every day.ã' MM represents a month (numbers 1-12)ã' DD represents a day (numbers 1-31)ã' YY represents the year (only the last two digits i.e. 1/98)ã' YYYY the full year, i.e. 1/1998ã' Typing in a specific day such as 1/25/98 (or 1/25/1998) withã' cause the program to calculate the julian date.ã' The only valid separation character is the foward slash (/).ã'ã' Changes made by Wolf-Dieter (WDAPPELT@AOL.COM) to work all theã' rest of time. Thanks to him Easter works :>ã'******************************************************************************ã'ã' changes in LINE 850 set to REM, LINE 840 changed sequenceã' LINE 980 changed indexing name, LINE 1780 to 1870 total NEWã'ã'******************************************************************************ã'ã'ã10 DEFSNG A-Z: '<-Don't change ! / Auto Calendar Version 1.75ã20 'WIDTH 40, 25: 'uncomment this so you can strain your eyes :}ã30 CY$ = RIGHT$(DATE$, 4) ' EXTRACT CURRENT YEAR FROM SYSTEM CLOCKã40 yr$ = CY$ã50 DIM hol$(31)ã60 ed = 99: LM = 31ã70 PRINT : 'NEVER ALTER LINES 71-110ã71 MH$ = "0414040303230411033104180408032804160405032504130402032204100330041704070327"ã80 DY$ = "000031059090120151181212243273304334"ã90 MN$ = "JANUARY FEBRUARY MARCH APRIL MAY JUNE JULY AUGUST SEPTEMBEROCTOBER NOVEMBER DECEMBER"ã100 AD$ = "SUNDAY MONDAY TUESDAY WEDNESDAY THURSDAY FRIDAY SATURDAY"ã110 DZ$ = " SUN MON TUE WED THU FRI SAT "ã120 CLSã130 PRINT : PRINT : PRINTã140 PRINT TAB(11); "PERPETUAL CALENDAR"ã150 PRINT TAB(14); "VERSION 1.75": PRINTã160 PRINT TAB(5); " ENTER A DATE (YEARS 1753- )"ã170 PRINT TAB(6); "(FORMATS: MM/DD, MM/DD/YYYY,"ã180 PRINT TAB(6); " MM/DD/YY, MM/YYY, OR JUST MM)"ã190 PRINTã200 PRINT TAB(10); "ENTER DATE OR END"; : INPUT DT$ã210 LL = LEN(DT$)ã220 IF UCASE$(DT$) = "END" THEN WIDTH 80, 25: ENDã230 IF LL = 0 THEN 120ã240 P1 = INSTR(1, DT$, "/"): P2 = INSTR(P1 + 1, DT$, "/")ã250 IF P1 = 0 THEN mo = VAL(DT$): DA = 1: GOTO 320ã260 mo = VAL(LEFT$(DT$, P1 - 1))ã270 IF P2 = 0 THEN 310ã280 DA = VAL(MID$(DT$, P1 + 1, (P2 - 1) - P1))ã290 IF LL - P2 > 3 THEN yr$ = RIGHT$(DT$, 4) ELSE yr$ = STR$(VAL("19" + RIGHT$(DT$, 2)))ã300 GOTO 320ã310 IF LL - P1 > 3 THEN yr$ = RIGHT$(DT$, 4): DA = 1 ELSE yr$ = CY$: DA = VAL(RIGHT$(DT$, LL - P1))ã320 yr = VAL(yr$)ã330 IF LL < 5 AND yr$ = CY$ AND mo < 1 THEN yr = yr + 1: yr$ = LTRIM$(STR$(yr))ã340 IF yr < 1753 AND SW = 0 THEN GOSUB 1200ã350 IF mo > 12 OR mo < 1 THEN DA = 1: GOTO 1140ã360 IF DA < 1 THEN 1140ã370 LP = 0ã380 IF (yr / 100 - INT(yr / 100)) = 0 THEN I = INT(yr / 400) * 400 ELSE I = INT(yr / 4) * 4ã390 IF I = yr THEN LP = 1ã400 LD = 365 + LPã410 IF mo = 2 THEN 450ã420 IF mo = 4 OR mo = 6 OR mo = 9 OR mo = 11 THEN 480ã430 IF DA > 31 THEN yr$ = STR$(VAL("19" + STR$(DA)))ã440 LM = 31: GOTO 500ã450 LM = 28 + LPã460 IF DA > LM THEN 1140ã470 GOTO 500ã480 LM = 30ã490 IF DA > LM THEN 1140ã500 IF mo < 3 THEN LP = 0ã510 N = mo * 3ã520 JUL = VAL(MID$(DY$, N - 2, 3))ã530 JUL = JUL + DA + LPã540 N = mo * 9ã550 PM$ = MID$(MN$, N - 8, 9)ã560 DT = yr + INT((yr - 1) / 4) - INT((yr - 1701) / 100) + INT((yr - 1601) / 400) + JULã570 IF P1 = 0 OR (P2 = 0 AND LL > 5) THEN 710ã580 IF DA > 31 THEN 710ã590 DW = (DT / 7): WKDY = INT((DW - INT(DW)) * 7 + .5)ã600 O1 = WKDY * 10 + 1ã610 WKDY$ = MID$(AD$, O1, 10)ã620 CLS : PRINT : PRINT : PRINTã630 PRINT TAB(6); "THE DATE "; DT$; " = "; WKDY$ã640 IF LL > 5 THEN 650ã650 PRINT : JD$ = LTRIM$(yr$) + "." + LTRIM$(STR$(JUL))ã660 PRINT TAB(6); " THE JULIAN DATE = "; JD$ã670 PRINT : PRINT : PRINT TAB(6); "WOULD YOU LIKE TO SEE"ã680 PRINT TAB(6); "THE WHOLE MONTH? (Y OR N) "; : INPUT R$ã690 IF UCASE$(R$) = "Y" THEN 710ã700 IF UCASE$(R$) = "N" THEN 120 ELSE DT$ = R$: GOTO 210ã710 DD = 0: HS = 0ã720 MS = (DT - (DA - 1)) / 7ã730 d1 = INT((MS - INT(MS)) * 7 + .5)ã740 CLSã750 PRINT TAB(8); PM$; TAB(18); LTRIM$(yr$)ã760 PRINTã770 PRINT DZ$ã780 GOSUB 1010ã790 PL$ = ""ã800 FOR WK = 1 TO 7ã810 IF DD = d1 THEN dp = 1ã820 IF dp < 10 THEN dp$ = " " + STR$(dp) ELSE dp$ = " " + STR$(dp)ã830 IF dp = 0 THEN dp$ = " "ã840 IF hol$(dp) <> "" THEN dp$ = " **": HS = 1ã850 'IF hol$(dp) <> "" THEN dp$ = " " + dp$ã860 PL$ = PL$ + dp$ã870 DD = DD + 1ã880 IF dp <> 0 THEN dp = dp + 1ã890 IF dp > LM THEN dp = 0: dp$ = ""ã900 NEXT WKã910 PRINT PL$ã920 IF dp = 0 THEN 940ã930 GOTO 790ã940 PRINTã950 GOTO 1280ã970 DT$ = R$: GOTO 210ã980 IF hol$(eh) <> "" THEN hol$(ed) = "EASTER SUNDAY" + CHR$(13) + " & " + hol$(ed) ELSE hol$(ed) = "EASTER SUNDAY"ã990 ed = 99ã1000 RETURNã1010 'SET MONTHS HOLIDAYSã1020 GOSUB 1880ã1030 GOSUB 1480ã1040 RESTOREã1050 READ HDT$, hol$ã1060 IF HDT$ = "END" THEN RETURNã1070 MT = VAL(LEFT$(HDT$, 2))ã1080 IF LEN(HDT$) > 5 AND yr <> VAL(RIGHT$(HDT$, 4)) THEN 1050ã1090 IF MT <> mo THEN 1050ã1100 HDT$ = LEFT$(HDT$, 5)ã1110 DX = VAL(RIGHT$(HDT$, 2))ã1120 IF hol$(DX) = "" THEN hol$(DX) = hol$ ELSE hol$(DX) = hol$(DX) + CHR$(13) + " & " + hol$ã1130 GOTO 1050ã1140 CLS : LOCATE 10, 14: PRINT "INVALID DATE"ã1150 IF DA > LM THEN PRINT TAB(8); "FORMATS ARE:MM/YYYY OR MM/DD ": PRINT TAB(13); " - NOT MM/YY!"ã1160 S9 = 1ã1170 Period! = 2: GOSUB 1921ã1180 IF DA > LM AND S9 < 2 THEN S9 = S9 + 1: GOTO 1170ã1190 GOTO 120ã1200 'TOO OLDã1210 CLS : LOCATE 2, 12: PRINT "*** CAUTION ***"ã1220 PRINT : PRINT : PRINT ; "OUR PRESENT CALENDAR WAS ADOPTED IN 1753- ACCURACY FOR DATES EARLIER THAN 1753"ã1230 PRINT "MAY REQUIRE CONVERSION."ã1240 PRINT : PRINT TAB(1); "*(MOST DATES IN AMERICAN HISTORY HAVE ALREADY BEEN CONVERTED)"ã1250 PRINT : PRINT : PRINT TAB(3); "PRESS TO CONTINUE "; : INPUT R$ã1260 SW = 1ã1270 RETURNã1280 ' PRINT HOLIDAYSã1290 IF HS = 0 THEN 1460ã1300 PRINT " IMPORTANT DATE(S) IN "; PM$ã1310 PRINT STRING$(30, "*")ã1320 FOR H = 1 TO LMã1330 IF hol$(H) = "" THEN 1350ã1340 PRINT H; TAB(5); hol$(H)ã1350 NEXT Hã1360 PRINT "";ã1370 R$ = "": PRINT : PRINT "ENTER DATE OR FOR NEXT MONTH "; : PRINTã1380 PRINT "NEXT DATE OR END "; : INPUT R$ã1390 X = 3ã1400 FOR I = 1 TO X: PRINT : NEXTã1410 IF R$ = "" THEN DT$ = STR$(VAL(DT$) + 1): mo = mo + 1ã1420 IF mo = 13 THEN mo = 1ã1430 IF VAL(DT$) = 13 THEN DT$ = STR$(1): yr$ = STR$((VAL(yr$) + 1))ã1440 IF R$ = "" THEN GOTO 210ã1450 DT$ = R$: GOTO 210ã1460 PRINT " NO HOLIDAYS, BIRTHDAYS, OR ANYTHING AT ALL IN "; PM$ã1470 GOTO 1360ã1480 'MOVABLE HOLIDAYSã1490 ON mo GOSUB 1500, 1510, 1780, 1780, 1540, 1630, 1500, 1500, 1670, 1750, 1700, 1500ã1500 RETURNã1510 IF d1 < 2 THEN HX = 16 - d1 ELSE HX = 23 - d1ã1520 hol$(HX) = "WASHINGTON'S BIRTHDAY"ã1530 RETURNã1540 HX = 15 - d1ã1550 IF d1 = 0 THEN HX = 8ã1560 hol$(HX) = "MOTHER'S DAY"ã1570 HX = 30 - d1ã1580 IF d1 = 6 THEN HX = 31ã1590 hol$(HX) = "MEMORIAL DAY **"ã1600 HX = 21 - d1ã1610 hol$(HX) = "ARMED FORCES DAY"ã1620 RETURNã1630 HX = 22 - d1ã1640 IF d1 = 0 THEN HX = 15ã1650 hol$(HX) = "FATHER'S DAY"ã1660 RETURNã1670 IF d1 < 2 THEN HX = 2 - d1 ELSE HX = 9 - d1ã1680 hol$(HX) = "LABOR DAY **"ã1690 RETURNã1700 IF d1 < 2 THEN HX = 3 - d1 ELSE HX = 10 - d1ã1710 hol$(HX) = "ELECTION DAY"ã1720 IF d1 > 4 THEN HX = 33 - d1 ELSE HX = 26 - d1ã1730 hol$(HX) = "THANKSGIVING DAY **"ã1740 RETURNã1750 IF d1 < 2 THEN HX = 9 - d1 ELSE HX = 16 - d1ã1760 hol$(HX) = "COLUMBUS DAY"ã1770 RETURNã1780 'EASTER SUNDAYã' yr must be 1583 to 4099ã1790 a = yr \ 100: b = yr MOD 19ã' calculate PFM dateã1800 c = (a - 15) \ 2 + (a > 26) + (a > 38) + 202 - 11 * bã1805 c = c + ((a = 21) OR (a = 24) OR (a = 25) OR (a = 33) OR (a = 36) OR (a = 37))ã1810 c = c MOD 30ã1815 tA = c + (c = 29) + (c = 28 AND b > 10) + 21 ' table A result (21=M21 to 49=A18)ã' find the next Sundayã1820 tB = (tA - 19) MOD 7 ' table B resultã1825 c = (40 - a) MOD 4ã1830 tC = c - (c > 1) - (c = 3) ' table C resultã1835 c = yr MOD 100ã1840 tD = (c + c \ 4) MOD 7 ' table D resultã1845 tE = ((20 - tB - tC - tD) MOD 7) + 1 ' table E resultã' return the dateã1850 d = tA + tE: IF d > 31 THEN d = d - 31: m = 4 ELSE m = 3ã1860 IF m = mo THEN ed = d: GOSUB 980: ELSE ed = 0ã1870 RETURNã1880 ' CLEAR HOLIDAYSã1890 FOR IX = 1 TO 31ã1900 hol$(IX) = ""ã1910 NEXTã1920 RETURNã1921 BEGIN! = TIMER 'Delayã1922 DO UNTIL (TIMER - BEGIN! > Period!) OR (TIMER - BEGIN! < 0)ã1923 LOOPã1924 RETURNã1930 'add any fixed day holidays here.ã1940 DATA 01/01, NEW YEARS DAY **ã1941 DATA 02/12, LINCOLN'S BIRTHDAYã1942 DATA 02/14, VALENTINE'S DAYã1943 DATA 03/17, ST. PATRICK'S DAYã1944 DATA 03/20, FIRST DAY OF SPRINGã1950 DATA 04/15, INCOME TAXES DUE !!!ã1951 DATA 06/14, FLAG DAYã1952 DATA 06/21, FIRST DAY OF SUMMERã1960 DATA 07/04, INDEPENDENCE DAYã1961 DATA 09/22, FIRST DAY OF AUTUMNã2020 DATA 10/31, HALLOWEENã2030 DATA 11/11, VETERAN'S DAYã2070 DATA 12/07, PEARL HABOR DAYã2080 DATA 12/21, FIRST DAY OF WINTERã2081 DATA 12/25, CHRISTMAS DAY **ã ' DON'T change then following line at all !ã2090 DATA END, ***ãDon Schullian MILLISECOND DELAY FOR PB d83@ath.forthnet.gr 06-24-98 (05:10) Text, PB 59 1686 MDELAY.BAS >>>>>>>>>>>>>>>> !!WARNING!! <<<<<<<<<<<<<<<<<<ããThis atricle contains a shameless, commercial plug.ãã >>>>>>>>>>>>>>>> !!WARNING!! <<<<<<<<<<<<<<<<<<ããHi,ãã Here's one for you that seems to pop up now and agian. It isãjust one of the hundreds of little goodies you can find in myãlibrary "Nutz 'n Boltz".ãã MicroDelay works on 1/1000ths of a second (997 to be exact).ãTo delay the program by 1/3 of a second CALL MilliDelay( 333)ãTo delay the program by 1 full second CALL MilliDelay(1000)ããThere are 2 versions of the same routine below. One uses PowerBASIC'sãREG/CALL INTERRUPT the other uses ASM code. You'll note that the PBãversion costs 112 bytes more code than the ASM version. That is anãadditional 25% to do the _SAME_ job.ããNOTE: This puppy may not work on XT's but should be OK for AT's andã above.ããHave fun,ããDonãã'-------------------------------------------------------------ã'---------- start code -------------------------------------ã'-------------------------------------------------------------ãã$if 1ããSUB MilliDelay( BYVAL Millis% ) LOCAL PUBLIC ' CODE 448 BYTESã LOCAL Msec&ãã Msec& = ( Millis% * 1000 )ã REG 1, &h8600ã REG 3, ( Msec& \ 65536 )ã REG 4, ( Msec& AND 65535 )ã CALL INTERRUPT &h15ããEND SUBãã$elseããSUB MilliDelay( BYVAL Millis% ) LOCAL PUBLIC ' CODE 336 BYTESãã ! mov ax,1000 ;ã ! mul Millis% ; DX:AX = Microsã ! mov cx,dx ;ã ! mov dx,ax ; CX:DX = Microsã ! mov ax,&h8600 ; Wait Intervalã ! int &h15 ; BIOS system servicesããEND SUBãã$endifãPetter Holmberg WEEK OF THE DAY CALCULATOR petter.holmberg@usa.net 06-28-98 (14:26) QB, QBasic, PDS 57 1491 DAY.BAS ' Week of the day calculator by Petter Holmberg, -98:ããCLSãPRINT "Have you forgotten what day of the week you were born? Do you want to know what"ãPRINT "day of the week Jan. 1, 2000 will be? Or have you even forgotten what day it is"ãPRINT "today? Don't worry! This program can help you."ãPRINTããDOã INPUT "Enter a date, (yy,mm,dd): ", year%, month%, date%ã PRINTãã SELECT CASE month%ã CASE 1: monthnumber% = 0ã CASE 2: monthnumber% = 3ã CASE 3: monthnumber% = 3ã CASE 4: monthnumber% = 6ã CASE 5: monthnumber% = 1ã CASE 6: monthnumber% = 4ã CASE 7: monthnumber% = 6ã CASE 8: monthnumber% = 2ã CASE 9: monthnumber% = 5ã CASE 10: monthnumber% = 0ã CASE 11: monthnumber% = 3ã CASE 12: monthnumber% = 5ã END SELECTãã IF month% = 1 OR month% = 2 THENã IF year% <> 0 THENã IF year% \ 4 = year% / 4 THEN monthnumber% = monthnumber% - 1ã END IFã END IFãã day% = year% + year% \ 4 + date% + monthnumber%ã day% = day% MOD 7ãã SELECT CASE day%ã CASE 0: day$ = "Sunday"ã CASE 1: day$ = "Monday"ã CASE 2: day$ = "Tuesday"ã CASE 3: day$ = "Wednesday"ã CASE 4: day$ = "Thursday"ã CASE 5: day$ = "Friday"ã CASE 6: day$ = "Saturday"ã END SELECTãã PRINT "The date you entered was/is/will be a "; day$; "."ã PRINTã PRINT "Another date (Y/N)?"ã PRINTãã DOã kbd$ = UCASE$(INKEY$)ã LOOP UNTIL kbd$ = "Y" OR kbd$ = "N"ãã IF kbd$ = "N" THEN ENDãLOOPãDieter Folger ON SCREEN DIGITAL CLOCK folger@bamberg.baynet.de 07-24-98 (16:19) PB 46 1675 DCLOCK.BAS '-----------------------------------------------ã' DCLOCK.BAS for Power Basicã' Shows system time as a digital clockã' Can be used as screen saverã' Freeware (c) by Dieter Folgerã'-----------------------------------------------ã DEFINT A-Z: SCREEN 12ã x = 200: y = 200 'upper left position of displayã C(0) = 0: C(1) = 3'background black, segments greenã FOR i = 0 TO 9: READ Segment(i): NEXTã FOR i = 1 TO 7: READ x(i), y(i): NEXTã FOR i = 1 TO 3: READ xp(i), yp(i): NEXTã Digit$(1) = "F2 D11 G2 H2 U11 E2 B D1 P" 'segment verticalã Digit$(0) = "E2 R14 F2 G2 L14 H2 B R1 P" 'segment diagonalã DOã xt = 0ã FOR i = 1 TO 6ã T = VAL(MID$(REMOVE$(TIME$, ":"), i, 1))ã FOR j = 1 TO 7 'draw segmentsã C$ = STR$(C(1)): Segm$ = Digit$(1)ã IF j MOD 2 = 0 THEN Segm$ = Digit$(0)ã IF BIT(Segment(T), j - 1) = 0 THEN C$ = STR$(C(0))ã DRAW "BM"+STR$(x(j)+x+xt)+","+STR$(y(j)+y)ã DRAW "C" + C$ + Segm$ + C$ + "," + C$ã NEXTã INCR xt, 32ã IF i MOD 2 = 0 THEN INCR xt, 15ã NEXTã FOR i = 1 TO 3 'dotsã CIRCLE (xp(i) + x, yp(i) + y), 3, C(1)ã PAINT (xp(i) + x + 1, yp(i) + y + 1), C(1)ã NEXTã LOOP WHILE INKEY$ = ""ã ENDã' s6 Example of number 4:ã' ÄÄÄÄ 1 0 0 1 1 0 1 = 77 decimalã' s7³ s4 ³s5 s1 s2 s3 s4 s5 s6 s7ã' ÄÄÄÄã' s3³ s2 ³s1ã' ÄÄÄ-ã' 0 1 2 3 4 5 6 7 8 9 bitmaps of numbersãDATA 119,68,62,110,77,107,123,70,127,111ã'position of segments:ãDATA 9,11,10,10,29,11,10,27,9,28,10,44,29,28ã'position of dots:ãDATA 153,42,75,20,76,38ãDieter Folger PB CALENDAR BOX folger@bamberg.baynet.de 09-10-98 (19:26) PB 120 4382 CALENDAR.BAS '---------------------------------------------------'ã ' CALENDAR.BAS for Power Basic 'ã ' Freeware (c) 1998 by Dieter Folger 'ã ' Calendar in a box showing current month and 'ã ' day (blinking) 'ã ' Use arrows right, left, up, down to go forth 'ã ' and back in months and years 'ã '---------------------------------------------------'ã DEFINT A - Zã 'Data for days in a month and months names:ã DATA 31, "January", 28, "February", 31, "March"ã DATA 30, "April", 31, "May", 30, "June", 31, "July"ã DATA 31, "August", 30, "September", 31, "October"ã DATA 30, "November", 31, "December"ã Day$="Mo Tu We Th Fr Sa Su"ã FOR i = 1 TO 12 : READ Dm(i), Month$(i) : NEXT 'read DATAã ' get current date ã d$ = Date$ : m = VAL(Left$(d$, 2)) : y = VAL(MID$(d$, 7, 4))ã Cm = m : Cy = y : Dd = VAL(MID$(d$, 4, 2))ã SaveScreen Tmp$ 'save current screenã 'make box for calendar:ã VIEW TEXT (10,2)-(33,11)ã COLOR 14,3ã PRINT "É";STRING$(22,"Í");"»";ã LOCATE CSRLIN,1ã FOR i = 1 TO 8ã PRINT "º";SPACE$(22);"º";ã NEXTã PRINT "È";STRING$(22,"Í");"¼";ã COLOR 0,3ã LOCATE 10,9: PRINT " ";CHR$(24,25,26,27);"Esc ";ã ã DO ' main loopã IF y < 1583 THEN y = 1583 : m = 1 ' start of Gregorian calendarã IF y > 9999 THEN y = 9999 : m = 12 ' nearly until the end of timeã LOCATE 1,10: PRINT STR$(Y) + " ";ã LOCATE 3,3: PRINT Day$ã Dm(2) = 28 ' February has normally 28 daysã IF y MOD 4 = 0 THEN Dm(2) = 29 'except in leap yearsã 'centuries are only leap years when they canã 'be divided by 400 (i.e. 1900 was not a leap year, 2000 is one):ã IF y MOD 100 = 0 AND y MOD 400 <> 0 then Dm(2) = 28ã d = 1 : mo = m : yy = yã 'Calculate first weekday of current month of yearã '(algorithm by Carl Friedrich Gauss 1777-1855):ã IF mo < 3 THENã INCR mo, 10 : DECR yyã ELSEã DECR mo, 2ã END IFã Cent = yy \ 100 : yr = yy MOD 100ã fd = ((((26 * mo - 2) \ 10) + d + yr + (yr \ 4) _ã + (Cent \ 4) - (2 * Cent)) MOD 7) - 1ã IF fd < 0 then fd = fd + 7ã 'show result in calendar boxã LOCATE 2,3ã PRINT Month$(m) + SPACE$(20 - LEN(Month$(m)))ã ro = 4 : co = 1 : s$ = ""ã IF fd < 7 THEN FOR i = 0 TO fd - 1 : s$ = s$ + " " : NEXTã FOR i = 1 TO dm (m)ã c$ = STR$(i)ã IF LEN(s$) = 21 THEN LOCATE Ro, 2: PRINT s$: s$ = "" : INCR roã IF i < 10 then s$ = s$ + " " + c$ ELSE s$ = s$ + c$ã IF i = dd THEN cRow = ro : cCol = LEN(s$)ã NEXTã IF LEN(s$) THEN LOCATE ro,2 : Print s$; SPACE$(21 - LEN(s$));ã IF ro < 9 THEN LOCATE 9,2 : Print SPACE$(21);ã IF y = cy AND m = cm THENã COLOR 16,3 ' current day should blinkã LOCATE cRow, Col + cColã PRINT RIGHT$(" "+STR$(Dd),2); : COLOR 0,3ã END IFã DO: Kb$ = INKEY$ : LOOP UNTIL Kb$ <> ""ã IF LEN (Kb$) = 2 THEN Kb$ = MID$ (KB$, 2)ã SELECT CASE Kb$ ' Keyboard functions:ã CASE CHR$ (&H50) ' cursor downã INCR y ' next yearã CASE CHR$ (&H48) ' cursor upã DECR y ' last yearã CASE CHR$ (&H4B) ' cursor leftã DECR m ' last monthã IF m = 0 THEN m = 12 : DECR yã CASE CHR$ (&H4D) ' cursor rightã INCR m ' next monthã IF m = 13 THEN m = 1 : INCR yã CASE CHR$(27) ' ESC keyã EXIT LOOP ' end programã END SELECTã LOOP ' end of main loopã VIEW TEXT (1,1) - (80,24)ã RestoreScreen Tmp$ 'restore screen againãENDã'----------------------------------------------------------------------------ãSUB SaveScreen (Scrn$)ã'----------------------------------------------------------------------------ã SHARED py,pxã py = CSRLIN: px = POS(0)ã IF (PbvScrnCard AND 1) = 0 THENã Address = &HB800 ã ELSEã Address = &HB000 ã END IFã DEF SEG = Address ã Scrn$ = PEEK$(0,4000)ã DEF SEGãEND SUBã'----------------------------------------------------------------------------ãSUB RestoreScreen (Scrn$)ã'----------------------------------------------------------------------------ã SHARED py, pxã IF (PbvScrnCard AND 1) = 0 THENã Address = &HB800 ã ELSEã Address = &HB000 ã END IFã DEF SEG = Addressã POKE$ 0, Scrn$ã DEF SEGã LOCATE py, px, 1ãEND SUBãAndrew S. Gibson VARIOUS CLOCK DISPLAY PROGRAMS zapf_dingbat@juno.com 09-15-98 (00:10) QB, QBasic, PDS 370 24521 CLOCKS.BAS DEFINT A-Z:DIM SHARED K,S,B&,Z&:V1 'Created by PostIt! 7.2ãSUB V1:OPEN "O",1,"CLOCKS.ZIP",4^6:Z&=18143:?STRING$(50,177);ãU"%up()%9%'%d-%H(%SJ?Q,d')).%%h.%%%/%%%%fh%qthp%SgfxMt%:>][k9vk]=ãU"N1].G*3JS=b4l.R=0n]>9&l:AEA3gMxK/GEr=_j]LBqqyx6bFu%lNQ;t)j.:FGFãU"b$c5Hg]AQ(,mgM'ap/Y'?D?J^pglB-u*2[+Qq\;AQy=hW9)i'PQ>nH]=6QrkYN:ãU"$9a9;b;JoH19xmBi)*(lQS)(sp%08m#)KãU"X)fkbX+'06O_/[W+XNE=S$n?B7iW/B7$U6T1*5[*J_y;?nxx(2I8EmVA[h\?,0?ãU"hG7iGcZHXk-Q[$++ciO:e\EP:O?om?TvK,k/^$B(0'D)/YBC-349\&*WB\A2D#QãU".EOOrJQg4VYHcx2I4kDIoX#KYAS,&.V,nv)55_2JV1Qn'-/XC\DãU"+I_k-\oeJq5Fj(tobNrSs4Y0-&hF[&:]8Cw<4jN4d%?Puk0HC]U7xdiUHVHrdaQãU"5&f>)ygUTw+'OL0lmi',Rh%5WzLb?Hzx;p6b5K)yyA$RbdAefa7#2Dv?\]ãU"+B'XL$y/1NKtzuFB3z&T)an)N6%]S$dIR(Vo5_B0OwB;=aoP8%;H;Y^?,(6n[P6RtQG40-RKm9&RGPl9WWMQG[>q%W++CWuf3WNãU"u*fauIKh.e56cUT$pF+'9_P^KK1_741s+EwIT_(oKXDO$f7iEnT5>cqsMC06Y+CãU"4rTarRq6958=GIl(7k2xqh9s=oB>^<]JtT6_F/gmH7Uhv&ET]C>M2f.G92PGY&[ãU"peVNT2mK3sF0%V9o\9ktf($hTX;X(^-H-Sne]>g_p7$8H6PG(=/3C:Sa];UBKl+ãU"ZT]n9i0[/b=b3tM5oDt>**7OctTP6Vs/(JE_T)h]^by(Z;W[E(i;*c3a_N[O(NIãU"yiK5/4zS]YP+bgKd;NkM.c$,8w4/jQak#1pGoN9=.=tqzJE,I*[s[e4;U.)*/vvãU"K$)6(&9QF*UN7A%[yag+;wC#o'=_6y)y9D66u$l&_FQpB>11XE7K9e*uwoTxW9_ãU"Xv5Y1g98dBsT%up()%9%'%d-%A(%SJJv5;j6/%%%8B%%%/%%%%ih%qthp%SgfxVãU"t(TABTk7LV&dwp_Zti])iu.5AcRJj.Q-O<+#5)%A<^T*I5.Y'%h%0=h)%tkHhTbãU"RNDOs;+LJ(j$EkcVPL_Qm0tlB,pd-ZJ)KãU"J%[i\3K'Nc/WSGD'R#)1d,B0Fp_KcWY_FqI/QsLm5n#d,UDN#e2CG[r9q$=.,dRãU"3Y\SRf=(qmbc/I15hrBe/)0ESQYorWaxCSc;-Cip&-:hWw=l.:X[h,sctHT$^;sãU"53$6uZbkEaIb.wsX12*FQ)?f(fCqb]3+ns(Y?VYwF,WRn5ZPE_A6v9HuF(#?HID<%6>o4i7ãU"%KgcA7XAdrhaQpTC[o/e'\QS<ãU"*4M)NW:)QaX9l'w25\*4TI?UF9b\8C.H5;K>Y;Fqk#bd#1H0Dw2't.$:Qi_/*i,ãU"50I3[-u8Nlq;9-$i[M+R[(f7l?;YS[g_vXt]asF65ez4#)=L1Co69ERER=;9uwHãU"fbluNopqmnF%8*Th5'ZovYeu8J[?bG#H^By3':k0=zVow]elgr(7_98ãU"OYMg']R_Cr^C?^'KEGWX,8<1H;q>+D/1.41l=]kJM&OeEcF1r+szTrXMR%ewGq5)erQ(Bep6-Id8pqR[OoAeqz0n$jãU"(3]6uEk<9ZpLmN%Z1Yf$.J]$;jq&DZqzA:eNWRX'WdElL/UW^jbhT5o/)\JotHKãU"3wRsEF^]KYFO_HN$i=pmog)s$k6Jv2047'vo8/w^e_?-COKn7S4?G3Yf?q,HN:CãU">*ScQ5OK?rr'->2+??nAL)4bKmHRQn+kbxK1xG72A]4g^jcNB&fkERmXhM-Kd]fãU"9e'EW$Oi/gA^Lumh<>'>Dq=\kLZU8?Xk0&kxfW.$?.EmWUJPf5\aH&ky?JS#dYXJh83&novX:GnEje+ID_>R8A\rQYãU"R^Lnoio8bNt:nKBiG'IAVsV4Z#hU;jekr.wZSL+/t34mC+)w4UOs7PPwA]*NTlaãU"#/>J*d-0V1Vvlf?vCveb?r\+MiVmJ3P4Mjm[3.LrbVo=wUHBJny)m,*rwORs,$6ãU"3;tv4hi9&AlwKk4Bi/cSfj_HEH9E49=g+pf)iTn1poVW9ZU1Y7iM$z]NZP]9[v=ãU",NBrQ2=^?tf2()P9(V)4[**2_IfD%w&A0W6lDmdf+Z?,H8pq?S+#>_&/M.3dy:dãU"jy#O1Hky&/]My8qq=RC_^Q3a')RiR#)ITF:&(&*^<1TXYM-\r5ReK6fqzoãU"R1S'TM':_2dT\]<3?HãU"IbcqUL5?:QY*0Y2iJa7CEUy&0wq][9m;??pUbS0k6kVa1BtPiiMs$C^3B'Ssf?PãU"qe:q4(%QTFbz_*XfTM[G$JSM<&o(dprvDiY_vnM*G81ob+QRUUMaCfsIcr^24'hãU"8lSMrF)rm/8?RR4k\n)R/b_MZD%k=9CmF45eK1&ZZãU"_l1t&9lCX1OTw/,)g,zv9ocXEC:N?(%lpc/f>zYh.ChJK[>bYwXZE6(QDJNJ[0WãU"X9A:sh[AQ0179G>q.EJ/ORt?+5+9[lBO_oNm*Nf*W?'I?'D,eqADrDI/PeYQXFzãU"GPL8W)M&EAf]N'MD$5O],U=:q1Ag41VIy7$-HP^y*Fpbp+XXQZ;*Bs($,&vnUO^ãU"6to_E9M>AOWF2f%1N%v2^^;?[)68u$=Lpp(o=OXpa6QWh&-&-$?WM:+yYcscy[#ãU",nR$Slc21tTZdC%uHer3rtUVrn9r7XNiaLPx[VxVdlPQY[LmeDH-^t.KMVY2EgsãU"o\kYM;Owbe2c45WBL+$5NoRT7jb3.A%8C49O^,:aI#7Ik=,xN(U+Z=^yo0plj1#ãU"FDh,?&6d?/NwS6>f8;d)5=a.oYRz77J5;qqY^u[QLfL4D#R\uVCwK?H+vhaEi9:ãU"\3-0DYIPu#<%,jNJT+)MuE[^*HEMRhSWL5^-rtqOeaWP_kUE6ta1fK,=*+p+_IZãU"#Wg,[*&$o8o=Gnr*>u?Ju3Y=g9ff[KyPgR+-+I%xui+p3A;KVy53YqK#;^IFdx%ãU"wiFDd#pxbgah6<,.DykQ(/MK=D%Tg4zZyaGxj$z51=A>8q-On#A-qD)er#N'sT^ãU"xo]6Eb%jNu.UmilzevxN;+M\_x-%BKD9o,Zi11'HJlRJ>r/wNIFDpg[t,_hl_r8ãU"R^0E2C#mx3KWFumdFMN(Mw,:AVG#5JNOoJ/V?KTB&7Fg_X]RNSMdMsHSu+eãU"MD.oceãU"Z4[pfR/nrI4&>:,#xDu%p()9%%'%-ãU"7%z*S:Jp3a)gr5%(%5w%%%1%%%%qhi%hqth%pSgfOxf+JGBSoe$xnO79<.^..UFãU"]%.d7ALB,g-j-25SwqAlu,dJh2-#;7JXX5hMKpMNB3n',SfIZG*4VdX=3tkNãU"XHCzY.cL4GSz-:n_QO;Ckei:C0r0OY3c-$i>);p>2\s1'RM/),[p3\N6-loo*,[&pPmi_WK0<;&N+T5?e,0+;f#SduOom/S<*occ,FuqiM*-TISHH,r.rpE9\vtDpyI$&ãU"PLqrL?Uh.^9^2\I(cq*0,>fuV+\?J8IOb''k.2Ye+PlR,::j(B=YQ6.i9E0BJ4AãU"&0])3g''aR(0e$ml7eL2BTKZOG-42eH+a=fI0\#1y*QPJ^$*la^Pkoe_rOSR:LrãU".;#32E'\5Sso1>zãU")HgbyZoTu*VT&B;0;]#R,NE4e#]Y7*%n/3qVBH$NTc:65omaJTãU"rWv.j&B)=EQ]B)]ãU"wB/S9D)(]S&0mzJm.+A<*op2_l'$76.:)lZO]pz5KRqVun3>;Fu8W4APu\tpj8IãU"dfpqDk,H#4nC&HH1IGTo%KbAT?6t_s\^]yq=P&%3doUUZ1ESwdiRmaew&w(p%3LãU"(^iB5uL0?]]ILw'ySvIn%LQ[UoãU"dtK+gH>AAPFVn>BRdVXm3X#Eh6hdi.2iYDFa$Wy8QDZxw;6?M+StFDbNgV4H&UnãU"nW=fcJ]nE]>gaYs4(hZT3)IT;[30Aj>ZBW;0,rFBqhfl;\b6;ll6jLãU"64mk_oU83dn^GNXsm/]JJjf:pILi[;yH_1m(ODElY8Kjwtd70WZ^O1i)RkH.S'DãU"seH7.pQta21e1x\*=2k.KlOu-=J0ãU"MUXLUUz[O?0(,oMOjpBwm:g.esTaEo9s])G]J\47Njh(dmv*?ERIc+jTCdwuge7ãU"d3:F[VER0J60?zgCF4uhoWw\iBuw8M[iqE*B0:iho.vh_yqO'Caf?2L3/8Lljs(.L%kQCfGY7OeãU"b=#^9fM.xyqKm,wn1/W=ahwsYx4K?iY#f'8F#Ytx(=cO+NLay(mga7GT>iWg=KWãU"sh_4W5lW\Se3J2LOBf/cCEDY2rBb+QXhKKvBDJN*K$#Mm1[6?,ju[>-U\;:,M=)ãU"_Uea^:p>f,T>g5P2?-R_?vdKK:'YROpz9IA1;f8vUK5B1^kia$4>OFZM75(2Z$^ãU"I0p:k>=]BXc)rVDA/g9>kIMGkvHhb2mgZL5joo_LU[K,l7mPqTzH$R/xHVlgNYX?<#pQRd6jY>\5)(QWZ2K$z)ãU"x$ãU"leDSK:*H_9N)tYnTxnd^$m4cXPDvd7^VtCHIPBo)JVxn)RbJZ7tnm5ztRRs.XZ.ãU"_mv%H=2b#CE61&.WwMH+utPaFSFk+ktH;(J8;3omtUvf2FBveVQm55bKf-^j=aHãU"/D1d:IC3SA)7dBsIWUlIgbbM1t;:xQ6Ss]for^$Y]?^Dh%YM&=jdXnV?JBptIGr:LAãU"Hi7(\E31IxZJiX]W#=5;pTa'?Ss/SDkk'L8l3ml9dWaF(=-rTBsb>2oWbZ&GUoAãU"?V[+HI:iW^L]W1y'foh6L,H-FRk+5PgdeI\AeAf15pcU%YYpb*nep1*3CU=NL*TkDbqc*)tgNB=^[rnBi-yGPyfTZ0pz[C#*0'KpãU"10iJ.UF/PuD#YKk?:eNm)1Hc#qR\]?x-U$li_Ck?B3oUMcB2V]L*0aS3O5XL'LaãU"o.q+\8M'/[7/7T(U0.AE1h9A=Cka#K1JcWlV)t7zg\rxdka=NVmsiA$Eerh+:nYãU"rfrD,qN9bejs%F>cU2VB:fS$KZ#T\#Gv#d$ZQoe-XNfQ;Sl#iFqi,,,)]P:KqqxãU"5[0,,/Ge&BMM]qGY0_T.Tj=ME;D1Mo+%V_*bi?lKgNSfGtC'=ZTX?0h%-#m=3[$ãU"B$o=x$#2t]ahrlchE[kw[B(]HZYCl]OB)15dMW6*SQãU"PBP)OG%g'k6O9^-QQK;;+=K%PHB?3];lhhUA&pJ1,,x#ki.19u7RZGu\+dMW1E1ãU"'g-L:?MeeNZ2\C/tnLTi_gF7m8EkK0n_e,%l_=Tw2aE&dKDMV\NL,K=a:1[n(NJãU"5QTT06FA8P65F9t;g'scqAxsXnExs0wmfs5d$sd3yF_o,2uLF]w<+-QPfkn,_*/ãU"6N$;js*#VWmi\EJ(ivms:6EqjUA0>oB?;qCo.(M:)8doxGXef)/]<+RãU"u9U?iH=J=3ZvauK(e;GWZU\O-cFtV90P#,6iW]c&%t*d0:iCq:cO_0N$A7tV),cãU"QjJ>&0%6Z\j4f4BL,F3)?V\dfToIYGgK?CsãU"M4X\s,%iQas0OK]%FuDVIEcK80UMCf1XnZkUoRR5'??Yc.>b2C-70H5ãU"uGsk+$v%nq$D%5%DfA]dJ$42,ux6kk0k)2q,WZiC$]vEu(Ya7H1F]LH&Uq9^>,qãU"W7H(&E9S11&?[Bu]^_gr\TD9d=>\'M+mc.hHi;&J?aL-Wiq]rl81VYQ8j7oI+ACãU"W=WmPC/ahJ$Mu(hbWT[rOs=v9oFKG[B_:4F?\-t(Zw5B[n<(p9%K5OFi>6I[9KCãU"NhgCR\Q9EBh\ong'?)Wj$jJ%m'Rf.8A=Q5LH8EE6NT1SzLNDSãU"W/Z#TT]%r(wOcb9]gJD;1lMT3ubY=+3e&u(xiPkziy;1^c)',bsnx*t->=kãU"ulk+T0&o8N;6v%dQV*,Y?XdPR9HK:P6te:ico2]n>W%L*SKgWe-]C4#HVWV)3R>ãU"CXb4mAS2LkQ*IFsbW%l_g8SiKZu1NSb)Q:<:2:[E9I/n#h=SHLseWvUAWWuifjyPoR5UeeDKhq/FG^ãU"GCNA>c:RUVMEX<3p3K%7ic?*t8IkKmVk1]h0K:%=+=t\H4k?KcZr.1/UJBAE2m^ãU"yqBGAO1-Dc)ebk,5BYd6Ukk=6CpR%-F?*b]=Wfn&in7a=e_JEuS,^6Yq>ãU"1VN^&d6h3O+tRUKP#rUHDc#Q-$6$)K;c?LH7?g/l0dPG*=n^=(nEW>1byC6t1ORãU"xa7Bx%?>Aict*#rzip3+\bk?-yA2P:M,hk'2](%maB#uQ^A9is8()^%E^_G6t#&ãU"r:n3lUrF9,Xnn36YTv(-CNo36Y4v(,Y>p3Y-dbG2Aak(&7bBu0F**c1B;_0$/I_ãU"Q7]0/b;]soO6+0XjdH)YL(G#Gun'p[/r.T^Lc9Uu=.Ba#k$4]VD+(5Hsq;tZUCMãU"/3&Z(]iIAz7bK;7uWtYAaãU"*d^)qH*)$.AzP/cJHG3].8u?d$Y=u9Y?[_UWYJd_F;L$BU\)BcBT6PAkT1E9Sz)ãU"c6$-x>9a/0oJ=.1HnPOPeJPZ\MQAvnz7h1t3GSn$,=;oAãU"CFib_%eDKJt,8=WVoD/1KUMvZrkbwU/45e1Q\P\FQIksq+GZfAINl[cjC-.TL6UãU"+F*5_j#a\;Q*k%%Z3/LoQ>ãU"VDxI\2r^aK5$(oJGfVF^6gGPHR[Z$G?Vwi/$sH>9igQAb9N)k^8WSA7hvqkdoZ6ãU"51];b>zYx%%up()%9%'%[-%[-ISJ#H0x4P;#%%;U%%%.%%%%wq%hqpS[gfx.),JãU"x#UnaxnF-7hhoj(GYWdInR*Rh$Q)3j#&V-_Pm;\Z45KI+TTl=.sZ?q%,6Ttz'zrãU"nweeSyon[9HV:muV8E%gl%%Oi(y*(5'x=]Y4,ZLTGsQKtiX)R5,G]LZlTJ/rCIlãU"bV,-)(cw8XOodC,bNuYLl/c<[utH*AhulJLo*OzGDq[ULR$ii:r^h$tl*j;U#=sãU"?e>Y24Pb*tVvcZDR\?YE#7]tUPXk6[F-NW?MBnquV_rGY+GrNu59=mB:ãU">]>#CgLc8^z^hE=ULYVJY8VVd^j/-L\8kr7WdB0%.N:;D>R\W0D$Ez_hbM7#EZoR,ãU"Nb28s_Ee#Umu*jYW^yJw)N:73CYc^569HOqv>(FPz0vOlxauwwbeDcm^H>+?;4UãU"70\$DuVv=zR(o?W6e1mCqJx/6ckzrFA*gUWRe[sKPXQ,?CC+MrK5yn,1ljlFa88ãU"OQZc4TR0o'F1D#26ooXBh\>YuG$6D-RrL\yV_tZvB+[\b<>BPFXlkunRJ:?XF$slhaqD7Sd6ZFBRV<3>EJz>j6QhZp4#k$f-c]ZPHp[hmãU"&u$U$bjC553>_dPo*Luf&GriR4nn7L4u^rtXfur\n^8YNeejLP1#TPdxe&M3DTPãU"jPC1Q43Iu<^moR/is(H^Xt\+XPuSCd9Hgh0s]+mHtH^D<=CVuãU"Iu->(,43,H$T;LIbfs\e[vY*oT/^Y.2TEb7W2U.Jn=Lw1JR5v5/zND=>lYNc,f^ãU"D3LR,6BFPj/wq-V#Ao#rP+EoX3Rf.JprdnckPo:p\cJftT%w>H>'LZ\Xk1t5;DVfu[ãU"6%rTnTpXtGG0?:6uvl+5tV%L4V3V%F5+SW3uãU"R>]*Zu9rprbarvtGr^-M>QJT]qaX>tX/0OO(*F+t\PlfE&Tl6WV-p,6xr=*NV61>Eh_Blb%wc1oX&qK81ãU"J;jV4=jtNx4\Mq?ox[4j4Dl+%Ej5fuX%F^3om6aYd+2U]Hxpl%e4xYq%jfdbx.oãU"bifAg)cNttY]PFofEBo9j=fDHJEAg-enTsCsnãU",d;ew+o7mFcoDn\d;MqJE+Nd'HlLz[)^cSb6bFd>kpGTk'5>u?Ye<]3.[.3imZãU":R7aNbFuS-:+EW>c(8\)ifTA#XP14,e=UQsCuFVRjU(45onqmY0L1J)Z'HHJNTdãU"a,mL0N0rkl6'O>K\OR2'u_l,llw[BQ2pG%^=y.)_J-QPePYwC-*/W$M^^zSwBR1ãU"29;-d/jo'+Di7,7/jL9#3s/,wãU"a;+-msfG3(#PKrGMK2#h(?kVr*0t]z%4z#hiG<.[471ssl;flVOiFz=hS&wt[ohãU"R$S:/rKzuWL(K4N,IR^R%p9e9>HA^sf\E*$]%\Z'E$9un2KjcwUybrk=kQB2#9KãEND SUBãSUB V2ãU"t(mkHD:efr#>[Op.v.[oS7y'[V%ZMeLkDS\;9nJ=I?zNuMui>;dy$:sDV[/;=yqãU"syYN8_dEQ71\Pyxni^O;yrt[kh_i6)>UYvXJJr\\#bkF%8+u*Jh$dmK9fsAg%PtãU"rD=7RU]7.H[P0XtNgua['nDAWSb9mN%^ey*AzoS<8k;#L'K8.[n]T+c,g)'C3K28xNl7l]Yjmo<_0%7eZ;_X%>k(=J*pXD4_Y>e1ãU"dKS%[)$d[*M8)N.WVqZCD\K^$FQI'\m%r:$PAWb1Q;*X/Qg8eãU"MXkXu,p>YJ84dXIlS\o%u7Yst]A2NBclT3O?2UlH)e'3C:C?;)LcNGZV$>rP13V^2T:.Z2DB,#1AwVOA1*IIãU".fQc#dwquS;b:1'x':dGD+XR^oZCM0=Ds'dw%*un)/oV(tU,p0YjR#Q]#t15:>:ãU"H9Bw'bWN]+$kD2;[z4\d=Gr3],52WAA[AJal'j2nFn7,,nFv13u/37.QXw#Q,w'ãU"UAMZdwre2,)RmfANJIn=\d-(vu.6$5'l)60Yw[SHPalsz]Yw%YmA-wa[IkCrwLaz]ee0Y%ãU"'SWA)]6O'E.X9VRz-w+L)^Azt<12XIz_40]cIyBT*:78Pa=1#S*iJc'6jIi'8aGãU"S7d]P)Cdq.F&Q39#C7gkr]N8x0g2\a_HY^mLA.(.yV6kQ*AZ;QJDCdp']NDz?pqãU"2=\D=D]IZ]qXe=cd8'^ntvZ/='cXO$6'(qGeqR$seS8G%k.19d5\lXI3Yw:8P6PãU"Ir)4q.]b%hqj*vtt-^]%t&Ud$s[SOHn8[iYKcETc8G6M0xES)8dfR)Cd&giB1vkãU"i92v[Y2v#FLX^P+tL[.;Ki.n6Y,wz:'nj[C.KK)+Ji>ZR6HfYRmJ*IuVGH,N1lnãU"6[n$dHNKEMmY4fuk%lv$lf$6>$'ba7I^XU)]&FC#aD)J&'YLd.s=ka.48sso%bpãU"PC9FF^&wFVUC:j#hCI>[#WH:xQtfTWN,%ec*FK2+oF#nGCWY5:Y,q=hbãU"18nOI['ph9p>w.o(07G9.Z)kb#B7mW-YN5m,,W?7ZAAV%H-bl=NHqm]I^FOL.N;ãU"S%6oOg/$RGa=[s+#mnCh92A,?-2Je9zTGhET_15X,hH9gt3Sj.%J2)z\)dQZuLoãU"F)UU&'ee5d'?4])Xs)u*GnMg.eF>rIYJOkKHr$xTETY[BãU"H[Jq7&XV\AnlO)-C=SL-*1b4&8k3?0pLN;68GniRs=heUU%-4k1LO^Bf7>O4A%wãU"&G(?UL-qmTZAeB)^;PG]hQ/B'nGo5Eo>OVWD5+%qs(Bh_/alqZiY[##'*)b>1-RãU"]nf_=ec[#%h'>VQ7)OW7M&]9nQ?:Q(PSE)#5PPSJs)?$\cxEjC07Gy.Y)kVJ))YãU"c15#wFZYeb_%ekiS(Q/nT_m;K9;X'P5^5c%c&8N.&fepOq9k-YGFvj?^O,DL#44ãU"<^*Gk49PpM5R(q)gj#7JngwRE&DN3:2lFj&gC7_OOBL$j5'gAH^Eo(MP=.\7o%2ãU")UYN&,CUwJJc%im8dXl70;T_6A0+07b6m;*V.OU^T;'gm%3-mGA_Z)c*L*(''S^ãU"C'#'VJO&I?A(&Z[/X0YEglg%HzG%M&YC.Q*%8bWv'UFNY43/e'z.a-8eq8+SSJ(ãU"5e%xO#:,jTD&1\ET1HKX7WZ:BYx'^L4M60Ua9DS$Q?iw)5(T\(AnPTãU"--p'g7$$=9p;nAPs>Ke>$04[OtCAm8O8v381u9,i_14Qvv(=]_[E^0]AVjcQX3;ãU"-ho:'^5c5D&oeoH[i'>\?M4\FcCZnVL:l7K21B3+jdK5BrhDD>HRg9A*iaFa%?GãU"jfY$ht3=)>*G_N'\^DEJ80akrWD:NUB2\)5%.6kUfW>$:7W6\XjGesad&=6p4+iãU"k-#x=T+og>9DV?'L--83R4I(m?cg0mujac=H:.ãU"vSGKNIJW(&)C0Cm\%TUg7DQ^0*Y7Jg2]AZ7_MPf1PGc0rr_^*$YP+)/$S#B-eY*ãU"h(eJ>?_8HQH(f;ipanfcY5brWTD8HQG&'1AwjgMi-1aeQyjieL=lRk'i%Z,/I\QãU">7)o#cYZX=bTT;_e#w3iodd3BXx8WmG=Pqr+9r2sF8KB:vSG8mXjsW'eGaKiavNãU")W)cphQ5d7WNb-K>e$2)*MwniDlHjG^p&'H^8hTc^JQE+Iv3#a)ZiO*GjF.*.S'jNVPpEN)-)e6we0qY9j6[Bc_(g^3W3ãU"BcI?%/b8G%xn.E_f?dc%-*uDYvMR*J\_PK0Q6l4)b8g.2o0ewa4;MUXo]M[/)N:ãU"$1Z*ipX(HLh;F9/a2f>uj3'0XS0XqZO)bS0HaWL3x[I^nWmIDIfG1)jhRQ+M[f6)jhRQ+Mcf6e47qLJ*ocZqãU">T6Hu\ym6L+3S#yteokE7$M6u>epkq#IA\:agF11\(xOM/:I_voDYM%>etkJimwãU"(2bjT970mg#\H2bHN>d^7aIfhr=6)UfL;77M2>etk)U2C;._Pv=V0b^itg9GYJhãU"lmrrUi(g:H,$Idc^7ab(^it9/Glg$=pO'%*=U4N2Q*x9^XaoFwTwG\Iuv4ãU"H#[:oN;sjRaiL(FhUp%+/;=7IKTkwXqc9jS1%tw.=?8\1kkdAt^Nmo992Spwa4HãU"1Y2+fJk6P1LW0;t#=0O6$'dMy8D)VHw%=Al-E0U3VU1RXk&RlIDV,HU3JZ%Ck0sãU"C0<<6Xk0sQ0R^)BP&04Jn.Uar&#;1c)Kgbcy[mãU"?1(J_7A%Fk&)WRU4*TM.EwwKn09t)SIZ5^C8nUkA:2BCUnTp<:8RUHX;8\2Vs;.jn(PGlfV[VihML71j<(1xyvex-M(8tKU#O4Jci5jjWptx22J.4NãU"d7K[obv?djT^7HOgf*g<.VLDhSk0H71C/=-V>ipb\;i4:zV?(ukXiCiK^1<9%r-7k0ZDz]MãU"a,*[_uXI09>Dbtm=E]K_qamg)Z_b%TL$Je3l#uh=n.6TbgJGpUHT?'?BYQ.:G.fãU"I>=%T.k**\xq1<\xFm2[^XQ4.\xDtX9q-9NH4?Xa[am.75-ii=[OjZ5NGh:;qNsãU"8g;+B)Bx&&T/6dv_T=l*e8eO2fLHcE>:kjkLY^:$W/JLm:+V8[#GRYGevevkBeifd/*efL\Ig.p%MY'lB)+8rB88fg2q-78JS$;&ãU"w#::C=8e(lQK/^=tS[mP_D6'/;l,NZOQ5Vp)*&xY#\fm7u+9c)r^27i;Y7kV-VGãU"5I#$D;u0-E6%,c_W,#3q[?HAS,YgeJbWjkki:4UA+usa]uV/fs4X/9x^Xdoip7XãU"fllKxZ]hpQ:D#td%up()%9%'%[-%=+[SJ5+6f1O2.%%_e%%%1%%%%zu%ihqt%hpãU"SgRfxf*SBfvkhI6KTM*4OYFi>+ZGxJ4c?.rx*(N$D58.][RQ;39'(dWeGHt*N8F+Ci=*v5R5/Dd]fãU"*p;lj6C2[;)CoOoJM[YOf2<*NG,q#S;xX(UR'dSW'zIpeE:CX54_[NHl+\tg[DzãU"I6gYFgQoki_o1R6lXv#a:[H=w#=ReD2Dpr1X+95%pLbl*8P7A218A2a7Sn*%_o+'t:U8]_#zLm:,vI_Ni-=ieãU"hGjupCx3x7sbT5j;aKs[,n3jx^l,eHQI<=N4-shWXv4av?^j'g%\OJ,$o=w>^'UMY>H3^=fbOht7YDv#u2sDvAA16BiHx2.6w,gz7%JmhkvUfh?6i-7GmlFRa1ãU"CG7:j.9v1\.dS7KAt1DQ-oJeNZ70K0QDUHyTRhssM]Ak-2F>0E,\=CB*M:[T?<-ãU"'95>9Fg)C\N'ZT-bVS1m5s>&=20#&Pa;m$;hV=NmXn6Sf[oEW'ãU"$>\?m5YqC1%9fb#hXWXq[VS><&TWM4WMm*.H_%z7&%ORu5Uu]UC6fe/MEG(=;B66q(r4[:u=XcOv6?E\a_kduW%'j(eQjZ[Q$bg-,'xgIãU"=3k3X,dA%^a20/vEU8XM_F2D4o?Um/8Ow)67Az?^(\((M<1.sqDprH1wrnkt/e-ãU"bpW/5tnH8PovQ&bug$SX75m*j1moc_30uBhJol,A6\KdXi\8ZD;M?Lj/^l6TA5^B#F[8G$[-s,B\t.ãU"-LQNa_#d>Hl_smYv)BGI,(Nr\.5sqm8.8X<>a#XHCK>,r2-*)/HS9y3^.^d##FiãU"qc.GvfK&/[tOW>QWhGwc-6(Z$wWFXdaHB[FpnC;RN$*4\?=#qIãU"P;0vM9YAvyLb+i?Lwi+/WhP,JdGV(0s/s8Ll:0=ics;>,3E>oEEJT7X:Vb#wS=kãU"v)ug&,rK;?k?Tom%Js2tB$I.:(ydwSfTBK1R5%z17Hp1m*cH/VYT'1aM),i_dL%ãU"op[S(u[8HEL',EI2-tsB);GuGJRQ2tt,'IA7BbUSk3YS349_8/VTwtQ$S_XOY^*ãU"2B2l<7Ml#3(m[)U6im;)iiJGHb9TXbtq?^bOoK2TRGxãU"]*Ok&,u_en]nSG.R3l*9Fk>MK$V0A=WdT8T2Fs>g.w\^af8h_3$8)2Zchi#$E64ãU"e],TqM'b,1Vv'uq1pU[Er(.xmTs/L*1+gw-]d8-1.[v5mwfLlhf10qaw40k_RO1ãU"ioXE98A$uQ[h.3FBf>LNENwvmutNerZ5:kPT#gM;GtdMD5E<-Kp\'mNXF)Vu[nMãU"le9Sa#DHjJD)=K_s&botx5+/0'>(;u^)ffIK*&08g,9GGY3fiQR23%(8iF>kQ#VãU"VcE2(6(uQ#F_Ob#jbLU*kG.g*5:.w(h\)L(4J/P')c>0t3b1ãU"0_FX)RV:%,s19A(LJ-&62k^uYjV])?0C$eyrv$T.O5+oQ)4\Vb1H\D(a+pY,L#UãU"w-+wnSe1j[ZZBM;H\cqT$6akef0jPimmO0?/ubRoji&h*4oW35F9%C;VR_F6UKdãU"0c7.EW-M-n2bcJ:mQTJ,\'Xg:Mc*8w8c&E)ugr1T1>7ltsZaHZG$RYrBYãU"uDgg039FjD2,*<1;egL053=N';.eso(*miqi?qrSEq#)X7XhXI,)tGzb=&EMWd,ãU"D1jc:WLe=4B']\oEW*SD')[2l):hVZ):\\z*q;^XZ3oYouoi/mEZw/iQw'(T>P^ãU"%Cb/v3:QM>Yp5(Mx'rjv.CMeD2f8GCm?1=.Fx_TQckMY2'Y))$OQ(*28>bL%I*AãU"KQKx=fR92po42-+R;\O'Nx*US;AS]uZ1nf0ãU"=/Lq4e1_\[Qqp6G1\Gk.1d#vFA:6p7?=ElbnY2DãU"q3gvWerhl#:*,je[p8'I3fp6aXSJBv7'7j3Bd$szUR[0?_.b?(sGãU"6Q#vsK#%vLm:2Pt#K2-qima,93BH\fc_n6(a9Oh'a:T&H6i#F$r:%q9b:#Q8#NDãU"T_DciR5q''K_5,V^,Z9B2-0[=a:F*PLL.Hl5?JãU"E9I4So8T0W5,.]&PTPjYJJmsHknjD4JCK?>k0L]w,#Opc0US2ZaU.6=lr';[BV5ãU"m(X7'K_r=iV(D.(PqZEEju2>#,m+^2)wPnfn9%(OqOyk)R=)k[yiZ6xq\xQa>l_'ew_4hnM\zFq]pLN7a$poALePjk(WHI6YBM;.E6ãU"=trRrXtsM'1KG#h%QurTP1uBaUN-5dx*KArWeenpDE36$^CbVibRWLDB74G-'>tãU"9AA>>Wb])Y%)P^EA8U-u9Z^SkW)cB'G.P';m$ZNUS9#tHXPxtj>X9Z\s%-D'iVW#4H'k9_8-i]$%.jol.3rMFm2h16g,MQBwQ]UhWH&V64DMf.ãU"8fg3x]K9REV=#_9R)FV#LfZ7dWNJV<#S5akQ[x$\YK>#:?xãU"&C&%%&W&%%%/%%%%kfij%nyStIgo,_#dm##s9#88Et,S6*A_;f7AY:Z.=ol0)-iãU"X37V._7CHto<7xOQ)*k>8Tk5Xsy:5rD/M+NU+c.fãU"7'8,nE%A/:F,_=4G$Dm4jz,?Du.3t1ow$PcY\8-MX13xz?2<$_j++lvr(fBbpNvnnd\3k2EãU"/A)c1fUMD9o]c3ZdpYILD9Kc7y,3.gxL0[W&PSQep;\_;V95R&J(up%&'9%%9%'ãU"%d-%H(%SJ?Q,d')).%%h.%%%/%%%%%%%%%&%%E%%%%%%%%%fhqt%hpSg%fxup%&ãU"'9%%9%'%d-%A(%SJJv5;j6/%%%8B%%%/%%%%%%%%%&%%E%%%%Q)%%%ihqt%hpSgãU"%fxup%&'9%%9%'%[-%z*dSJp31agr5.%%5w%%%1%%%%%%%%%&%%E%%%'43%%%qhãU"ih%qthp%Sgfx%up&'%9%9%%'%-%+[-SJ;#Hx4&P;%%(;U%%%.%%%%%%%%%&%E%.ãU"%%WD%%%wq%hqpS%gfxu%p&'9%%9%'%%-%='+SJ5Z+f1O#2%%_%e%%1%%%%%%%%%ãU"&%%E%%%%U[%%%zui%hqth%pSgf%xup&%'9%9%%'%-O%3'Dp>#:?(xC&%(%W&%%%ãU"/%%%%%%%%%&%E[%%%S%h%%k%fijn%yStg%oup*%+%%%%%+%+%%x&%(%Ej%%%%%ãEND SUBãV2ãCLOSE:IF S=207AND B&=Z&THEN?" :) Ok!"ELSE?" :( Bad!ãSUB U(A$):FOR A=1TO LEN(A$):C=ASC(MID$(A$,A))-37:IF C<0THEN C=91+C*32ãIF K<4THEN K=C+243ELSE?#1,CHR$(C+(K MOD 3)*86);:K=K\3:B&=B&+1ãS=(S+C)AND 255:NEXT:LOCATE,1:?STRING$(B&*50\Z&,219);:END SUBãLeandro Pardini JULIAN DATE lpardini@cefex.com 09-28-98 (20:38) QB, QBasic, PDS 43 1063 JULIAN.BAS '$STATICãDEFINT A-ZããDECLARE FUNCTION Julian# (Fecha$, Hora$)ããPRINT "Current Julian Date: "; Julian#(DATE$, TIME$)ãã'=====================================================ã' This routine requires that you pass Date and Time in the followingã' formats:ã'ã' DATE - MM-DD-YYYYã' TIME - HH:MM:SSã'ã' To get current Julian date, call Julian#(DATE$, TIME$).ã' "Fecha" and "Hora" means "Date" and "Time" in spanish.ã'=========================================================================ãFUNCTION Julian# (Fecha$, Hora$)ããDM% = VAL(LEFT$(Fecha$, 2))ãDD% = VAL(MID$(Fecha$, 4, 2))ãDY% = VAL(RIGHT$(Fecha$, 4))ããTH% = VAL(LEFT$(Hora$, 2))ãTM% = VAL(MID$(Hora$, 4, 2))ãTS% = VAL(RIGHT$(Hora$, 2))ããJT# = ((TH% * 3600&) + (TM% * 60&) + TS%) / 86400ããIF DM% > 2 THENã DM% = DM% - 3ãELSEã DM% = DM% + 9ã DY% = DY% - 1ãEND IFã ãJ1& = FIX(DY% / 100)ãJ2& = DY% - 100 * J1&ããJulian# = FIX((146097 * J1&) / 4) + FIX((1461 * J2&) / 4) + FIX((153 * DM% + 2) / 5) + DD% + 1721119 + JT# - .5ããEND FUNCTIONããDon Schullian DISPLAY DATES FOR PB/PBCC d83@ath.forthnet.gr 09-17-98 (15:03) PB 100 3485 DISPDATE.BAS$if 0ã Hi all you non-Americans and other individuals that need to displayã the date in any one of the myriad formats found around the world;ã here's a little idea I came up with that you may find interesting.ãã By calling DateSetup you load the individual members of the TYPE withã the info to 'build' a date in the required format very quickly and withã a minimum of code.ãã In the function fYMD2Date you'll find a "$if". It is now set to work inã PB v3.5 so to get it over to PBcc just change the 1 to a ZERO, theã DIM tDate to GLOBAL tDate, VARPTR32 to VARPTR, and you're all set.ãã In my business programs I convert the dates to WORDs (or LONGs). Theã system uses day numbers; 01-01-1872 is day #1 and day #65536 is in theã year 2050. This provides QUICK computations and tight storage. It alsoã means that the dates can be unpacked into any/all formats for use byã humans, hence this bit of an idea I offer to you today. Hope it willã come in handy for you.ãã C'ya,ãã ____ _ ____ ____ _____ã | _ \ / \ / ___) __ | ___)(_ _) Don Schullianã | |_) / _ \ \____\/ \| _) | | d83@ath.forthnet.grã |____//_/ \_\(____/\__/|_| |_| www.DASoftVSS.comã ___________________________________ www.basicguru.comã Vertical Software Solutionsã$endifããTYPE DateDataTYPEã Today AS STRING * 10ã Mask AS STRING * 10ã Seperator AS BYTEã Format AS BYTEã Y_ptr AS STRING PTR * 4ã M_ptr AS STRING PTR * 2ã D_ptr AS STRING PTR * 2ãEND TYPEãã DIM tDate AS SHARED DateDataTypeã' GLOBAL tDate AS DateDataTYPE ' need this for PBccããCLSãDateSetup 0, 47 : PRINT fYMD2Date(1999,1,20)ãDateSetup 1, 45 : PRINT fYMD2Date(1999,1,20)ãDateSetup 2, 46 : PRINT fYMD2Date(1999,1,20)ããSUB DateSetup (BYVAL Format AS BYTE, BYVAL Seperator AS BYTE)ãã IF Seperator = 0 THENã tDate.Seperator = 45ã ELSEã tDate.Seperator = Seperatorã END IFã tDate.Format = ( Format AND 3 )ã tDate.Mask = ""ãã IF tDate.Format < 2 THENã ASC(tDate.Mask,3) = tDate.Seperatorã ASC(tDate.Mask,6) = tDate.Seperatorã tDate.M_ptr = VARPTR32(tDate.Mask) ' change this for PBccã tDate.Y_ptr = tDate.M_ptr + 6ã tDate.D_ptr = tDate.M_ptr + 3ã IF tDate.Format = 1 THEN SWAP tDate.M_ptr, tDate.D_ptrã ELSEã ASC(tDate.Mask,5) = tDate.Seperatorã ASC(tDate.Mask,8) = tDate.Seperatorã tDate.Y_ptr = VARPTR32(tDate.Mask) ' change this for PBccã tDate.M_ptr = tDate.Y_ptr + 5ã tDate.D_ptr = tDate.Y_ptr + 8ã END IFãã tDate.@Y_ptr = MID$(DATE$,7) ' set tDate.Todayã tDate.@M_ptr = DATE$ã tDate.@D_ptr = MID$(DATE$,4)ã tDate.Today = tDate.MaskããEND SUBããFUNCTION fYMD2Date (BYVAL Year AS LONG, _ã BYVAL Month AS LONG, _ã BYVAL Day AS LONG ) AS STRINGãã$if 1 ' PowerBASIC v3.xã DIM Dyte AS LOCAL STRINGã tDate.@Y_ptr = USING$("####", Year )ã tDate.@M_ptr = USING$("##" , Month )ã tDate.@D_ptr = USING$("##" , Day )ã Dyte = tDate.Maskã REPLACE " " WITH "0" IN Dyteã FUNCTION = Dyteã$else ' PowerBASIC ccã tDate.@Y_ptr = FORMAT$(Year , "####" )ã tDate.@M_ptr = FORMAT$(Month, "00" )ã tDate.@D_ptr = FORMAT$(Day , "00" )ã FUNCTION = tDate.Maskã$endifããEND FUNCTIONãNigel Traves LEAP YEAR ALGORITHM UPDATE tarot@ihalliwell.freeserve.co.u03-09-99 (19:05) QB, QBasic, PDS 24 1135 LEAP.BAS 'Some time ago I submitted a set of routines that were inspired byã'similar ones that are part of ansi C. Unfortunately the algorithmã'that I found for determining if a year was in fact a leap year wasã'wrong and meant that overall the package would not be Y2K compliantã'(the dreaded millennium bug strikes again!). Having now got theã'correct algorithm for determining leap years I have produced thisã'update. Serendipitously (oooo, big woid - just means happy accident),ã'leap year determination was limited to a single SUB, so all that needsã'doing is to replace the existing SUB with the one below.ã'ã' N. Traves 3/1999ãã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ãNick Kochakian DELAY ROUTINE nickk@worldnet.att.net 03-29-99 (23:21) QB, QBasic, PDS 75 1728 DELAY1.BAS 'DELAY1.BASã'ã'This program should provide a good enough base to write some sufficientã'delay routines. (Note: If you want to use this in a game, i'd stronglyã' recommend that you adjust to frame rates.. Just an idea :)ã'ã'ã'3/29/99 By: - Nick Kochakian -ã'web: http://come.to/dn3ã'e-mail: nickk@worldnet.att.netããDIM Timer.Whole.Second AS LONG 'This is where we store the result of theã 'second.ãDIM Timer.Half.Second AS LONGãDIM Timer.Quater.Second AS LONGããTimer.Flag = 0 'Tells when to break out of the loopãTimer.Whole.Second = 0ããTIMER ON 'Turn the timer onãON TIMER(1) GOSUB Timer.Release:ããPRINT "Timing second..."ããDOã Timer.Whole.Second = Timer.Whole.Second + 1ãLOOP WHILE Timer.Flag = 0ããTimer.Half.Second = Timer.Whole.Second / 2ãTimer.Quarter.Second = Timer.Half.Second / 2ãã'Some example:ãCLSãPRINT "I have known for some time now that timing in QBasic has been a"ãPRINT "problem. Which is why I've whiped up some basic timer routines."ãPRINT "This demo program will show you the differences between pausing"ãPRINT "for a Qtr second , and a half second."ãPRINT ""ãPRINT "Press SPACE"ããDOãLOOP UNTIL INKEY$ = CHR$(32)ããCLSãPRINT "Timing 3 times..."ãPRINT ""ããFOR t = 1 TO 3ã FOR Timer.count = 1 TO Timer.Quarter.Secondã NEXT Timer.countãã PRINT ".25 seconds"ãNEXT tããFOR t = 1 TO 3ã FOR Timer.count = 1 TO Timer.Half.Secondã NEXT Timer.countãã PRINT ".5 seconds"ãNEXT tããFOR t = 1 TO 3ã FOR Timer.count = 1 TO Timer.Whole.Secondã NEXT Timer.countãã PRINT "1 second"ãNEXT tããENDããTimer.Release:ããTimer.Flag = 1ãTIMER OFFãRETURNãRoger W. Sinnott CALCULATE SUNRISE/SUNSET TIMES www.gnomehome.demon.nl 05-31-99 (17:23) QB, QBasic, PDS 141 4676 SUNRISE.BAS 310 DIM A(2), D(2)ã10 ' Sunrise-Sunsetã20 GOSUB 300ã30 INPUT "Lat, Long (deg)"; B5, L5ã40 INPUT "Time zone (hrs)"; Hã50 L5 = L5 / 360: Z0 = H / 24ã60 GOSUB 1170: T = (J - 2451545) + Fã70 TT = T / 36525 + 1: ' TT = centuriesã80 ' from 1900.0ã90 GOSUB 410: T = T + Z0ã100 'ã110 ' Get Sun's Positionã120 GOSUB 910: A(1) = A5: D(1) = D5ã130 T = T + 1ã140 GOSUB 910: A(2) = A5: D(2) = D5ã150 IF A(2) < A(1) THEN A(2) = A(2) + P2ã160 Z1 = DR * 90.833: ' Zenith dist.ã170 S = SIN(B5 * DR): C = COS(B5 * DR)ã180 Z = COS(Z1): M8 = 0: W8 = 0: PRINTã190 A0 = A(1): D0 = D(1)ã200 DA = A(2) - A(1): DD = D(2) - D(1)ã210 FOR C0 = 0 TO 23ã220 P = (C0 + 1) / 24ã230 A2 = A(1) + P * DA: D2 = D(1) + P * DDã240 GOSUB 490ã250 A0 = A2: D0 = D2: V0 = V2ã260 NEXTã270 GOSUB 820: ' Special msg?ã280 ENDã290 'ã300 ' Constantsãã320 P1 = 3.14159265#: P2 = 2 * P1ã330 DR = P1 / 180: K1 = 15 * DR * 1.0027379#ã340 S$ = "Sunset at "ã350 R$ = "Sunrise at "ã360 M1$ = "No sunrise this date"ã370 M2$ = "No sunset this date"ã380 M3$ = "Sun down all day"ã390 M4$ = "Sun up all day"ã400 RETURNã410 ' LST at 0h zone timeã420 T0 = T / 36525ã430 S = 24110.5 + 8640184.812999999# * T0ã440 S = S + 86636.6 * Z0 + 86400 * L5ã450 S = S / 86400: S = S - INT(S)ã460 T0 = S * 360 * DRã470 RETURNã480 'ã490 ' Test an hour for an eventã500 L0 = T0 + C0 * K1: L2 = L0 + K1ã510 H0 = L0 - A0: H2 = L2 - A2ã520 H1 = (H2 + H0) / 2: ' Hour angle,ã530 D1 = (D2 + D0) / 2: ' declination,ã540 ' at half hourã550 IF C0 > 0 THEN 570ã560 V0 = S * SIN(D0) + C * COS(D0) * COS(H0) - Zã570 V2 = S * SIN(D2) + C * COS(D2) * COS(H2) - Zã580 IF SGN(V0) = SGN(V2) THEN 800ã590 V1 = S * SIN(D1) + C * COS(D1) * COS(H1) - Zã600 A = 2 * V2 - 4 * V1 + 2 * V0: B = 4 * V1 - 3 * V0 - V2ã610 D = B * B - 4 * A * V0: IF D < 0 THEN 800ã620 D = SQR(D)ã630 IF V0 < 0 AND V2 > 0 THEN PRINT R$;ã640 IF V0 < 0 AND V2 > 0 THEN M8 = 1ã650 IF V0 > 0 AND V2 < 0 THEN PRINT S$;ã660 IF V0 > 0 AND V2 < 0 THEN W8 = 1ã670 E = (-B + D) / (2 * A)ã680 IF E > 1 OR E < 0 THEN E = (-B - D) / (2 * A)ã690 T3 = C0 + E + 1 / 120: ' Round offã700 H3 = INT(T3): M3 = INT((T3 - H3) * 60)ã710 PRINT USING "##:##"; H3; M3;ã720 H7 = H0 + E * (H2 - H0)ã730 N7 = -COS(D1) * SIN(H7)ã740 D7 = C * SIN(D1) - S * COS(D1) * COS(H7)ã750 AZ = ATN(N7 / D7) / DRã760 IF D7 < 0 THEN AZ = AZ + 180ã770 IF AZ < 0 THEN AZ = AZ + 360ã780 IF AZ > 360 THEN AZ = AZ - 360ã790 PRINT USING ", azimuth ###.#"; AZã800 RETURNã810 'ã820 ' Special-message routineã830 IF M8 = 0 AND W8 = 0 THEN 870ã840 IF M8 = 0 THEN PRINT M1$ã850 IF W8 = 0 THEN PRINT M2$ã860 GOTO 890ã870 IF V2 < 0 THEN PRINT M3$ã880 IF V2 > 0 THEN PRINT M4$ã890 RETURNã900 'ã910 ' Fundamental argumentsã920 ' (Van Flandern &ã930 ' Pulkkinen, 1979)ã940 L = .779072 + .00273790931# * Tã950 G = .993126 + .0027377785# * Tã960 L = L - INT(L): G = G - INT(G)ã970 L = L * P2: G = G * P2ã980 V = .39785 * SIN(L)ã990 V = V - .01 * SIN(L - G)ã1000 V = V + .00333 * SIN(L + G)ã1010 V = V - .00021 * TT * SIN(L)ã1020 U = 1 - .03349 * COS(G)ã1030 U = U - .00014 * COS(2 * L)ã1040 U = U + .00008 * COS(L)ã1050 W = -.0001 - .04129 * SIN(2 * L)ã1060 W = W + .03211 * SIN(G)ã1070 W = W + .00104 * SIN(2 * L - G)ã1080 W = W - .00035 * SIN(2 * L + G)ã1090 W = W - .00008 * TT * SIN(G)ã1100 'ã1110 ' Compute Sun's RA and Decã1120 S = W / SQR(U - V * V)ã1130 A5 = L + ATN(S / SQR(1 - S * S))ã1140 S = V / SQR(U): D5 = ATN(S / SQR(1 - S * S))ã1150 R5 = 1.00021 * SQR(U)ã1160 RETURNã1165 'ã1170 ' Calendar --> JDã1180 INPUT "Year, Month, Day"; Y, M, Dã1190 G = 1: IF Y < 1583 THEN G = 0ã1200 D1 = INT(D): F = D - D1 - .5ã1210 J = -INT(7 * (INT((M + 9) / 12) + Y) / 4)ã1220 IF G = 0 THEN 1260ã1230 S = SGN(M - 9): A = ABS(M - 9)ã1240 J3 = INT(Y + S * INT(A / 7))ã1250 J3 = -INT((INT(J3 / 100) + 1) * 3 / 4)ã1260 J = J + INT(275 * M / 9) + D1 + G * J3ã1270 J = J + 1721027 + 2 * G + 367 * Yã1280 IF F >= 0 THEN 1300ã1290 F = F + 1: J = J - 1ã1300 RETURNã1310 'ã1320 ' This program by Roger W. Sinnott calculates the times of sunriseã1330 ' and sunset on any date, accurate to the minute within severalã1340 ' centuries of the present. It correctly describes what happens in theã1350 ' arctic and antarctic regions, where the Sun may not rise or set onã1360 ' a given date. Enter north latitudes positive, west longitudesã1370 ' negative. For the time zone, enter the number of hours west ofã1380 ' Greenwich (e.g., 5 for EST, 4 for EDT). The calculation isã1390 ' discussed in Sky & Telescope for August 1994, page 84.ãDon Schullian DATES ROUTINES FOR QB d83@DASoftVSS.com 07-02-99 (13:31) QB, QBasic, PDS 156 4549 DATES-QB.BAS Hi,ãã These routines are Y5M compliant!ãã This code was reworked from code I was given by Eustice Frilingos so most ofã the credit goes to him.ãã These two functions pack the three date elements (Y,M,D) into a long integerã by counting the number of days since 1-1-0001 then unpacking that number intoã the three date elements. The last possible date is in the year 5.8M so it'sã safe to say that the Y2K thingie isn't a problem!ãã The fly in the ointment is that somewhere in the 12th century 11 days wereã cut or added to the calendar (don't remember which) so if you're an historianã you'll need to modify the routines to work around that little chronologicalã blip. The reason I've not messed with it is two fold:ã 1) I don't plan on going back that farã 2) that 11 day blip is ONLY good in so many countries.ã Other countries and/or religious and/or ethnic groups did things differentlyã so the whole sheebang gets totally mind boggling if one wants to make thisã routine work 100% for all conditions.ãã The benefits of storing dates in this manner are many fold and not limited toã the list below:ã 1) DayOfTheWeek = (Days MOD 7) ' Sunday = 0 and Saturday = 6ã 2) The system is country independentã 3) ToDay + 7 = SameDay_NextWeekã ToDay + 28 = SameDay_NextMonth (4 weeks)ã 4) Validation of an incoming date is fast and quick using the sameã two routines and comparing the returned Y,M,D with what wasã sent. (You need to build such a checking routine)ãã fYMD2Days& returns the number of days since 1-1-0001ã fDays2YMD% returns the year, month, day and day of the week for a day numberã fJulianDay& returns the day number in a given yearã fLeapYear% returns 0 or 1 if the year is, in fact, a leap year.ãã Hope these routines help you out.ãã d83)ãã---------------------------------------------------------------ã-----------------------------------------------------ã---------------------------------------------------------------ããDEFINT A-ZãDECLARE FUNCTION fLeapYear% (Year%)ãDECLARE FUNCTION fYMD2Days& (Year%, Month%, Day%)ãDECLARE FUNCTION fDays2YMD% (Days&, Year%, Month%, Day%)ããCLSããT1! = TIMERãFOR Y1% = 400 TO 2400ã PRINT USING "#,###"; Y1%ã DoM& = &H3DFF7F9Fã IF fLeapYear%(Y1%) THEN DoM& = (DoM& + 32)ã FOR M1% = 1 TO 12ã FOR D1% = 1 TO (DoM& AND 31)ã IF LEN(INKEY$) THEN GOTO BailOutã Dz1& = fYMD2Days&(Y1%, M1%, D1%)ã DoW% = fDays2YMD%(Dz1&, Y2%, M2%, D2%)ã IF (Y1% <> Y2%) OR (M1% <> M2%) OR (D1% <> D2%) THEN PRINT "ERROR": ENDã NEXTã DoM& = DoM& \ 32ã IF DoM& = 0 THEN DoM& = &H3FEFFBFFã NEXTãNEXTããBailOut:ã T1! = TIMER - T1!ã PRINTã PRINT USING "###.####"; T1!ã PRINT "<>";ãENDããFUNCTION fDays2YMD% (Daze&, Year%, Month%, Day%)ãã Year% = 1ã Month% = 1ã Days& = Daze& - 1ãã IF Days& > 146096 THENã Year% = Year% + (Days& \ 146097) * 400ã Days& = (Days& MOD 146097)ã END IFã IF Days& > 36523 THENã D% = (Days& \ 36524)ã IF D% < 4 THENã Year% = Year% + (D% * 100)ã Days& = (Days& MOD 36524)ã ELSEã Year% = Year% + 300ã Days& = 36524ã END IFã END IFã IF Days& > 1460 THENã Year% = Year% + (Days& \ 1461) * 4ã Days& = (Days& MOD 1461)ã END IFã IF Days& > 364 THENã D% = (Days& \ 365)ã IF D% < 4 THENã Year% = Year% + D%ã Days& = (Days& MOD 365)ã ELSEã Year% = Year% + 3ã Days& = 365ã END IFã END IFãã Day% = Days& + 1ã DoM& = &H3DFF7F9Fã IF Day% > 58 AND fLeapYear%(Year%) THEN DoM& = (DoM& + 32)ã DOã D% = (DoM& AND 31)ã IF D% >= Day% THEN EXIT DOã Day% = Day% - D%ã Month% = Month% + 1ã DoM& = (DoM& \ 32)ã IF DoM& = 0 THEN DoM& = &H3FEFFBFFã LOOPãã fDays2YMD% = (Daze& MOD 7)ããEND FUNCTIONããFUNCTION fLeapYear% (Year%)ãã IF ((Year% MOD 4) = 0) AND ((Year% MOD 100) > 0) OR ((Year% MOD 400) = 0) THEN fLeapYear% = 1ããEND FUNCTIONããFUNCTION fYMD2Days& (Y%, M%, D%)ãã Days& = D%ãã IF M% > 1 THENã Month% = M%ã DoM& = &H3DFF7F9Fã IF Month% > 2 AND fLeapYear%(Y%) THEN DoM& = (DoM& + 32)ã DOã Days& = Days& + (DoM& AND 31)ã IF Month% = 2 THEN EXIT DOã Month% = Month% - 1ã DoM& = DoM& \ 32ã IF DoM& = 0 THEN DoM& = &H3FEFFBFFã LOOPã END IFãã Year% = (Y% - 1)ã Days& = Days& + (CLNG(Year%) * 365) + (Year% \ 4) - (Year% \ 100) + (Year% \ 400)ãã fYMD2Days& = Days&ããEND FUNCTIONãLaz500@aol.com SECONDS LEFT UNTIL YEAR 2000 santa@tir.com 07-25-99 (12:02) QB, QBasic, PDS 62 2244 2000AD.BAS ' º Millenium º ã' ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍͼã'ã' E-Mail: Graham_Lally@o14amiga.demon.co.uk ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍã' Or: Laz500@aol.com º²²²²²²²²²²²²²²²²ã' º±±±±±±±±±±±±±±±±ã' WWW: http://www.kingston.ac.uk/~lr_s536/Qbasic.html º°°°°°°°°°°°°°°°°ã'ÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍͼãããDIM total.secs.left AS LONG 'to stop getting those nasty E numbers :]ããYear = VAL(RIGHT$(DATE$, 4)) '\ãmonth = VAL(LEFT$(DATE$, 2)) ' \ãday = VAL(MID$(DATE$, 4, 2)) ' Gets the values from the Date$ and Time$.ã ' The VAL just turns what is usually aãHours = VAL(LEFT$(TIME$, 2)) ' string into a number. Pretty useful...ãMins = VAL(MID$(TIME$, 4, 2)) ' /ãSecs = VAL(RIGHT$(TIME$, 2)) '/ã ãYears.left = (1999 - Year) * 365 * 24 * 60 * 60ãã'The above line works out the number of seconds in the years left.ãã'This next SELECT works out how many days have gone past in the completedã'months of this year.ããSELECT CASE monthã CASE 1: daysgone = 0ã CASE 2: daysgone = 31ã CASE 3: daysgone = 59ã CASE 4: daysgone = 90ã CASE 5: daysgone = 120ã CASE 6: daysgone = 151ã CASE 7: daysgone = 181ã CASE 8: daysgone = 212ã CASE 9: daysgone = 243ã CASE 10: daysgone = 273ã CASE 11: daysgone = 304ã CASE 12: daysgone = 334ãEND SELECTãdaysgone = daysgone + day 'Now we add the number of days gone in this month.ãDays.left = (364 - daysgone) * 24 * 60 * 60 'And work out the seconds...ããHours.left = (23 - Hours) * 60 * 60ãMins.left = (59 - Mins) * 60ãSecs.left = (60 - Secs)ãã 'Yep, all pretty straightforward...ããtotal.secs.left = Years.left + Days.left + Hours.left + Mins.left + Secs.leftãã 'Add it all up...ããPRINTãPRINT "Seconds left till the Year 2000:";ãCOLOR 14ãPRINT total.secs.leftãPRINTãCOLOR 7ãã 'And print it. All done. Easy peasy pudding and pie.ãWayne Henderson SEASONS CALCULATOR whenders@becon.org 10-29-99 (22:14) QB, QBasic, PDS 127 5394 SEASONS.BAS 'ã' SEASONS CALCULATOR (approximate) times within ñ minute for yearsã' from +1000 to +3000 or moreã'ã' from algorithms presented in 'Astronomical Algorithms' byã' Jean Meeus, 1991 ISBN 0-943396-35-2 (get it at the library to see howã' this complicated algorithm works.)ã' More accurate methods exist and are mentioned in the book's bibliographyã'ãDEFINT A-ZãDECLARE FUNCTION dcos# (deg#) 'convert degrees to radians, get cosãDECLARE FUNCTION jd2date$ (month, day AS DOUBLE, y&) 'Julian Day to Calendar dateãDIM yr AS DOUBLE, day AS DOUBLE, jde AS DOUBLE, Lambda AS DOUBLEãDIM March AS DOUBLE, June AS DOUBLE, September AS DOUBLE, December AS DOUBLEãDIM c AS INTEGER, b(72) AS DOUBLEãCONST rad# = 3.141592653589793# / 180ã'ãstart: PRINT : INPUT "Year ", q$: yr = VAL(q$): IF yr = 0 THEN SYSTEMãyr = (yr - 2000) / 1000: PRINTã'ã' step 1 calculate:ã'ã' JDE0 - 2451545.0ã' T = ----------------, # of Julian centuries since Jan. 1, 2000 noon UTã' 36525ã'ã' W = 35999.373T - 2.47 (degrees)ã'ã' Lambda = 1 + 0.0334 cos W + 0.0007 cos 2Wã'ã'  jde0 valuesãMarch = 2451623.80984# + 365242.37404# * yr + .05169 * yr * yrãMarch = March - .00411 * yr * yr * yr - .00057 * yr * yr * yr * yrãJune = 2451716.56767# + 365241.62603# * yr + .00325 * yr * yrãJune = June + .00888 * yr * yr * yr - .0003 * yr * yr * yr * yrãSeptember = 2451810.21715# + 365242.01767# * yr - .11575 * yr * yrãSeptember = September + .00337 * yr * yr * yr + .00078 * yr * yr * yr * yrãDecember = 2451900.05952# + 365242.74049# * yr - .06223 * yr * yrãDecember = December - .00823 * yr * yr * yr + .00032 * yr * yr * yr * yrã'ã' step 2 get the 24 terms of the series A cos (B + CT)ã' and calculate their sum in subroutine kalk.ã'ãRESTORE: FOR c = 1 TO 72: READ a$: b(c) = VAL(a$): NEXTã'  terms of the series: A cos (B + CT), S = ä { A cos (B + CT) }ã' eg: 485 * cos (324.96 + 1934.136 * T) + 203 * ...ãDATA 485,324.96,1934.136,203,337.23,32964.467,199,342.08,20.186ãDATA 182,27.85,445267.112,156,73.14,45036.886,136,171.52,22518.443ãDATA 77,222.54,65928.934,74,296.72,3034.906,70,243.58,9037.513ãDATA 58,119.81,33718.147,52,297.17,150.678,50,21.02,2281.226ãDATA 45,247.54,29929.562,44,325.15,31555.956,29,60.93,4443.417ãDATA 18,155.12,67555.328,17,288.79,4562.452,16,198.04,62894.029ãDATA 14,199.76,31436.921,12,95.39,14577.848,12,287.11,31931.756ãDATA 12,320.81,34777.259,9,227.73,1222.114,8,15.45,16859.074ã'ã'........ Change TZ and TZ1$, TZ2$ to the correct values for your time zone:ã'........ 8 for PST 7 for PDT, 7 for MST 6 for MDT, 6 for CST 5 for CDT, etc.ã'ãtz1$ = " EST": tz2$ = " EDT"ãjde = March: tz = 5: GOSUB kalk: PRINT "Spring: ";ãGOSUB jddate: PRINT jd2date$(month, day, y&); tz1$ãjde = June: tz = 4: GOSUB kalk: PRINT "Summer: ";ãGOSUB jddate: PRINT jd2date$(month, day, y&); tz2$ãjde = September: tz = 4: GOSUB kalk: PRINT "Autumn: ";ãGOSUB jddate: PRINT jd2date$(month, day, y&); tz2$ãjde = December: tz = 5: GOSUB kalk: PRINT "Winter: ";ãGOSUB jddate: PRINT jd2date$(month, day, y&); tz1$ãGOTO startã'ã' step 3ã' 0.00001Sã' JDE = jde0 + ----------ã' Lambdaã'ãkalk:ã t# = (jde - 2451545) / 36525ã w# = 35999.373# * t# - 2.47#ã Lambda = 1 + .0334 * dcos(w#) + .0007 * dcos(2 * w#)ã sum# = 0ã FOR c = 1 TO 72 STEP 3ã sum# = sum# + b(c) * dcos(b(c + 1) + b(c + 2) * t#)ã NEXTã jde = jde + (.00001 * sum#) / Lambda - tz / 24 'UT to local - tz/24ãRETURNã'ãjddate: 'algorithm from Peter Baum (pbaum@capecod.net)ã r$ = "312831303130313130313031": s& = INT(jde - 1721118.5#)ã H# = jde - 1721118.5# - s&: m# = 100 * s& - 25ã a = m# \ 3652425: b = a - a \ 4: y& = (100 * b + m#) \ 36525ã c = b + s& - 365 * y& - y& \ 4: month = (5 * c + 456) \ 153ã day = c - (153 * month - 457) \ 5 + H#ã IF month > 12 THEN y& = y& + 1: month = month - 12ã IF y& / 400 = y& \ 400 THEN MID$(r$, 4, 1) = "9"ã IF (y& / 100 <> y& \ 100) AND (y& / 4 = y& \ 4) THENã MID$(r$, 4, 1) = "9"ã END IFãRETURNã'ã' by Wayne Henderson Oct. 29, 1999 (Fri) 10:00 pm EDTããDEFSNG A-ZãFUNCTION dcos# (deg#)ã dcos# = COS(deg# * rad#)ãEND FUNCTIONããDEFINT A-ZãFUNCTION jd2date$ (month, day AS DOUBLE, y&)ã r$ = "312831303130313130313031"ã hr! = (day - INT(day)) * 24 'fraction of a dayã min! = (hr! - INT(hr!)) * 60 'fraction of an hourã sec = CINT((min! - INT(min!)) * 60) 'fraction of a minuteã min! = INT(min!): day = INT(day): hr! = INT(hr!)ã IF sec = 60 THEN sec = 0: min! = min! + 1ã IF min! = 60 THEN min! = 0: hr! = hr! + 1ã IF hr! = 24 THEN hr! = 0: day = day + 1ã IF day > VAL(MID$(r$, month * 2 - 1, 2)) THEN day = 1: month = month + 1ã IF month > 12 THEN month = 1: year = year + 1ã IF month < 10 THEN u$ = "0" ELSE u$ = ""ã IF day < 10 THEN w$ = "0" ELSE w$ = ""ã IF hr! < 10 THEN v$ = "0" ELSE v$ = ""ã IF min! < 10 THEN x$ = "0" ELSE x$ = ""ã IF sec < 10 THEN p$ = "0" ELSE p$ = ""ã u$ = u$ + LTRIM$(STR$(month)) + "-": w$ = w$ + LTRIM$(STR$(day)) + "-"ã v$ = v$ + LTRIM$(STR$(hr!)) + ":": x$ = x$ + LTRIM$(STR$(min!)) + ":"ã p$ = p$ + LTRIM$(STR$(sec))ã jd2date$ = u$ + w$ + LTRIM$(STR$(y&)) + " " + v$ + x$ + p$ãEND FUNCTIONãDavid O. Williams SIDEREAL TIME CLOCK david.williams@ablelink.org 01-01-00 (15:23) QB, QBasic, PDS 252 5428 SIDCLK.BAS ' Sidereal Clockãã' David O. Williams. 1999. Public Domain. No Price. No Warranty.ã' (But I do think it's correct!)ãã' Thanks to Jeff Root, Mike Ross and Arnold Gill for suggestions and help.ãã' E-mail: david.williams@ablelink.orgãã' If you make any changes, and distribute the changed version, pleaseã' document what you have done here, so you get the credit - or blame!ããDECLARE FUNCTION DivMult% (Div&)ãDECLARE FUNCTION Sting$ (X%)ãDECLARE FUNCTION Secs& (TS$)ãDECLARE FUNCTION Dte# (Dat$)ãDECLARE SUB Dely (N!)ããDEFDBL A-ZãCOMMON SHARED Num&ããCONST Factor = 1.00273793# ' sidereal / solar time ratioããEqDate$ = "03-21-1999" ' these 2 lines are date and (UT) time ofãEqTime$ = "01:46:00" ' most recent available March equinox.ããTEqun = -440 ' equation of time at March equinoxããEqTi = Secs&(EqTime$)ãOffset = Dte#(EqDate$) + EqTiããPl$ = "MBMST255L10"ãFOR X% = 1 TO 10ã Pl$ = Pl$ + "N50N55N60N65N70N65N60N55"ãNEXTãPl$ = Pl$ + "N50L64N0"ããDIM P$(0 TO INT(LEN(Pl$) / 20))ãY% = 1ãNp% = 0ãDOã Z% = INSTR(Y% + 25, Pl$, "N")ã IF Z% = 0 THEN Z% = LEN(Pl$) + 1ã P$(Np%) = MID$(Pl$, Y%, Z% - Y%)ã IF Z% > LEN(Pl$) THEN EXIT DOã Y% = Z%ã Np% = Np% + 1ãLOOPããCLSããSetAll:ããPRINT "Input your longitude, in degrees west of Greenwich, as"ãPRINT "accurately as possible. Use negative numbers if east of Greenwich."ããINPUT "Longitude (w)"; LonãLonCorr = 43200# - EqTi + 240# * Lon - TEqunããPRINTãPRINT "Hit if no change needed, else type new date and/or time."ãON ERROR GOTO ErrtrapããPRINT "Current date "; DATE$ãINPUT "Changed date"; D$ãIF LEN(D$) = 10 AND D$ > "01" AND D$ < "13" THENã DATE$ = D$ã PRINT "Change made"ãELSEã PRINT "Date unchanged"ãEND IFãPRINTãPRINT "Current time "; TIME$ãINPUT "Changed time"; T$ãIF LEN(T$) = 8 AND T$ > "00" AND T$ < "24" THENã TIME$ = T$ã PRINT "Change made"ãELSEã PRINT "Time unchanged"ãEND IFãON ERROR GOTO 0ããPRINTãPRINT "Enter time-zone to which computer clock is set, as difference,"ãPRINT "in hours, from GMT/UT. E.g. for EST, enter -5."ãINPUT "Time Zone Offset"; TzãTz = 3600# * TzããKonst = LonCorr + Factor * (Offset + Tz)ããSetAlarm:ããPRINTãPRINT "Hit if sidereal alarm is not to be set, else enter time."ãINPUT "Sidereal alarm time (HH:MM:SS)"; At$ãIF LEN(At$) = 8 THENã Al& = Secs&(At$)ã PRINT "Alarm Set"ãELSEã Al& = -1ã PRINT "Alarm not set"ãEND IFãAlCount% = Np% + 1ããPRINTãPRINT "Enable sidereal time beeps? (y/N) ";ãDOã K$ = LCASE$(INKEY$)ãLOOP UNTIL K$ = "y" OR K$ = "n" OR K$ = CHR$(13)ãIF K$ = CHR$(13) THEN K$ = "n"ãPRINT K$ãBp% = (K$ = "y")ããCALL Dely(.5)ããCLSãPRINT "Upper display is computer clock, showing regular civil time."ãPRINTãPRINT "Lower display shows your local sidereal time, i.e. the Right"ãPRINT "Ascensions of objects currently on the meridian of your sky."ãPRINTãPRINT "Press 'Q' key to terminate displays."ããLOCATE 12, 20ãPRINT " Local civil time:";ãLOCATE 14, 20ãPRINT "Local sidereal time:";ããN& = 0ãDt$ = ""ãTm$ = ""ãDOã IF TIME$ <> Tm$ THENã Tm$ = TIME$ã LOCATE 12, 42ã PRINT Tm$;ã END IFã IF DATE$ <> Dt$ THENã Dt$ = DATE$ã K = Factor * Dte#(Dt$) - Konstã END IFã Num& = INT(Factor * TIMER + K)ã IF Num& <> N& THENã N& = Num&ã Junk% = DivMult%(86400)ã IF Num& = Al& THENã AlCount% = 0ã END IFã H% = DivMult%(3600)ã M% = DivMult%(60)ã T$ = Sting$(H%) + ":" + Sting$(M%) + ":" + Sting$(CINT(Num&))ã LOCATE 14, 42ã PRINT T$;ã IF Bp% THENã IF PLAY(0) = 0 AND AlCount% > Np% THENã PLAY "MBMST255L10"ã IF Num& MOD 10 <> 0 THENã PLAY "O3C"ã ELSEIF Num& = 0 THENã PLAY "O4C"ã ELSEã PLAY "O3E"ã END IFã END IFã END IFã END IFã IF AlCount% <= Np% THENã IF PLAY(0) < 10 THENã PLAY P$(AlCount%)ã AlCount% = AlCount% + 1ã END IFã END IFãLOOP UNTIL LCASE$(INKEY$) = "q"ããLOCATE 12, 20ãPRINT " ";ãLOCATE 14, 20ãPRINT "'Q' Key pressed. Displays ended."ããCALL Dely(1)ããCLSãPRINT "1. Reset alarm and/or beeps"ãPRINT "2. Reset all variables"ãPRINT "3. End program"ãPRINTãPRINT "Choose by number (1 - 3) : ";ããDOã K$ = INKEY$ãLOOP UNTIL K$ >= "1" AND K$ <= "3"ãPRINT K$ããSELECT CASE VAL(K$)ã CASE 1ã GOTO SetAlarmã CASE 2ã PRINTã GOTO SetAllãEND SELECTããPRINTãPRINT "Program terminated"ããENDããErrtrap:ã BEEPã PRINT "**** Improperly entered data ****"ã PRINT "No ";ã RESUME NEXTããSUB Dely (N!)ã Tim! = TIMERã DOã Ti2! = TIMER - Tim!ã IF Ti2! < 0 THEN Tim! = Tim! - 86400!ã LOOP UNTIL Ti2! > N!ãEND SUBããFUNCTION DivMult% (Div&)ã Q% = INT(Num& / Div&)ã Num& = Num& - Div& * Q%ã DivMult% = Q%ãEND FUNCTIONããFUNCTION Dte# (Dat$)ã Y% = VAL(RIGHT$(Dat$, 4))ã M% = VAL(LEFT$(Dat$, 2))ã D% = VAL(MID$(Dat$, 4, 2))ã IF M% > 2 THENã M% = M% - 3ã ELSEã M% = M% + 9ã Y% = Y% - 1ã END IFã X = 86400# * (365& * Y% + Y% \ 4 + CINT(30.6 * M%) + D%)ã Dte# = XãEND FUNCTIONããFUNCTION Secs& (TS$)ã H% = VAL(LEFT$(TS$, 2))ã M% = VAL(MID$(TS$, 4, 2))ã S% = VAL(RIGHT$(TS$, 2))ã Ti& = 3600& * H% + 60& * M% + S%ã Secs& = Ti&ãEND FUNCTIONããFUNCTION Sting$ (X%)ã S$ = RIGHT$(STR$(X% + 100), 2)ã Sting$ = S$ãEND FUNCTIONãDavid O. Williams 2 DIGIT YEARS david.williams@ablelink.org 03-10-00 (20:19) QB, QBasic, PDS 60 2197 2DIG_YR.BAS ' 2dig_yr David O. Williams 2000ãã' E-mail: david.williams@ablelink.orgãã' Public Domain. No cost. No warranty. (But I think it is right!)ãã' Program is explained in PRINT statments below.ãããDEFINT A-ZãDECLARE FUNCTION LongYear (X)ãCLSããPRINT "This program demonstrates present-centred two-digit year dating."ãPRINTãPRINT "For many purposes, dates more than twenty or thirty years into"ãPRINT "either the past or the future are virtually never encountered."ãPRINT "It is therefore possible to use just two digits to represent"ãPRINT "the year, provided they are always interpreted in the context"ãPRINT "of the present date. For example, in the year 2000, the digits"ãPRINT "'75' would be interpreted as meaning the year 1975. But in"ãPRINT "2050, the same two digits would mean the year 2075."ãPRINTãPRINT "To perform this interpretation, this program includes a function"ãPRINT "called LongYear. If the argument that is passed into this"ãPRINT "function is an integer between zero and 99, inclusive, so it"ãPRINT "can be a two-digit year, the LongYear function takes a value"ãPRINT "that is between (P-49) and (P+50), inclusive, where P is the"ãPRINT "*present* year, as shown by the computer's internal calendar,"ãPRINT "and the right two digits of the function output are the same as the"ãPRINT "two digits of the input argument."ãPRINTãPRINT "To demonstrate this function, the following loop allows you to"ãPRINT "input two-digit years, and will output them in four-digit format."ãPRINT "Enter any negative number to quit."ãPRINTããDOã INPUT "Year"; Yã IF Y < 0 THEN EXIT DOã PRINT LongYear(Y)ãLOOPããCLSãPRINT "In order to use this dating system in any program, just use"ãPRINT "two digits for the year-number in any date. However, before any"ãPRINT "calculations, comparisons, etc., are done that involve dates,"ãPRINT "pass the two-digit values through the LongYear function, and"ãPRINT "do the calculations with the four-digit outputs of the function."ãPRINTããENDããFUNCTION LongYear (X)ã Y = Xã IF Y < 100 AND Y >= 0 THENã Y = ((VAL(RIGHT$(DATE$, 4)) + 50 - Y) \ 100) * 100 + Yã END IFã LongYear = YãEND FUNCTIONãWayne Henderson CALENDAR DATE TO JULIAN NUMBER whenders@becon.org 03-15-00 (22:08) QB, QBasic, PDS 331 13392 LOCALJD.BAS 'ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»ã'º Calendar date to Julian Number & vice-versa; input TIME as local (H/M/S) ºã'º Program gives the correct Julian Day when local DATE/TIME is entered and ºã'º the correct local DATE/TIME when a Julian Number is entered. ºã'º by Wayne Henderson___March 16th, 2000 (Thu)___7:00 am, EST___(2,451,620) ºã'ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍͼã'ãDEFINT A-ZãDECLARE FUNCTION EDT (Y) 'rename these two FUNCTIONs as required (see EDT)ãDECLARE FUNCTION EST (Y) 'Change all occurrences of EDT & EST accordingly.ãDECLARE FUNCTION Leap (Year)ãDECLARE FUNCTION Weekday (Month, Day, Year)ãDECLARE FUNCTION To12 (Hour)ãDECLARE FUNCTION MTRIM$ (a$, b$)ãDECLARE FUNCTION Julian# (Year, Month, Day, utc#)ãDECLARE SUB ParseInp (a$)ãDIM Month$(12), m(12), D$(6): COLOR 7, 0ãtz = 5: dtz = 4 'EST/EDT correction west of UT, change as required.ã 'Set dtz to same value as tz if Daylight Saving Time isã 'not observed in the area (for example, Saskatchewan).ãFOR c = 1 TO 12: READ Month$(c): NEXTãFOR c = 1 TO 12: READ m(c): NEXT: FOR c = 0 TO 6: READ D$(c): NEXTãDATA January,February,March,April,May,June,JulyãDATA August,September,October,November,DecemberãDATA 30,28,31,30,31,30,31,31,30,31,30,31,Sun,Mon,Tue,Wed,Thu,Fri,Satã'ãcL$ = LTRIM$(RTRIM$(COMMAND$)) 'if no CMD Line, thenãIF cL$ = "" THEN cL$ = DATE$ + " " + TIME$: v = 1 'calculate current JDãIF INSTR(cL$, "?") THEN GOTO helpãIF INSTR(cL$, " ") = 0 AND VAL(cL$) > 12 THEN 'a Julian Number was enteredã IF VAL(cL$) < 2299161# THENã PRINTã PRINT "Before Gregorian Calendar."ã ENDã ELSEIF VAL(cL$) > 3000000# THENã PRINTã PRINT "Invalid JD, too high."ã ENDã END IFã 'Julian Day to calendar date by Peter Baum (pbaum@capecod.net)ã jd# = VAL(cL$): s# = INT(jd# - 1721118.5#)ã h# = jd# - 1721118.5# - s#: m# = 100 * s# - 25ã a& = m# \ 3652425: b = a& - a& \ 4: Y& = (100 * b + m#) \ 36525ã c = b + s# - 365 * Y& - Y& \ 4: Month = (5 * c + 456) \ 153ã D# = c - FIX((153 * Month - 457) / 5) + h#: Year = Y&ã IF Month > 12 THEN Year = Year + 1: Month = Month - 12ã IF Leap(Year) THEN m(2) = 29ã h# = (D# - INT(D#)) * 24: Day = INT(D#)ã min! = (h# - INT(h#)) * 60: hr = INT(h#)ã sec = CINT((min! - INT(min!)) * 60): min = INT(min!)ã IF sec = 60 THEN sec = 0: min = min + 1ã IF min = 60 THEN min = 0: hr = hr + 1ã IF hr = 24 THEN hr = 0: Day = Day + 1ã IF Day > m(Month) THEN Day = 1: Month = Month + 1ã IF Month > 12 THEN Month = 1: Year = Year + 1ã EDTbegins! = VAL(STR$(4 + EDT(Year) / 100) + "07") 'GMT at EDT switchoverã ESTbegins! = VAL(STR$(10 + EST(Year) / 100) + "06") 'same for ESTã 'change "07" and "06" toã ' "10" and "09" for PST (an example)ã IF hr < 10 THEN tmp$ = "0" ELSE tmp$ = ""ã now! = VAL(STR$(Month + Day / 100) + tmp$ + LTRIM$(STR$(hr)))ã IF now! >= EDTbegins! AND now! < ESTbegins! THEN adj = dtz ELSE adj = tzã hr = hr - adj: IF hr < 0 THEN hr = hr + 24: Day = Day - 1ã IF Day < 1 THENã IF Month = 1 THENã Month = 12ã Year = Year - 1ã ELSEã Month = Month - 1ã END IFã Day = m(Month)ã END IFã PRINT : PRINT cL$; " = "; Month$(Month); " ";ã IF Day < 10 THEN PRINT "0";ã PRINT LTRIM$(STR$(Day)); ","; Year; "(";ã PRINT D$(Weekday(Month, Day, Year)); ") "ã PRINT LTRIM$(STR$(To12(hr2))); ":"; : IF min < 10 THEN PRINT "0";ã PRINT LTRIM$(STR$(min)); ":"; : IF sec < 10 THEN PRINT "0";ã PRINT LTRIM$(STR$(sec)); " "; ap$;ã IF adj = 4 THEN PRINT " (EDT)"; ELSE PRINT " (EST)";ã utc# = hr + adj + min / 60 + sec / 3600ã IF utc# >= 24 THEN utc# = utc# - 24: v$ = "tomorrow" ELSE v$ = ""ã PRINT " UT ="; utc#; v$ãELSE 'a calendar DATE and, optionally, a TIME was enteredã a$ = cL$ 'work with a$ instead of changing cL$ã FOR c = 1 TO 5: PRINT : NEXTã IF v THENã PRINTã PRINT CHR$(34); cL$; CHR$(34); " Using System DATE/TIME (?=help)"ã END IFã CALL ParseInp(a$)ã 'Scan modified COMMAND line and retrieve numerical valuesã a$ = MTRIM$(a$, "__"): c = 1ã WHILE a$ <> ""ã IF VAL(a$) > 32767 THEN GOTO errerã TD(c) = VAL(a$): a$ = MID$(a$, INSTR(a$, "_") + 1)ã PRINT TD(c), "a$="; CHR$(34); a$; CHR$(34)ã c = c + 1ã WENDã Month = TD(1): Day = TD(2): Year = TD(3)ã hr = TD(4): min = TD(5): sec = TD(6)ã IF hr > 23 OR min > 59 OR sec > 59 THEN GOTO errerã IF Year >= 0 AND Year < 100 THEN Year = 1900 + Yearã IF Year < 1583 OR Year > 9999 THEN GOTO errerã m(2) = 28 - Leap(Year) 'Set days in Feb. if YEAR is validã IF Month < 1 OR Month > 12 THEN GOTO errer 'Check for valid monthã IF Day < 1 OR Day > m(Month) THEN GOTO errer 'Check for valid dayã 'ã 'Example of using the remaining subprograms: To12, Weekday, EDT, ESTã PRINT : PRINT "("; D$(Weekday(Month, Day, Year)); ") ";ã PRINT Month$(Month); STR$(Day); ","; Year;ã EDTbegins! = VAL(STR$(4 + EDT(Year) / 100) + "02")ã ESTbegins! = VAL(STR$(10 + EST(Year) / 100) + "02")ã IF hr < 10 THEN tmp$ = "0" ELSE tmp$ = ""ã now! = VAL(STR$(Month + Day / 100) + tmp$ + LTRIM$(STR$(hr)))ã IF now! >= EDTbegins! AND now! < ESTbegins! THEN adj = dtz ELSE adj = tzã IF m(2) = 29 THEN PRINT " {Leap Year} ";ã IF c > 4 THEN 'a TIME was enteredã IF ap$ = "am" AND hr = 12 THEN hr = 0 'to 24-hrã IF ap$ = "pm" AND hr < 12 THEN hr = hr + 12ã h$ = STR$(To12(hr))ã m$ = LTRIM$(STR$(min)): IF LEN(m$) = 1 THEN m$ = "0" + m$ã s$ = LTRIM$(STR$(sec)): IF LEN(s$) = 1 THEN s$ = "0" + s$ã PRINT h$ + ":" + m$ + ":" + s$; " "; ap$;ã IF adj = dtz THEN PRINT " EDT" ELSE PRINT " EST"ã IF ap$ = "am" AND hr = 12 THEN hr = 0ã h$ = LTRIM$(STR$(hr)): IF LEN(h$) = 1 THEN h$ = "0" + h$ã m$ = LTRIM$(STR$(min)): IF LEN(m$) = 1 THEN m$ = "0" + m$ã s$ = LTRIM$(STR$(sec)): IF LEN(s$) = 1 THEN s$ = "0" + s$ã PRINT h$; ":"; m$; ":"; s$; " ";ã END IFã 'set local time to UT to calculate JDã utc# = hr + min / 60 + sec / 3600 + adjã IF h$ = "" THEN utc# = 12: w$ = "Setting " ELSE w$ = ""ã jul# = Julian#(Year, Month, Day, utc#)ã IF utc# >= 24 THENã utc# = utc# - 24: v$ = " tomorrow"ã ELSEã v$ = ""ã END IFã PRINT "("; w$; "UT:"; STR$(utc#); v$; ") ="; jul#ãEND IFã'ãhelp:ãIF INSTR(cL$, "?") THENã PRINT : COLOR 14, 0: PRINT "SYNTAX:";ã COLOR 3: PRINT " jd m d yyyy"; : COLOR 7: PRINT "[";ã COLOR 3: PRINT " h/m/s"; : COLOR 7: PRINT "]";ã COLOR 3: PRINT " or jd Julian# (>= 2,299,161)": COLOR 7ã PRINT " m = 1 or 2 digits, or at least 3 letters of the month name"ã PRINT " d = 1 or 2 digits"ã PRINT " y = 4 digits (2 digits may be used for years in the 1900s)"ã PRINT : COLOR 15ã PRINT "If a TIME is entered it must follow these conventions:"ã COLOR 7ã PRINT " h = 1 or 2 digits (24-hour or 12-hour TIME [AM/PM])"ã PRINT " m = 1 or 2 digits (m may be left out if it is zero)"ã PRINT " s = 1 or 2 digits (s may be left out if it is zero)"ãEND IFãCOLOR 3: SYSTEMãerrer: PRINT : PRINT "Error: "; cL$; Month; Day#; Year; hr; min; secãSYSTEMã'NOTE: The statements that show it working should be removed. They makeã' understanding the program a bit easier.ãã'These FUNCTIONS are derived from the Weekday(Month,Day,Year) function byã'substituting known values for Month and Day. It could also be written as:ã'ã' FUNCTION EDT (Year)ã' Day = 1 'start at the first of April and search for a Sundayã' WHILE Weekday (4, Day, Year) <> 0 '4 = April, 0 = Sundayã' Day = Day + 1ã' WEND: EDT = Dayã' END FUNCTIONã'ã'...but calling one FUNCTION from another reduces portability (both must beã'included even if only one is required by the program). EST() and EDT() mayã'both be moved to another program module since they are written as stand-ã'alone FUNCTIONs.ã'ã'EXAMPLE: Find the date of Daylight Saving Time in Holland, UT + 2,ã'where the change from CET (Central European Time, UT + 1) occurs onã'the last Sunday in March (at 3:00 am).ã'ã'from the Weekday FUNCTION:ã' tmp = (14 - Month) \ 12: y = Year - tmp: m = Month - 2 + 12 * tmpã' Weekday = (Day + y + y \ 4 - y \ 100 + y \ 400 + (31 * m) \ 12) MOD 7ã'ã'tmp = (14 - 3) \ 12 '= zeroã'y = Year - tmp '= Yearã'm = Month - 2 + 12 * tmp '= 3-2+12*0 = 1ã'(31 * m) \ 12 '(31 * 1) \ 12 = 2ã'ã'hence:ã'ã'FUNCTION CEDT (y&)ã' c = 25 'Start on the 25th of March.ã' WHILE (c + y& + y& \ 4 - y& \ 100 + y& \ 400 + 2) MOD 7 <> 0ã' c = c + 1ã' WEND: CEDT = c 'c is the date of the last Sunday in Marchã'END FUNCTIONã'ã'EXAMPLE 2: Find MST for the year 2001 (UT - 7 hours, last Sundayã' in October at 2:00 am MDT)ã'ã'tmp = (14 - 10) \ 12 '= 0ã'y = 2001 - 0 '= 2001ã'm = Month - 2 + 12 * tmp '= 10-2+12*0 = 8ã'(31 * m) \ 12 '(31 * 8) \ 12 = 20ã'ã' c = 25 'Start on Oct. 25thã' WHILE (c + y& + y& \ 4 - y& \ 100 + y& \ 400 + 20) MOD 7 <> 0ã' ... etc:ã'ã'same as EST, except tz would be set to 7, insteadã'of 5 (and dtz = 6 vs. 4) in the Main Module and theã'FUNCTION renamed to 'FUNCTION MST (y)'. Search andã'Change all occurrences of EST with MST and EDT with MDT.ã'ã'finally, here is the FUNCTION:ã'ãFUNCTION EDT (Y)ã c = 1 'Get date of first Sunday in April (EDT begins)ã WHILE (c + Y + Y \ 4 - Y \ 100 + Y \ 400 + 5) MOD 7 <> 0ã c = c + 1ã WEND: EDT = cãEND FUNCTIONããFUNCTION EST (Y) STATIC 'change FUNCTION Name to your timezoneã c = 25 'Get date of last Sunday in October (EST begins)ã WHILE (c + Y + Y \ 4 - Y \ 100 + Y \ 400 + 20) MOD 7 <> 0ã c = c + 1ã WEND: EST = cãEND FUNCTIONãã'by Meeus, all values are integers, except JD.ã'y = y + (m < 3): m = m - 12 * (m < 3): a = y \ 100: b = 2 - a + a \ 4ã'JD = INT(365.25 * (y + 4716)) + INT(30.6001 * (m + 1)) + d + b - 1524ã'ã'from Pacific Exchange, UBC, Canada.ãFUNCTION Julian# (Year, Month, Day, utc#)ã Y& = Year: D# = Day: tmp# = 367 * Y& - 7 * (Y& + (Month + 9) \ 12) \ 4ã tmp# = tmp# - 3 * ((Y& + (Month - 9) / 7) \ 100 + 1) \ 4ã Julian# = tmp# + 275 * Month \ 9 + D# + 1721028.5# + utc# / 24ãEND FUNCTIONããFUNCTION Leap (Y) 'from the ABC Archives, author unknown.ã Leap = Y MOD 4 = 0 AND (Y MOD 100 = 0 IMP Y MOD 400 = 0)ãEND FUNCTIONãã'remove duplicated B$ in A$, "--1---2----3----" becomes "1-2-3-" if b$ = "--"ãFUNCTION MTRIM$ (a$, b$)ã IF a$ = "" OR b$ = "" THEN EXIT FUNCTIONã WHILE LEFT$(a$, 1) = LEFT$(b$, 1) 'remove leading duplicatesã a$ = MID$(a$, 2)ã WENDã k = INSTR(a$, b$): flag = 0ã WHILE kã a$ = LEFT$(a$, k) + MID$(a$, k + 2)ã k = INSTR(a$, b$): PRINT CHR$(34); a$; CHR$(34); " ";ã IF flag = 0 THEN 'Remove this IF...ELSE...ENDIF structureã flag = 1ã PRINT "start MTRIM$"ã ELSEã PRINT "working"ã END IFã WENDã PRINT "Done: a$="; CHR$(34); a$; CHR$(34): PRINTã MTRIM$ = a$ãEND FUNCTIONããSUB ParseInp (a$)ã SHARED ap$ã ap$ = "": dt$ = "JANFEBMARAPRMAYJUNJULAUGSEPOCTNOVDEC"ã PRINT CHR$(34); a$; CHR$(34); " Original input"ã IF a$ <> COMMAND$ THENã a$ = UCASE$(a$): PRINT CHR$(34); a$; CHR$(34); " to UPPERCASE"ã END IFã FOR c = 1 TO 34 STEP 3ã k = INSTR(a$, MID$(dt$, c, 3))ã IF k THENã MID$(a$, k) = STR$(c \ 3 + 1)ã PRINT CHR$(34); a$; CHR$(34);ã PRINT " Month-name detected, replaced with Number"ã END IFã NEXTã FOR c = 1 TO LEN(a$)ã ascii = ASC(MID$(a$, c, 1))ã IF ascii < 48 OR ascii > 57 AND ascii <> 80 AND ascii <> 65 THENã MID$(a$, c, 1) = " "ã END IFã NEXT: PRINT CHR$(34); a$; CHR$(34); " Nonessentials replaced"ã a$ = LTRIM$(RTRIM$(a$)): PRINT CHR$(34); a$; CHR$(34); " squeezed";ã k$ = ""ã IF RIGHT$(a$, 1) = "A" THENã ap$ = "am"ã PRINT " (AM detected)"ã ELSEIF RIGHT$(a$, 1) = "P" THENã ap$ = "pm"ã PRINT " (PM detected)"ã ELSEã k$ = "_"ã a$ = a$ + k$ã PRINTã END IFã FOR c = 1 TO LEN(a$)ã ascii = ASC(MID$(a$, c, 1))ã IF ascii < 48 OR ascii > 57 THENã MID$(a$, c, 1) = "_"ã END IFã NEXTã PRINT CHR$(34); a$; CHR$(34); " All ALPHA replaced";ã IF k$ <> "" THENã PRINT ", "; CHR$(34); k$; CHR$(34); " added."ã ELSEã PRINTã END IFãEND SUBããFUNCTION To12 (Hour) 'changes 24-hour format to 12-hour, AM/PMã SHARED ap$: IF Hour = 24 THEN Hour = 0ã IF Hour < 12 THEN ap$ = "am" ELSE ap$ = "pm"ã IF Hour = 0 THEN Hour = 12ã IF Hour > 12 THEN To12 = Hour - 12 ELSE To12 = HourãEND FUNCTIONãã'from the ABC Archives, author unknown.ãFUNCTION Weekday (Month, Day, Year)ã tmp = (14 - Month) \ 12: Y = Year - tmp: m = Month - 2 + 12 * tmpã Weekday = (Day + Y + Y \ 4 - Y \ 100 + Y \ 400 + (31 * m) \ 12) MOD 7ãEND FUNCTIONãDavid Williams JULIAN DAY <> GREGORIAN DATE david.williams@capcanada.com 12-26-00 (10:25) QB, QBasic, PDS 88 1698 JULGREG.BAS 'Julian Day <> Gregorian date interconverterã'David Williams 2000ã'david.williams@ablelink.orgã'Public Domain. No price. No warrantyãDECLARE FUNCTION Jday& (Y&, M&, D&)ãDECLARE SUB Greg (J&, Y&, M&, D&)ãDECLARE FUNCTION DM& (V&)ãDECLARE FUNCTION DM2& (V&)ãDEFLNG A-ZãCOMMON SHARED N, ZãZ = 1721120ãCLSãStart:ãPRINT "1. Gregorian to Julian"ãPRINT "2. Julian to Gregorian"ãPRINTãPRINT "Which? (1 or 2): ";ãDOã K$ = INKEY$ãLOOP UNTIL K$ = "1" OR K$ = "2"ãPRINT K$ãPRINTãIF K$ = "1" THENã DOã INPUT "Year, Month, Day (YYYY,MM,DD including commas)"; Y, M, Dã J = Jday(Y, M, D)ã CALL Greg(J, P, Q, R)ã IF P = Y AND Q = M AND R = D THEN EXIT DOã BEEPã PRINT "Illegal Gregorian date!"ã LOOPã PRINT "Julian Day is"; JãELSEã INPUT "Julian Day"; Jã CALL Greg(J, Y, M, D)ã PRINT "Gregorian date (Y,M,D) is: "; Y; ","; M; ","; DãEND IFãPRINTãPRINT "Another? (y/n) ";ãDOã K$ = LCASE$(INKEY$)ãLOOP UNTIL K$ = "y" OR K$ = "n"ãPRINT K$ãIF K$ = "y" THENã PRINTã GOTO StartãEND IFãENDããFUNCTION DM (V)ã Q = N \ Vã N = N MOD Vã DM = QãEND FUNCTIONããFUNCTION DM2 (V)ã Q = N \ Vã IF Q = 4 THEN Q = 3ã N = N - Q * Vã DM2 = QãEND FUNCTIONããSUB Greg (J, Y, M, D)ã N = J - Zã A = 400 * DM(146097) + 100 * DM2(36524) + 4 * DM(1461) + DM2(365)ã B = 5 * DM(153) + 2 * DM(61) + DM(31)ã IF B < 10 THENã M = B + 3ã Y = Aã ELSEã M = B - 9ã Y = A + 1ã END IFã D = N + 1ãEND SUBããFUNCTION Jday (Y, M, D)ã IF M > 2 THENã B = M - 3ã A = Yã ELSEã B = M + 9ã A = Y - 1ã END IFã L = A \ 4 - A \ 100 + A \ 400ã C = CLNG(30.6 * B)ã Jday = Z + 365 * A + L + C + D - 1ãEND FUNCTIONãRichard Kelly Micro-Timer Newson@37.com 06-15-01 (19:34) QB, QBasic, PDS 53 2007 Qb-timer.bas'Author: Richard Kelly 05/27/2001 E-Mail: Newson@37.comã'ã'This program is released into the Public Domain. It should workã'fine in Q-BASIC, QuickBASIC, PDS, or FirstBASIC.ã'ã'It demonstrates a "Microtimer" that's supported in several BASICã'languages.ã'ã'The "moving ball routine" is purposely "un-fancy", as I was moreã'concerned with making the demo fast and simple. This way, there'sã'less code for the user to go through to figure out the Timerã'routine. I hope this routine is useful to you. :-)ã'ã'Special thanks to Edward Di Geronimo Jr. and Eric Carr.ãã'Draw the ball, then "GET" itãDIM A%(100), B%(100): SCREEN 9, 0, 1, 0: COLOR 7: CLS : GET (0, 0)-(12, 8), A%ãCIRCLE (6, 4), 6, 7: PAINT (6, 2), 7, 7: CIRCLE (6, 4), 4, 15: PAINT (6, 3), 15, 15ãGET (0, 0)-(12, 8), B%: CLS : SCREEN 9, 0, 0, 0ããX0 = 316: Y0 = 0: X1 = X0: Y1 = Y0: Y = 0ãã'If you want 60hz, use "N& = 19886"ããN& = 29830 'Reprogram the timer to 40hzãLB& = N& AND &HFF 'instead of 18.2 (for 40 framesãHB& = (N& / 256) AND &HFF'per second.)ãOUT &H43, &H3C: OUT &H40, LB&: OUT &H40, HB&ããBLOOP:ãDEF SEG = 0ãPOKE (1132), 0 'Sets PEEK(1132) to Zero. (1132)ãPUT (X1, Y1), A%, PSET 'is the Microtimer, so this willãPUT (X0, Y0), B%, PSET '*not* reset the system clockãX1 = X0: Y1 = Y0 'to Midnight.ãYY = 0: IF Y0 + Y > 340 THEN Y = -Y: YY = 1ãY = Y + 1: IF Y = 0 AND YY = 1 THEN GOTO FINISãY0 = Y0 + YãROUTINE:ãI$ = INKEY$: IF I$ > "" THEN GOTO FINISãIF PEEK(1132) < 1 THEN GOTO ROUTINE 'Don't go to the next frame untilãWAIT 936, 8 'a certain time has elapsed.ãGOTO BLOOPããFINIS:ãSCREEN 0, 0, 0, 0: WIDTH 80ãN& = 65535 'Program the timer back toãLB& = N& AND &HFF '18.2hz before exiting!ãHB& = (N& / 256) AND &HFFãOUT &H43, &H3C: OUT &H40, LB&: OUT &H40, HB&ãCLEAR 'need to have this if reprograming the timerãENDããAntoni Gual DOS Timer using PIT agual@eic.ictnet.es 03-15-02 ( : ) QB, Qbasic, PDS, PB 199 6063 Timerlib.basDECLARE FUNCTION Delay% (d AS ANY)ãDECLARE FUNCTION XTimerD& ()ãDECLARE FUNCTION XTimerW& ()ã'--------------------------------------------------------------------------ã'Microsecond timer library.Using DOS timer + PITã'By Antoni Gual agual@eic.ictnet.es 3/2002ã'--------------------------------------------------------------------------ã'THE PROBLEM:ã'To delay for intervals smaller than the QB'S TIMER resolution, a solution isã'to do a delay loop with parameters calculated on the speed of the pc.ã'Unfortunately this calibration gives normally poor results when the user'sã'pc is 'much faster, or slower than the test pc.ãã'HOW DOES IT WORK:ã'The PIT (Programmable Interval Timer) was the chip that keped the paces inã'the software timer, the speaker beeps and the DRAM refresh.Today itsã'functions are emulated in the chipset.ã'A backwards counter in the PIT starts at 65535 counts at a frequency ofã'1,193,181 Hz. When it gets zero resets itself and issues an interruptã'(it happens 18,2 times per second), used by DOS to update the software timer.ã'At any time you can use the PIT register reading to increase accuracy of theã'DOS timer reading.ãã'WINDOWS WARNING:ã'In a DOS box in Win32, almost everything is emulated. The DOS timer updateã'is not done at the same moment when PIT counter becomes 0, so you can haveã'low readings (1/18.2 second lower than it should be)ãã'So I present here two routines XTimerD& and XTimerW&ã'Both give times in PIT units (1/1193181 of second), the first one is fasterã'but will give incorrect readings in Windows. The second corrects the problemã'but it's 50% to 100% slower.ã'Both routines are able to time a maximum delay of 29.99 minutes, limited byã'the capacity of the LONG variables used.ããã'The Delay routine is the base to implement your delays.It deals with timerã'rollovers.You can nest delays by using diferent delay vars.ã'----------------------------------------------------------------------------ãã'You can use these constants to convert XTimer readings to secondsãCONST clockfreq# = 1193181.666# 'PIT clock frequencyãCONST secstick# = 1 / clockfreq#ããTYPE delaytypeã start AS LONGã ends AS LONGãEND TYPEããCLSãxx$ = "|/\-"ã'----------------speed test-----------------------------------------ãããããnt = 3000ãFOR j = 1 TO 3ãdtimer& = 0ãltimer& = XTimerD&ã'call xtimer nt timesãFOR i% = 1 TO ntã tim& = XTimerD&ã dtimer& = dtimer& + tim& - ltimer&ã SWAP ltimer&, tim&ãNEXTãã'time the empty loopãdtimer1& = 0ãxtimer& = XTimerD&ãlt1& = 1&ããFOR i% = 1 TO ntã tim& = 1&ã dt1& = dt1& + tim& - lt1&ã SWAP lt1&, tim&ãNEXTãã'substract empty loop timeãdtimer& = dtimer& - XTimerD& + ltimer&ãPRINT USING "A call to XtimerD needs ##.#### milliseconds(Averaged in #### calls)"; dtimer& * secstick# * 1000 / nt; ntãNEXTãã'3 testsãFOR j = 1 TO 3ãdtimer& = 0ãltimer& = XTimerW&ã'call xtimer nt timesãFOR i% = 1 TO ntã tim& = XTimerW&ã dtimer& = dtimer& + tim& - ltimer&ã SWAP ltimer&, tim&ãNEXTãã'time the empty loopãdtimer1& = 0ãxtimer& = XTimerW&ãlt1& = 1&ããFOR i% = 1 TO ntã tim& = 1&ã dt1& = dt1& + tim& - lt1&ã SWAP lt1&, tim&ãNEXTãã'substract empty loop timeãdtimer& = dtimer& - XTimerW& + ltimer&ããPRINT USING "A call to XtimerD needs ##.#### milliseconds(Averaged in #### calls)"; dtimer& * secstick# * 1000 / nt; ntãNEXTãã'--------------------------implementing a delay -------------------------ããPRINT "delaying for 0.5 seconds ";ãa = 0ãT& = XTimerW&ã'--------to implement a delay first dim a variable of delaytype----------ãDIM d AS delaytypeãã'Then preset it with .start=-1 and .ends=delay time in PIT ticksããd.start = -1: d.ends = .5 * clockfreq#ãã'--------------------call delay function to initialize it-----------------ãdummy = Delay%(d)ãã'-----------------And loop until a delay call returns <>0----------------ãDOã 'do anything you want during the delay loop!!!!!ã a = (a + 1)ã LOCATE , 26: PRINT MID$(xx$, (a AND 3) + 1, 1);ãLOOP UNTIL Delay%(d)ãã'-----------------------------delay ended---------------------------------ãPRINT USING "Delay was called #### times. #.##### secs "; a; (XTimerW& - T&) * secstick#ãããFUNCTION Delay% (d AS delaytype)ã'pass a start of -1 and a time into end to initialize delayã'Keep on calling it until it returns -1ããCONST tr& = &H3FFFFFFF, tc& = &H40000000ãIF d.start = -1 THENã d.start = XTimerW&ã T& = d.endsã d.ends = (d.start AND tr&) + (d.ends AND tr&)ã c% = ((d.start AND tc&) = tc&) + ((T& AND tc&) = tc&) + ((d.ends AND tc&) = tc&)ã IF c% AND 1 THEN d.ends = d.ends OR tc&ã EXIT FUNCTIONãELSEã T& = XTimerW&ã IF d.ends > d.start THENã IF T& >= d.ends THEN Delay = -1: EXIT FUNCTIONã ELSEã IF T& < d.start THENã IF T& >= d.ends THEN Delay = -1: EXIT FUNCTIONã END IFã END IFãEND IFãEND FUNCTIONããFUNCTION XTimerD&ã'returns time in PIT ticks modulo 29 minã'for use in plain DOS. In Windows some readings are 1/18.2 seconds too low!ãããCONST forty = &H40ãCONST byte = 256&ã DEF SEG = fortyã IF NOT ini% THEN OUT &H43, &H0: ini% = -1ã DOã t3& = PEEK(&H6D) AND &H7Fã t2& = PEEK(&H6C)ã t0& = INP(forty)ã t1& = INP(forty)ã LOOP UNTIL t2& = PEEK(&H6C)ã XTimerD& = -t0& + byte * (-t1& + byte * (1& + t2& + byte * t3&))ãEND FUNCTIONããFUNCTION XTimerW& STATICã'returns time in PIT ticks modulo 30 min ã'Slow but safe to use in a DOS box in Windows as in plain DOSãCONST forty = &H40ãCONST byte = 256&ã DEF SEG = fortyã IF NOT ini% THEN OUT &H43, &H0: ini% = -1ã DOã t3& = PEEK(&H6D)ã t2& = PEEK(&H6C)ã t0& = INP(forty)ã t1& = INP(forty)ã x& = -t0& + byte * (-t1& + byte * (1& + t2& + byte * (t3& AND &H7F)))ã 'rollover!ã IF (t3& AND &H80) <> lt3& THEN EXIT DOã LOOP UNTIL x& > X1&ã SWAP x&, X1&: XTimerW& = X1&ã lt3& = t3& AND &H80ãEND FUNCTIONããDavid Williams When is Easter david.williams@ablelink.org 06-16-02 ( : ) Qbasic,QB,PDS 71 1342 Easter.bas ' EASTER.BAS ã' Calculates (Gregorian-calendar) month and day of Easter Sunday. ã ã' QBASIC code by David Williams, 2002 ã' david.williams@ablelink.org ã ã' Algorithm includes all rules for finding Easter, as ã' used in western countries. ã ãDECLARE SUB EaSun (Year%, Month%, Day%) ã ãDEFINT A-Z ã ãCLS ã ãPRINT "Easter Sunday calculator." ãPRINT ãPRINT "Hit to quit." ã ãDO ã ã PRINT ã INPUT "What year"; Y$ ã IF Y$ = "" THEN EXIT DO ã Year = VAL(Y$) ã PRINT ã ã IF Year >= 1582 THEN ã ã CALL EaSun(Year, Month, Day) ã ã IF Month = 3 THEN ã M$ = "March" ã ELSE ' Month must be 4 ã M$ = "April" ã END IF ã ã PRINT "In the year"; STR$(Year); ã PRINT ", Easter Sunday is on "; M$; STR$(Day); "." ã ã ELSE ã ã BEEP ã PRINT "Gregorian calendar not used before 1582." ã ã END IF ã ãLOOP ã ãEND ã ãSUB EaSun (Year, Month, Day) ' Finds month and day of Easter Sunday ã ã J = Year MOD 19 ã K = Year \ 100 ã L = Year MOD 100 ã M = K \ 4 ã N = K MOD 4 ã O = L \ 4 ã P = L MOD 4 ã Q = (8 * K + 13) \ 25 ã R = (19 * J + K - M - Q + 15) MOD 30 ã S = (J + 11 * R) \ 319 ã T = (2 * (N + O) - P - R + S + 32) MOD 7 ã U = R - S + T ã ã Month = (U + 90) \ 25 ã Day = (U + Month + 19) MOD 32 ã ãEND SUB ã ãDavid Williams What is the Julian Date? david.williams@ablelink.org 06-16-02 ( : ) Qbasic,QB,PDS 203 4803 Jgconv.bas 'There are already some programs of mine in the ABC archives. Maybe thisã'one should go there too. People who are interested in astronomy mayã'well find it useful.ã ã'David Williamsã ã'-------------------------------------------------ã ã' JGCONV.BASã' Julian Day and Gregorian Date interconverterã ã' David Williams. 2001ã' david.williams@ablelink.orgã ã' Program interconverts Gregorian-calendar dates (regular ones)ã' with Julian Days, a dating system used by astronomers whichã' simply counts days from a starting point in the distant past.ã ã' Note: For years before 1 C.E. (A.D.), program uses rationalizedã' calendar. Year before year 1 is year 0. Year before that isã' year -1, and so on.ã ãDECLARE SUB J2G ()ãDECLARE SUB G2J ()ãDECLARE SUB JultoGreg ()ãDECLARE SUB GregtoJul ()ãDECLARE FUNCTION Dte$ ()ãDECLARE FUNCTION DivMult% (FirstPeriod%, LastPeriod%)ã ãDEFINT A-ZãDIM SHARED Year AS INTEGER, Month AS INTEGER, Day AS SINGLEãDIM SHARED JulianDay AS DOUBLE, Num AS DOUBLEãDIM SHARED Period(1 TO 7, 1 TO 2) AS LONGã ãCONST ZeroOffset# = 1721119.5#ã' Difference between Julian and Gregorian zeroes.ã' Note: Julian Days start and end at noon UT, hence the .5ã ãDATA 146097, 400, 36524, 100, 1461, 4, 365, 1, 153, 5, 61, 2, 31, 1ã'Data are day-numbers and periods, e.g. 146097 days in 400 years.ã'First 4 pairs are days and years. Last 3 are days and months.ã ãFOR X = 1 TO 7ã FOR Y = 1 TO 2ã READ Period(X, Y)ã NEXTãNEXTã ãCLSãPRINT "Decimal fractions of Julian Days or Days of Month are allowed."ãPRINT "Gregorian Dates should be in Universal Time (GMT)."ã ãDOã PRINTã PRINT "1. Gregorian to Julian"ã PRINT "2. Julian to Gregorian"ã PRINT "3. Quit"ã PRINTã PRINT "Which? (by number) ";ã ã DOã Key$ = INKEY$ã LOOP UNTIL Key$ >= "1" AND Key$ <= "3"ã PRINT Key$ã PRINTã ã SELECT CASE Key$ã CASE "1"ã CALL G2Jã CASE "2"ã CALL J2Gã CASE "3"ã EXIT DOã END SELECTã ãLOOPã ãENDã ããFUNCTION DivMult (FirstPeriod, LastPeriod)ã' Utility function used by JultoGregã ã Total = 0ã ã FOR J = FirstPeriod TO LastPeriodã ã Quot = INT(Num / Period(J, 1))' number of periods in Num daysã ã IF Quot = 4 THENã IF J = 2 OR J = 4 THEN Quot = 3' needed for February 29ã END IFã ã Num = Num - Quot * Period(J, 1)' subtract the periods from Numã ã Total = Total + Quot * Period(J, 2)' add in the years or monthsã ã NEXT Jã ã DivMult = Total' number of years or monthsã ãEND FUNCTIONããFUNCTION Dte$ ' puts Gregorian date in standard formatã ã Dte$ = STR$(Year) + "," + STR$(Month) + "," + STR$(Day)ã ãEND FUNCTIONããSUB EaSun (Year, Month, Day) ' Finds month and day of Easter Sundayã ã J = Year MOD 19ã K = Year \ 100ã L = Year MOD 100ã M = K \ 4ã N = K MOD 4ã O = L \ 4ã P = L MOD 4ã Q = (8 * K + 13) \ 25ã R = (19 * J + K - M - Q + 15) MOD 30ã S = (J + 11 * R) \ 319ã T = (2 * (N + O) - P - R + S + 32) MOD 7ã U = R - S + Tã ã Month = (U + 90) \ 25ã Day = (U + Month + 19) MOD 32ã ãEND SUBããSUB G2J ' Gregorian to Julian packageã ã INPUT "Greg. Date (YYYY,MM,DD) (WITH commas!) "; Year, Month, Dayã ã Date1$ = Dte$ã ã CALL GregtoJulã CALL JultoGreg' Reverse conversion checks date's legalityã ã IF Date1$ = Dte$ THENã PRINTã PRINT "Julian Day is: "; JulianDayã ELSEã BEEPã PRINTã PRINT "Illegal Gregorian Date"ã END IFã ãEND SUBããSUB GregtoJul ' Does basic Gregorian to Julian conversionã ã ' Shift New Year from January 1 to March 1ã IF Month < 3 THENã Mth = Month + 9ã Yr = Year - 1ã ELSEã Mth = Month - 3ã Yr = Yearã END IFã ã Leap = INT(Yr / 4) - INT(Yr / 100) + INT(Yr / 400)ã ' leap years since Gregorian zero (March 1 in Year 0)ã ã Before = INT(30.6 * Mth + .5)ã ' days in this year (starting March 1) before present monthã ã JulianDay = ZeroOffset# + 365& * Yr + Leap + Before + Day - 1ã ãEND SUBããSUB J2G ' Julian to Gregorian packageã ã INPUT "Julian Day"; JulianDayã ã CALL JultoGregã ã PRINTã PRINT "In format Year, Month, Day: Gregorian Date is: "; Dte$ã ãEND SUBããSUB JultoGreg ' Does basic Julian to Gregorian conversionã ã Num = JulianDay - ZeroOffset#' days since Gregorian zeroã ' Note: DivMult reduces Num to show days remaining.ã ã Yr = DivMult(1, 4)' periods 1 - 4 are multiples of yearsã ã Mth = DivMult(5, 7)' periods 5 - 7 are multiples of monthsã ã Day = Num + 1' first day of month is #1, not #0ã ã ' Shift New Year from March 1 to January 1ã IF Mth > 9 THENã Month = Mth - 9ã Year = Yr + 1ã ELSEã Month = Mth + 3ã Year = Yrã END IFã ãEND SUBããDavid Williams Number of days between dates david.williams@ablelink.org 09-15-02 ( : ) QB,Qbasic,PDS 120 2798 datecalc.bas' DATECALC.BAS ã ã' David Williams. 2002 ã ã' david.williams@ablelink.org ã ã' Program does simple calendar calculations, finding the number ã' of days between two dates, or the date that is a given number of ã' days after or before a given date. ã ã' Decimal fractions of days are allowed. ã ãDECLARE SUB SubDates () ãDECLARE SUB AddDays () ãDECLARE SUB DateIn (P$) ãDECLARE SUB XD2G () ãDECLARE SUB G2XD () ãDECLARE FUNCTION Dte$ () ãDECLARE FUNCTION DivMult% (Sep$, N&) ãDEFINT A-Z ãDIM SHARED Year AS INTEGER, Month AS INTEGER, Day AS SINGLE ãDIM SHARED XDay AS DOUBLE ãCLS ãDO ã PRINT ã PRINT "1. Calculate number of days between two dates" ã PRINT "2. Calculate a date plus or minus some days" ã PRINT "3. Quit program" ã PRINT ã PRINT "Which (1 - 3)? "; ã DO ã K$ = INKEY$ ã LOOP UNTIL K$ >= "1" AND K$ <= "3" ã PRINT K$ ã PRINT ã SELECT CASE K$ ã CASE "1" ã CALL SubDates ã CASE "2" ã CALL AddDays ã CASE "3" ã EXIT DO ã END SELECT ãLOOP ãEND ã ãSUB AddDays ã CALL DateIn("Starting") ã INPUT "Add how many days (to subtract, use negative)"; Offset# ã XDay = XDay + Offset# ã CALL XD2G ã PRINT "Resulting date (Year, Month, Day) is "; Dte$ ãEND SUB ã ãSUB DateIn (P$) ã DO ã PRINT P$; " date "; ã INPUT "(YYYY,MM,DD - with commas)"; Year, Month, Day ã D1$ = Dte$ ã CALL G2XD ã CALL XD2G ã IF D1$ = Dte$ THEN EXIT DO ã BEEP ã PRINT "Illegal Gregorian Date!" ã LOOP ãEND SUB ã ãFUNCTION DivMult (Sep$, N&) ã A$ = ";146097,400;36524,100;1461,4;365,1:153,5:61,2:31,1" ã Total = 0 ã B = 1 ã DO ã B = INSTR(B, A$, Sep$) + 1 ã IF B = 1 THEN EXIT DO ã Days& = VAL(MID$(A$, B)) ã IF N& < 0 OR N& >= Days& THEN ã Quot = INT(N& / Days&) ã IF Quot = 4 THEN IF MID$(A$, B, 3) = "365" THEN Quot = 3 ã N& = N& - Quot * Days& ã Total = Total + Quot * VAL(MID$(A$, INSTR(B, A$, ",") + 1)) ã END IF ã LOOP ã DivMult = Total ãEND FUNCTION ã ãFUNCTION Dte$ ã Dte$ = LTRIM$(STR$(Year)) + "," + STR$(Month) + "," + STR$(Day) ãEND FUNCTION ã ãSUB G2XD ã IF Month < 3 THEN ã Mth = Month + 9 ã Yr = Year - 1 ã ELSE ã Mth = Month - 3 ã Yr = Year ã END IF ã Leap = INT(Yr / 4) - INT(Yr / 100) + INT(Yr / 400) ã Before = INT(30.6 * Mth + .5) ã XDay = 365& * Yr + Leap + Before + Day - 1 ãEND SUB ã ãSUB SubDates ã CALL DateIn("Earlier") ã X# = XDay ã CALL DateIn("Later") ã PRINT "Difference between dates is"; CSNG(XDay - X#); "days." ãEND SUB ã ãSUB XD2G ã N& = INT(XDay) ã F! = XDay - N& ã Year = DivMult(";", N&) ã Month = DivMult(":", N&) + 3 ã Day = N& + F! + 1 ã IF Month > 12 THEN ã Month = Month - 12 ã Year = Year + 1 ã END IF ãEND SUB ãDavid Williams Find the days of the week david.williams@ablelink.org 09-15-02 ( : ) QB,Qbasic,PDS 37 796 weekdays.bas' WEEKDAYS.BAS ã ã' Function "DayName$" finds day of week for any Gregorian date. ã' Rest of program is demonstration. ã ã' david.williams@ablelink.org ã ãDECLARE FUNCTION DayName$ (Year%, Month%, Day%) ãDEFINT A-Z ã ãDO ã ã INPUT "Date (YYYY,MM,DD)"; Y, M, D ã PRINT "This date is a "; DayName$(Y, M, D) ã ã PRINT "Another? (y/n) "; ã DO ã K$ = UCASE$(INKEY$) ã LOOP UNTIL K$ = "Y" OR K$ = "N" ã PRINT K$ ã ãLOOP UNTIL K$ = "N" ã ãEND ã ãFUNCTION DayName$ (Y, M, D) ã IF M > 2 THEN ã P = M - 3 ã Q = Y ã ELSE ã P = M + 9 ã Q = Y - 1 ã END IF ã Z = (D + Q + Q \ 4 - Q \ 100 + Q \ 400 + CINT(2.6 * P)) MOD 7 ã N$ = "Tues WednesThurs Fri Satur Sun Mon" ã DayName$ = RTRIM$(MID$(N$, 6 * Z + 1, 6)) + "day" ãEND FUNCTION ãDavid Williams Daylite Saving Time david.williams@ablelink.org 12-15-02 ( : ) Qbasic,QB,PDS 11 329 DST.BAS DEFINT A-Z ãCLS ãINPUT "Year"; Y ãQ = (Y + Y \ 4 - Y \ 100 + Y \ 400) MOD 7 ãF = 1 + (8 - Q) MOD 7 ãB = 25 + (11 - Q) MOD 7 ãPRINT "In most of North America, in the year"; STR$(Y); ãPRINT ", clocks are set ahead on" ãPRINT "April"; STR$(F); ", and back on October"; STR$(B); "." ãPRINT "Both dates are Sundays." ãEND ã