Thread Rating:
  • 0 Vote(s) - 0 Average
  • 1
  • 2
  • 3
  • 4
  • 5
another date challenge
#1
Ok....maybe not a very difficult one....

The challenge is to convert year and day of year to day of the week and day of the month in Basic.
Peace cannot be obtained without war. Why? If there is already peace, it is unnecessary for war. If there is no peace, there is already war."

Visit www.neobasic.net to see rubbish in all its finest.
Reply
#2
Untested, hope I got it right. Tongue

Weeks are assumed to start on Sunday; day of year is zero-based.

Compiles with FreeBASIC 0.17b (current CVS version)... no guarantees it'll work anywhere else.

Code:
declare function isleapyear(byval i as integer) as integer
declare function monthlen(byval m as integer, byval leap as integer) as integer
declare function monthname(byval m as integer) as string
declare sub yeardaytomonth(byval i as integer, byval leap as integer, byref m as integer, byref d as integer)
declare sub yeardaytoweek(byval i as integer, byref w as integer, byref d as integer)
declare function weekdayname(byval d as integer) as string

dim y as integer, i as integer, leap as integer, m as integer, w as integer, d as integer

do
    input "Year (-1 to quit): ", y
    if y < 0 then end
retry:
    input "Day of year (-1 to quit): ", i
    if i < 0 then end
    if i > 364 then goto retry
    
    leap = isleapyear(y)
    yeardaytomonth(i, leap, m, d)
    print d + 1 & " " & monthname(m)
    yeardaytoweek(i, w, d)
    print weekdayname(d) & " of week " & w
loop

function isleapyear(byval i as integer) as integer
    isleapyear = 0
    if i mod 4 = 0 then
        if i mod 100 = 0 then
            if i mod 400 = 0 then
                isleapyear = 1
            end if
        else
            isleapyear = 1
        end if
    end if
end function

function monthlen(byval m as integer, byval leap as integer) as integer

    static monthlentb(0 to 11) as integer = {31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31}

    if (leap <> 0) and (m = 1) then
        return 29
    else
        return monthlentb(m)
    end if
end function

function monthname(byval m as integer) as string
    static monthnametb(0 to 11) as zstring ptr = {@"Jan", @"Feb", @"Mar", @"Apr", @"May", @"Jun", _
        @"Jul", @"Aug", @"Sep", @"Oct", @"Nov", @"Dec"}
    return *monthnametb(m)
end function

sub yeardaytomonth(byval i as integer, byval leap as integer, byref m as integer, byref d as integer)
    static monthstarttb(0 to 12) as integer = {0, 31, 59, 90, 120, 151, 181, 212, 243, 273, 304, 334, 365}
    dim n as integer, add as integer = 0

    for n = 0 to 11
        if (i >= (monthstarttb(n) + add)) and (i < (monthstarttb(n + 1) + add)) then exit for
        if n = 1 then add = 1
    next n
    
    m = n
    d = i - monthstarttb(n)
end sub

sub yeardaytoweek(byval i as integer, byref w as integer, byref d as integer)
    w = i \ 7
    d = i mod 7
end sub

function weekdayname(byval d as integer) as string
    static daynametb(0 to 6) as zstring ptr = {@"Sun", @"Mon", @"Tue", @"Wed", @"Thu", @"Fri", @"Sat"}
    return *daynametb(d)
end function
Reply
#3
It won't work in anything but Freebasic...

I tried day:0, with years 2004, 2005, and 2006, and I got the same day of the week every time... Your input to the function "yeardaytoweek" is only the day of the year... I think I know how to fix it, but I will leave that to you....
Peace cannot be obtained without war. Why? If there is already peace, it is unnecessary for war. If there is no peace, there is already war."

Visit www.neobasic.net to see rubbish in all its finest.
Reply
#4
Ah, good point, the day of week thing is broken. I wrote it on the assumption that a week would start on the first day of the year... but I'm too lazy to go fix it, so there. Wink
Reply
#5
Quote:Ok....maybe not a very difficult one....

The challenge is to convert year and day of year to day of the week and day of the month in Basic.

Ok Aga, I took my old date utility and made some mods. Here it is. I did some testing.

Regards..... Moneo
Code:
rem Date Challenge by Agamemnus, 11-Dec-2006.
rem INPUT : YEAR and Day of Year
rem OUTPUT: Day of Week and Day of Month.

DEFINT A-Z

DECLARE FUNCTION   NumStrict    (Z$)
DECLARE FUNCTION IsLeapYear% (Z)  
DECLARE FUNCTION FillString$ (V#,ZL)          

DIM DAYS.OFFSET  AS LONG     'Plus or minus offset days from given date
DIM YEAR.MIN     AS INTEGER  'Minimum valid year for dates (default=0)
DIM DATE.FACTOR  AS SINGLE   'Number of days given date is from day zero.
DIM WEEK.DAY     AS INTEGER  'Day of week value: 1=Sunday....7=Saturday.
DIM WEEK.NUM     AS INTEGER  'Week number within year (1 to 54).
DIM JULIAN.DAY   AS INTEGER  'Day  number within year (1 to 366).
DIM DATE.OK      AS INTEGER  'Valid date indicator: -1=True, 0=False.
Z$               =  ""       'Date string as YYYYMMDD.
DIM ZYY          AS INTEGER  'Value of the 4 digit year.
DIM ZMM          AS INTEGER  'Value of the 2 digit month.
DIM ZDD          AS INTEGER  'Value of the 2 digit day.
DIM ZMAX         AS INTEGER  'Routine internal value of max days in month.
DIM ZDWORK       AS LONG     'Variable    internal to date routines.
DIM ZFSAVE       AS SINGLE   'Variable    internal to date routines.
DIM ZFSAVE2      AS SINGLE   'Variable    internal to date routines.
ZTEMP$           =  ""       'Work string internal to date routines.
ZTEMP2$          =  ""       'Work string internal to date routines.

DIM ZMO(1 TO 12) AS INTEGER
DATA 31,28,31,30,31,30,31,31,30,31,30,31
FOR ZMM=1 TO 12:READ ZMO(ZMM):NEXT

CONST ZMO3$="JANENEFEBFEBMARMARAPRABRMAYMAYJUNJUNJULJULAUGAGOSEPSEPOCTOCTNOVNOVDECDIC"

rem Miscellaneous variables:
twide = 14                  'width of text before equalsign is 14 in English
em4$="ERROR: Non-numeric Day of Year"
em5$="ERROR: Invalid Day of Year"
em6$="*** Internal date error #"
wdate1$="date#1"
wdate2$="date#2"
wdate3$="result date"
textoffset$="days_offset"

REM *************************************************************************
REM        |-------------------------------------|                  
REM        |  P R O G R A M   M A I N   L I N E  |
REM        |-------------------------------------|                  
REM *************************************************************************

cls
print "Input YEAR ";
input PARAM1$
PARAM1$=PARAM1$+"0101"
z$=Param1$
gosub date.factor
if not(date.ok) then print "Invalid Year":system

print "Input DAY OF YEAR ";
input PARAM2$
if param2$="" then print "Day of Year missing":system
if not NumStrict(param2$) then print em4$:system
if val(param2$)<1 then print em5$:system
days.offset=val(param2$)-1
z$=param1$
gosub date.offset
if not(date.ok) then print em5$:system
w$=wdate3$:gosub display
SYSTEM

REM ***************************************************************************
REM *****   S U B R O U T I N E S  
REM ***************************************************************************

display:
gosub date.format
print left$(w$+space$(twide),twide);"= ";z$
print "week day      = ";:print using "###";week.day;
                         print "  ";mid$("SunMonTueWedThuFriSat",3*week.day-2,3)
REM ...print "week number   = ";:print using "###";week.num
print "Julian day    = ";:print using "###";julian.day
return     '>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>


REM ***************************************************************************
REM *****   D A T E   S U B R O U T I N E S   *********************************
REM ***************************************************************************

REM ************************  DATE.FACTOR  ************************************
REM *
REM *** PRINCIPAL DATE SUBROUTINE:
REM *   =========================
REM *   - Validate input date string.
REM *   - Compute number of days (date.factor) from year 0, month 0, day 0.
REM *   - Compute day of week.
REM *   - Compute week number.
REM *   - Compute "julian" day of year.
REM *
REM *  INPUT:
REM *  =====
REM *  Z$         = Date string formatted as YYYYMMDD.
REM *  YEAR.MIN   = Minimum year user wishes to allow (default 0)
REM *
REM * OUTPUT:
REM * ======
REM * DATE.OK       = -1 if input date VALID.   (true)
REM *               =  0 if Input date INVALID. (false)                    
REM * NOTE: IF VALID,   THE FOLLOWING VARIABLES AR BASED ON INPUT DATE.
REM *       IF INVALID, THE VALUES MAY HAVE CHANGED AND ARE MEANINGLESS.
REM * DATE.FACTOR   = Number of cumulative days from year/month/day 0.
REM * WEEK.DAY      = 1 to   7 is Sunday to Saturday respectively.  
REM * WEEK.NUM      = 1 TO  54 is week number within year.            
REM * JULIAN.DAY    = 1 TO 366 is day  number within year.            
REM * ZYY           = Value of of 4 digit year.        
REM * ZMM           = Value of month.                    
REM * ZDD           = Value of day.                                
REM * Z$            = (unchanged).
REM * YEAR.MIN      = (unchanged).
REM *
REM *
REM * Date factor logic adopted from a Texas Instruments calculator manual.
REM *
DATE.FACTOR:
  gosub Date.Check                     'check input date
  if not(date.ok) then RETURN          'exit if invalid

  zmm=1:zdd=1                          'set to January 1st
  gosub Compute.Factor                 'compute factor of Jan 1st
  zfsave=date.factor                   'save factor   of Jan 1st
  gosub Compute.Weekday                'week.day now has day of week of Jan 1st

  zdd=val(right$(z$,2))                'Restore input date's day + month  
  zmm=val(mid$(z$,5,2))  
  gosub Compute.Factor                 'compute factor of input date

  '* Julian day is input date minus Jan 1st of same year +1
  julian.day=date.factor-zfsave+1  

  '* Compute the week number: (week.day-1 is week day of Jan 1st relative to 0)
  week.num=int((julian.day+(week.day-1)-1)/7)+1

  '* Compute the day of the week of input date:
  gosub Compute.Weekday
RETURN

COMPUTE.FACTOR:
  DATE.FACTOR=365!*ZYY+ZDD+31*(ZMM-1)  'NOTE: WON'T WORK WITHOUT ! AFTER 365.
  IF ZMM<3 THEN
     DATE.FACTOR=DATE.FACTOR+INT((ZYY-1)/4)-INT(3/4*(INT((ZYY-1)/100)+1))
  ELSE
     DATE.FACTOR=DATE.FACTOR-INT(.4*ZMM+2.3)+INT(ZYY/4)-INT(3/4*(INT(ZYY/100)+1))
  END IF
RETURN

COMPUTE.WEEKDAY:
  '* Compute the day of the week:
  WEEK.DAY=DATE.FACTOR-INT(DATE.FACTOR/7)*7    'Modulo 7.
  IF WEEK.DAY=0 THEN WEEK.DAY=7                'WEEK.DAY=1=Sunday.
RETURN
REM ***************************************************************************

REM ******************  DATE.OFFSET  ******************************************
REM *
REM *** COMPUTE THE DATE WHICH IS NUMBER OF DAYS FROM GIVEN DATE.
REM *
REM *  INPUT:
REM *  =====
REM *  Z$           = Given date as YYYYMMDD.
REM *  DAYS.OFFSET  = Number of calendar days plus or minus from given date.
REM *  YEAR.MIN     = Minimum year user wishes to allow (default 0)
REM *
REM * OUTPUT:
REM * ======
REM * DATE.OK       = -1 if input/offset/result date is VALID.   (true)
REM *               =  0 if input/offset/result date is INVALID. (false)
REM * NOTE: IF VALID, THE FOLLOWING VARIABLES AR BASED ON COMPUTED/RESULT DATE.
REM *       IF INVALID, THE VALUES MAY HAVE CHANGED AND ARE MEANINGLESS.
REM * Z$            = Computed/Result date (Given+DAYS.OFFSET) (as YYYYMMDD).
REM * DAYS.OFFSET   = (unchanged).
REM * DATE.FACTOR   = Number of cumulative days from year/month/day 0.
REM * WEEK.DAY      = 1 to   7 is Sunday to Saturday respectively.  
REM * WEEK.NUM      = 1 TO  54 is week number within year.            
REM * JULIAN.DAY    = 1 TO 366 is day  number within year.            
REM * ZYY           = Value of of 4 digit year.        
REM * ZMM           = Value of month.                    
REM * ZDD           = Value of day.                                
REM * EASTERSUNDAY$ = Date of Easter for computed/result year.      
REM * YEAR.MIN      = (unchanged).
REM *
DATE.OFFSET:
  gosub date.factor
  if not (date.ok) then RETURN        
  if date.factor+days.offset < 0 or_
     date.factor+days.offset > 3652424 then Date.ok=0 : RETURN
                              '3652424 is date.factor for max date of 99991231.
  '* Note: Date was split into zyy/zmm/zdd by date.factor routine.
  zdwork=zdd+days.offset                    'Set to Given day + increment.
  if zdwork < 1 then
     do
       zmm=zmm-1:if zmm=0 then zmm=12:zyy=zyy-1
       gosub GetZMax                           'go get max days cur month (zmm)
       zdwork=zdwork+zmax
     loop while zdwork<1
  else
     gosub GetZMax                             'go get max days cur month (zmm)
     do while zdwork>zmax
       zmm=zmm+1:IF zmm>12 then zmm=1:zyy=zyy+1
       zdwork=zdwork-zmax
       gosub GetZMax
     loop
  end if
  zdd=zdwork
  '* Pack the date as YYYYMMDD
  Z$=FILLSTRING$((ZYY),4)+FILLSTRING$((ZMM),2)+FILLSTRING$((ZDD),2)
  gosub date.factor         'get all pertinent variables for final date
  '* Note: date.factor routine also sets date.ok indicator.
RETURN

GetZMax:
  IF ZMM=2 AND ISLEAPYEAR(ZYY) THEN ZMAX=ZMO(ZMM)+1 ELSE ZMAX=ZMO(ZMM)
RETURN
REM ***************************************************************************

REM ***************************************************************************

REM *********************  DATE.CHECK  ****************************************
REM *
REM *** VALIDATE A DATE IN YYYYMMDD FORMAT.
REM *
REM *  INPUT: Z$       = Given date in format YYYYMMDD.
REM *         YEAR.MIN = Minimum valid year allowed. (default=0)
REM *
REM * OUTPUT: DATE.OK = -1 if input date is VALID.   (true)
REM *                    0 if input date is INVALID. (false)                    
REM *         (if VALID):
REM *         ZYY      = Value of 4 digit year.        
REM *         ZMM      = Value of month.                              
REM *         ZDD      = Value of day.                                
REM *
REM *
DATE.CHECK:
  DATE.OK = 0      'preset to false
  ZTEMP$="1"+Z$+"1"
  IF LEN(Z$)<>8 OR MID$(STR$(VAL(ZTEMP$)),2)<>ZTEMP$ THEN RETURN
  ZDD=VAL(RIGHT$(Z$,2))                'Set day                
  ZMM=VAL(MID$(Z$,5,2))                'Set month.
  ZYY=VAL(LEFT$(Z$,4))                 'Set year.
  IF ZMM<1 OR ZMM>12 OR ZDD<1 OR ZDD>31 OR ZYY<YEAR.MIN THEN RETURN
  IF ZMO(ZMM)+1*(-(ZMM=2 AND ISLEAPYEAR(ZYY))) < ZDD THEN RETURN
  '   If expression (month=2 and is leapyear) is TRUE which is -1, then
  '   taking the negative of this issues a plus 1. Conversely, the FALSE    
  '   always gives a zero. Multiplying the +1 by this result of 1 or 0
  '   will either add 1 or not to the number of days in the month.
  '   The routine wants to add 1 only when it is February and leap year.
  DATE.OK = -1        '-1=valid (true)
RETURN      
REM ***************************************************************************

REM ******************  DATE.FORMAT  ******************************************
REM *
REM *** FORMAT A DATE FOR PRINTING.
REM *
REM *  INPUT: Z$ in format YYYYMMDD. (assumed to be already validated)
REM *
REM * OUTPUT: Z$ formatted as DD-MMM-YYYY.
REM *
DATE.FORMAT:
  Z$=RIGHT$(Z$,2)+"-"+MID$(ZMO3$,6*VAL(MID$(Z$,5,2))-2-(3),3)+"-"+LEFT$(Z$,4)
RETURN
REM ***************************************************************************

END

REM ***************************************************************************
REM ***************************************************************************
REM *****   D A T E   F U N C T I O N S   *************************************
REM ***************************************************************************

' ====================== ISLEAPYEAR ==========================
'         Determines if a year is a leap year or not.
' ============================================================
'
FUNCTION IsLeapYear (Z) STATIC

   ' If the year is evenly divisible by 4 and not divisible
   ' by 100, or if the year is evenly divisible by 400, then
   ' it's a leap year:
   IsLeapYear = (Z MOD 4 = 0 AND Z MOD 100 <> 0) OR (Z MOD 400 = 0)
END FUNCTION
' ========================= FILLSTRING =============================
' Converts a value to string of specified length with leading zeros.
' ==================================================================
FUNCTION FillString$ (V#,ZL) STATIC

  FILLSTRING$=right$(STRING$(ZL,"0")+MID$(STR$(V#),2),ZL)
END FUNCTION
' ===================================================================


FUNCTION NumStrict (Z$)

REM *
REM *** (NUMSTRICT) - CHECK FOR STRICTLY NUMERIC ONLY (NO NULL NO DECIMAL)
REM *

  NumStrict=0         'Init to False

  IF Z$="" THEN EXIT FUNCTION

  FOR X = 1 TO LEN(Z$)
      A=ASC(MID$(Z$,X,1))
      IF A<48 OR A>57 THEN EXIT FUNCTION
  NEXT X

  NumStrict = -1          'True

END FUNCTION
Reply
#6
Hm... I guess you wrote this for QB, but there are loads of problems running this with FB... among them, date.ok doesn't seem to work right... :-| I'll try to fix later....
Peace cannot be obtained without war. Why? If there is already peace, it is unnecessary for war. If there is no peace, there is already war."

Visit www.neobasic.net to see rubbish in all its finest.
Reply
#7
Small is beautiful
Code:
'Conversion of day of year and year to day of month and day of week
'by Antoni gual 2006/12/15 for Agamemnus contest at QBN
'Tested in QB 1.1
'
DEFINT A-Z
DECLARE FUNCTION DayofWeek (y, m, D)
DECLARE FUNCTION ISLEAPYEAR (y)
DECLARE FUNCTION daysinmonth (y, m)

DO
INPUT "year (0 to exit)"; y
IF y < 1 THEN EXIT DO
INPUT "day of year"; dy
IF dy < 1 OR dy > 365 - ISLEAPYEAR(y) THEN PRINT "bad day of year": END
nt = 0
m = 0
DO
n = nt
m = m + 1
nt = nt + daysinmonth(y, m)
LOOP UNTIL dy <= nt

dm = dy - n
'PRINT "month (1=January...12=December)"; m
PRINT "day of month = "; dm
PRINT "day of week (1=monday...7=sunday) "; DayofWeek(y, m, dm) + 1
LOOP
END
'
'-------------------------------------------------------------------------
FUNCTION DayofWeek (y, m, D)
  '0=monday
  DIM P, Q
  IF m > 2 THEN
    P = m - 3
    Q = y
  ELSE
    P = m + 9
    Q = y - 1
  END IF
DayofWeek = (D + 1 + Q + Q \ 4 - Q \ 100 + Q \ 400 + CINT(2.6 * P)) MOD 7
END FUNCTION

'
'-------------------------------------------------------------------------
FUNCTION daysinmonth (y, m)
'get nr of days in a month  of a year(check for leap year if february)
SELECT CASE m
CASE 2: daysinmonth = 28 - ISLEAPYEAR(y)
CASE 1, 3, 5, 7, 8, 10, 12: daysinmonth = 31
CASE ELSE: daysinmonth = 30
END SELECT
END FUNCTION

'
'-------------------------------------------------------------------------
FUNCTION ISLEAPYEAR (y)
'Returns -1 if Gregorian year y is a leap year
ISLEAPYEAR = (y MOD 4 = 0) - (y MOD 100 = 0) + (y MOD 400 = 0)
END FUNCTION
'
'--------------------------------------------------------------------------
Antoni
Reply
#8
Quote:Small is beautiful
Code:
'Conversion of day of year and year to day of month and day of week
'by Antoni gual 2006/12/15 for Agamemnus contest at QBN
'Tested in QB 1.1

Antoni, Did some testing and it works fine.

I wonder why Aga didn't ask for the month as well as the day of the month?

¿Que te pareció el 4-0 del Barca contra el América?
Como dirián en inglés: When you play against Barcelona, you're playing with the big boys.

Saludos..... Moneo
Reply
#9
Naturally it works. Smile
It uses the day of week routine I once used in one of your challenges at Foronet. I can translate the explanation of the algorithm i posted there if someone is interested.

About the Barça, well, they were too confident. They have no rival in Spain at the moment, and they just classified for the next run of the european UEFA champions cup, so they believe they are the kings of mambo.
Antoni
Reply
#10
Quote:
Antoni Gual Wrote:Small is beautiful
Code:
'Conversion of day of year and year to day of month and day of week
'by Antoni gual 2006/12/15 for Agamemnus contest at QBN
'Tested in QB 1.1

Antoni, Did some testing and it works fine.

I wonder why Aga didn't ask for the month as well as the day of the month?

¿Que te pareció el 4-0 del Barca contra el América?
Como dirián en inglés: When you play against Barcelona, you're playing with the big boys.

Saludos..... Moneo

Yes, I guess that would be interesting as well...

Thank you Antoni for your submission. I am going to try to do something myself (without looking at you awesome compact code) and we shall then end the contest there, if no one else has any other submissions.
Peace cannot be obtained without war. Why? If there is already peace, it is unnecessary for war. If there is no peace, there is already war."

Visit www.neobasic.net to see rubbish in all its finest.
Reply


Forum Jump:


Users browsing this thread: 1 Guest(s)