Simple Calendar (Show only one month)

General FreeBASIC programming questions.
lrcvs
Posts: 578
Joined: Mar 06, 2008 19:27
Location: Spain

Simple Calendar (Show only one month)

Post by lrcvs »

Hi!

A simple Calendar program, show only one month

Code: Select all

'PROGRAM:CALENDAR, SHOW ONLY ONE MONTH

DIM AS INTEGER a,c,d,dm,ds,f,j,k,m,n,y
DIM u (49) AS STRING
DIM v (6,7) AS STRING

d = 1

CLS
INPUT "Month number 1...12 = ";m
INPUT "Year number yyyy = ";y
CLS

IF m = 1 OR m = 3 OR m = 5 OR m = 7 OR m = 8 OR m = 10 OR m = 12 THEN dm = 31
IF m = 4 OR m = 6 OR m = 9 OR m = 11 THEN dm = 30
IF m = 2 THEN dm = 28

IF m = 2 AND ((y MOD 4) =  0 OR ((y MOD 100) = 0 AND (y MOD 400)) = 0) THEN dm = 29

a = INT((14 - m) / 12)
y = y - a
m = m + (12 * a) - 2
ds =((d + y + INT(y / 4) - INT(y / 100) + INT(y / 400) + INT((31 * m) / 12)) MOD 7)

IF ds = 0 THEN ds = ds +7
IF ds > 0 THEN ds = ds -1

FOR n = 1 TO 49
    u(n) = "  "
NEXT n

FOR n = 1 TO dm
    f =  LEN(LTRIM(STR(n)))
    IF f =1 THEN
        u(n+ds) = " " + LTRIM(STR(n))
    ELSE
        u(n+ds) = LTRIM(STR(n))
    END IF    
NEXT n

c = 1

FOR j = 1 TO 6
    FOR k = 1 TO 7
        v(j,k) = MID(u(c),1,3)
        c = c + 1
    NEXT k
NEXT j
    
PRINT "Mo Tu We Th Fr Sa Su"
    
FOR j = 1 TO 6
    FOR k = 1 TO 7
        PRINT v(j, k) ;" ";
    NEXT k
    PRINT
NEXT j

SLEEP
END
Regards
Tourist Trap
Posts: 2958
Joined: Jun 02, 2015 16:24

Re: Simple Calendar (Show only one month)

Post by Tourist Trap »

lrcvs wrote: A simple Calendar program, show only one month
Nice, it works at least for 2016. We won't have to wait a long time before testing it with 2017 ;)
Lothar Schirm
Posts: 436
Joined: Sep 28, 2013 15:08
Location: Germany

Re: Simple Calendar (Show only one month)

Post by Lothar Schirm »

Ircvs,
FreeBASIC offers a nice function for such applications: DateSerial. This could simplify your code very much. Example:

Code: Select all

#Include "vbcompat.bi"

Dim As Integer d, m, y, a, col

Cls
Input "Month number 1...12 = ";m
Input "Year number yyyy = ";y
Cls

Print "Mo Tu We Th Fr Sa Su"
For d = 1 To 31
	a = DateSerial(y, m, d)
	If Month(a) = m Then
		If WeekDay(a) > 1 Then 
			'Monday to Saturday:
			col = 1 + (WeekDay(a) - 2) * 3 
			Locate , col
			Print Format(d, "00");
		Else
		'Sunday:
			col = 1 + 18
			Locate , col
			Print Format(d, "00")
		End If
	End If
Next

End
Should also work in 2017. Happy New Year!
bcohio2001
Posts: 556
Joined: Mar 10, 2007 15:44
Location: Ohio, USA
Contact:

Re: Simple Calendar (Show only one month)

Post by bcohio2001 »

There is also:

Code: Select all

Print MonthName(m)
lrcvs
Posts: 578
Joined: Mar 06, 2008 19:27
Location: Spain

Re: Simple Calendar (Show only one month)

Post by lrcvs »

Hi, all!

Happy New Year 2.017!!!

:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

To Tourist Tramp:

The formula used is: "Zeller's Congruence"

See:
https://es.wikipedia.org/wiki/Congruencia_de_Zeller

But... I have my doubts...,
...because the years: 1700-1800-1900-2100-2200-2300 ..., they say: "... they are not leap ..."
... then I have my doubts in knowing if the month of February of all those years, has 28 or 29 days?

... Well, if these years ... "They are not leap"..., then, between 1896 and 1900, you have spent 4 years ...

Where is that February 29th?


'::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

To Lothar Schirm:

Thanks for your code!

I know: #Include "vbcompat.bi" and "Date Serial"

But... I also have my doubts ...
... because the years: 1700-1800-1900-2100-2200-2300 ..., they say: "... they are not leap ..."
... then I have my doubts in knowing if the month of February of all those years, has 28 or 29 days?

... Well, if these years ... "They are not leap"..., then, between 1896 and 1900, you have spent 4 years ...

Where is that February 29th?

:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

For example:

The year: 1900, the month of February.
Using: #Include "vbcompat.bi" and "Date Serial"

February, has 28 days, starts Thursday and ends Wednesday. "<<< !!!"

March, has 31 days, starts Thursday and ends Saturday.

............................................................................................................
Well, now the same example: year 1900, February.
Using: "Zeller's Congruence"

February, has 29 days, starts Thursday and ends Thursday. "<<< !!!!"

March, has 31 days, starts Thursday and ends Saturday. "<<< !!!!"
............................................................................................................


As we see, ("there may be" ("a possible error") in this formula or Date Serial?)
lrcvs
Posts: 578
Joined: Mar 06, 2008 19:27
Location: Spain

Re: Simple Calendar (Show only one month)

Post by lrcvs »

Hi,
To bcohio2001:

I will see!

Regards!
Zippy
Posts: 1295
Joined: Feb 10, 2006 18:05

Re: Simple Calendar (Show only one month)

Post by Zippy »

This is an example using Zeller's that accommodates leaps. I've today modded the 10yo code for 64-bit compatibility - it should remain 32-bit able but didn't test.

Code: Select all

'Perpetual calendar >year 1582
'
'#define MondayStartZ
 
'function returns dateserial of date
declare function printcal(ds as string) as long
'
'printcal(date)
printcal("02-01-2016")
'printcal("02-01-2017")

sleep
'
function printcal(ds as string) as long
    dim as string  dstr,mstr,t1
    dim as long dow,sdow,ds1,ds2,ndays
    dim as long y,yy,m,mm,d,dd,a,c,tds
    '    
    dstr="Sunday   Monday   Tuesday  Wednesday" & _
         "Thursday Friday   Saturday "
    mstr="January  February March    April    May" & _
         "      June     July     August   " & _
         "SeptemberOctober  November December "
    '         
    'ds=date string mm-dd-yyyy
    yy=val(right(ds,4)) 'year must be >1582
    mm=val(left(ds,2))
    dd=val(mid(ds,4,2))
    y=yy:m=mm:d=dd
    '
    if m<3 then m+=12:y-=1:end if 'Zeller's month mod
    'get numeric day of week, where 0 = Sunday
    dow=(2+d+(13*m-2)\5+y+y\4-y\100+y\400) mod 7
    'get absolute number of days, Zeller
    tds=(d+(153*m-2)\5+365*y+y\4-y\100+y\400)
    'convert to M$ dateserial for function return, not otherwise used
    printcal = tds-693991 'base = 12-30-1899, = M$ dateserial
    '
    'get the month's start day of week    
    d=1:m=mm:y=yy
    if m<3 then m+=12:y-=1:end if
    ds1=(d+(153*m-2)\5+365*y+y\4-y\100+y\400) 'dateserial first day of month
    sdow=(2+d+(13*m-2)\5+y+y\4-y\100+y\400) mod 7
'mod for Monday start of week    
#if defined (MondayStartZ)
    sdow-=1:if sdow<0 then sdow=0
#endif
    '
    'get number of days in month   
    m=mm:y=yy
    m+=1:if m>12 then m=1:y+=1:end if
    if m<3 then m+=12:y-=1:end if
    'get dateserial of first day of next month
    ds2=(d+(153*m-2)\5+365*y+y\4-y\100+y\400)
    ndays=ds2-ds1 'if dd>ndays then..bad..day
    ' 
    'print calendar   
    t1=trim(mid(mstr,(mm-1)*9+1,9)) & " " & yy
    print:print space(11-len(t1)\2);t1
'mod for Monday start of week
#if defined (MondayStartZ)
    print:print " Mo Tu We Th Fr Sa Su"
#else
    print:print " Su Mo Tu We Th Fr Sa"
#endif
    a = 1-sdow:c=0
    while a<=ndays
        if a>=1 then
            color iif(a=dd,15,7),0
            print using "###";a;
        else
            print space(3);
        end if
        a+=1:c+=1
        if c=7 then c=0:print:end if
    wend
    '
    print
    print:color 15,0
    print trim(mid(dstr,dow*9+1,9)) & ", " & _
          trim(mid(mstr,(mm-1)*9+1,9)) & _
          " " & dd & ", " & yy
    color 7,0
'
end function
I posted a unicode internationalized version in 2006 that user voodoattack helped me with. I also have a version that prints both a month-by and year-by calendar, I don't rem if I posted that one. Note in this code the ability to define a Monday start date for the week.

@lrcvs: Not trying to step on your post. I hope you find this helpful. Happy New Year!
.
MrSwiss
Posts: 3910
Joined: Jun 02, 2013 9:27
Location: Switzerland

Re: Simple Calendar (Show only one month)

Post by MrSwiss »

Hi all,

recoded ex. from Zippy (hope you don't mind) to reflect EU style Date-Format:

Code: Select all

'Perpetual calendar > year 1582, original by Zippy
' recoded for EU Date format, by MrSwiss

#define MondayStartZ
 
'function returns dateserial of date
declare function printcal(ds as string) as long

'start Main
'printcal(EU String Date: "DD.MM.YYYY")
Dim As Long ret

ret = printcal("01.02.2016")
'ret = printcal("01.02.2017")
Print : Print "DateSerial: "; Str(ret)

sleep
' end Main

function printcal(ByRef ds as string) as long
    dim as string  dstr, mstr, t1
    dim as long    dow, sdow, ds1, ds2, ndays
    dim as long    y, yy, m, mm, d, dd, a, c, tds

    dstr = "Sunday   Monday   Tuesday  Wednesday" + _
           "Thursday Friday   Saturday "
    mstr = "January  February March    April    May" + _
           "      June     July     August   " + _
           "SeptemberOctober  November December "

    ' ds = date string dd.mm.yyyy (EU format)
    yy = ValInt(right(ds,4)) 'year must be >1582
    dd = ValInt(left(ds,2))  ' exchanged mm and dd for EU formated string
    mm = ValInt(mid(ds,4,2))
    y = yy : m = mm : d = dd
    '
    if m < 3 then m += 12 : y -= 1 'Zeller's month mod
    'get numeric day of week, where 0 = Sunday
    dow = (2 + d + (13 * m - 2) \ 5 + y + y \ 4 - y \ 100 + y \ 400) mod 7
    'get absolute number of days, Zeller
    tds = (d + (153 * m - 2) \ 5 + 365 * y + y \ 4 - y \ 100 + y \ 400)

    'convert to M$ dateserial for function return, not otherwise used
    printcal = tds - 693991 'base = 30.12.1899, = M$ dateserial

    'get the month's start day of week   
    d = 1 : m = mm : y = yy
    if m < 3 then m += 12 : y -= 1

    ds1 = (d + (153 * m - 2) \ 5 + 365 * y + y \ 4 - y \ 100 + y \ 400) 'dateserial first day of month
    sdow = (2 + d + (13 * m - 2) \ 5 + y + y \ 4 - y\ 100 + y \ 400) mod 7

'mod for Monday start of week   
#ifdef MondayStartZ
    sdow -= 1 : If sdow < 0 then sdow = 0
#endif

    'get number of days in month   
    m = mm : y = yy
    m += 1 : If m > 12 then m = 1 : y += 1
    if m < 3 then m += 12 : y -= 1
    'get dateserial of first day of next month
    ds2 = (d + (153 * m - 2) \ 5 + 365 * y + y \ 4 - y \ 100 + y \ 400)
    ndays = ds2 - ds1 'if dd > ndays then..bad..day
    'print calendar
    t1 = Trim(Mid(mstr, (mm - 1) * 9 + 1, 9)) + " " + Str(yy)
    Print : Print Space(11 - Len(t1) \ 2); t1

'mod for Monday start of week
#ifdef MondayStartZ
    Print : Print " Mo Tu We Th Fr Sa Su"
#else
    Print : Print " Su Mo Tu We Th Fr Sa"
#EndIf

    a = 1 - sdow : c = 0
    while a <= ndays
        if a >= 1 then
            color iif(a = dd, 15, 7)
            print using "###"; a;
        else
            print space(3);
        end if
        a += 1 : c += 1
        if c = 7 then c = 0 : Print
    wend

    Print : Print : Color 15

    ' recoded to reflect EU tsyle format
    Print Trim(Mid(dstr, dow * 9 + 1, 9)) + ", " + Str(dd) + _
          ". " + Trim(Mid(mstr, (mm - 1) * 9 + 1, 9)) + " " + Str(yy)
    color 7
End Function
Happy 2017, to all!
lrcvs
Posts: 578
Joined: Mar 06, 2008 19:27
Location: Spain

Re: Simple Calendar (Show only one month)

Post by lrcvs »

Hi!
Thank you all!!!
Solved the error.
The error was in my program, in the line to calculate the leap year.
Now, apparently, it's perfect.

Code: Select all

'PROGRAM:CALENDAR, SHOW ONLY ONE MONTH

DIM AS INTEGER a,c,d,dm,ds,f,j,k,m,n,y, Z
DIM u (49) AS STRING
DIM v (6,7) AS STRING

d = 1

CLS
INPUT "Month number 1...12 = ";m
INPUT "Year number yyyy = ";y
CLS

IF m = 2 THEN dm = 28

If m = 2 And (y Mod 400 = 0) And (y Mod 4 = 0) or (y Mod 100 <> 0) And (y Mod 4 = 0) Then dm = 29 

IF m = 1 OR m = 3 OR m = 5 OR m = 7 OR m = 8 OR m = 10 OR m = 12 THEN dm = 31
IF m = 4 OR m = 6 OR m = 9 OR m = 11 THEN dm = 30

a = INT((14 - m) / 12)
y = y - a
m = m + (12 * a) - 2
ds =((d + y + INT(y / 4) - INT(y / 100) + INT(y / 400) + INT((31 * m) / 12)) MOD 7)

IF ds = 0 THEN ds = ds +7
IF ds > 0 THEN ds = ds -1

FOR n = 1 TO 49
    u(n) = "  "
NEXT n

FOR n = 1 TO dm
    f =  LEN(LTRIM(STR(n)))
    IF f =1 THEN
        u(n+ds) = " " + LTRIM(STR(n))
    ELSE
        u(n+ds) = LTRIM(STR(n))
    END IF    
NEXT n

c = 1

FOR j = 1 TO 6
    FOR k = 1 TO 7
        v(j,k) = MID(u(c),1,3)
        c = c + 1
    NEXT k
NEXT j
    
PRINT "Mo Tu We Th Fr Sa Su"
    
FOR j = 1 TO 6
    FOR k = 1 TO 7
        PRINT v(j, k) ;" ";
    NEXT k
    PRINT
NEXT j

SLEEP
END
Happy New Year 2.017 !!!
Lothar Schirm
Posts: 436
Joined: Sep 28, 2013 15:08
Location: Germany

Re: Simple Calendar (Show only one month)

Post by Lothar Schirm »

Wikipedia (Leap Year - Gregorian Calendar) says:
Every year that is exactly divisible by four is a leap year, except for years that are exactly divisible by 100, but these centurial years are leap years if they are exactly divisible by 400. For example, the years 1700, 1800, and 1900 were not leap years, but the years 1600 and 2000 were.[.
So regarding Ircvs' example for 1900 it seems that DateSerial is ok.
Last edited by Lothar Schirm on Jan 01, 2017 12:16, edited 1 time in total.
BasicCoder2
Posts: 3906
Joined: Jan 01, 2009 7:03
Location: Australia

Re: Simple Calendar (Show only one month)

Post by BasicCoder2 »

Now you have the engine that generates the days for a given month in a given year you can use FreeBasic graphics to produce a really nice calendar display. It could have a nice GUI interface with maybe each day having an little edit box to make notes for that day.

Maybe this is a good project for someone to make a Calendar object to show off their OOP skills?

.
Last edited by BasicCoder2 on Jan 01, 2017 14:35, edited 3 times in total.
lrcvs
Posts: 578
Joined: Mar 06, 2008 19:27
Location: Spain

Re: Simple Calendar (Show only one month)

Post by lrcvs »

Hi:

To Lothar Schirm:

See:

https://es.wikipedia.org/wiki/Anexo:A%C ... XXI_y_XXII

To BasicCoder2

Thanks!

Regards
Last edited by lrcvs on Jan 07, 2017 13:01, edited 1 time in total.
dodicat
Posts: 7976
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: Simple Calendar (Show only one month)

Post by dodicat »

BasicCoder2 wrote:Now you have the engine that generates the days for a given month in a given year you can use FreeBasic graphics to produce a really nice calendar display. It could have a nice GUI interface with maybe each day having an little edit box to make notes for that day.

Maybe this is a good project for someone to make a Calendar object to show off their OOP skills?

.
Nice simple -- and accurate -- calendar Ircvs.
IMHO better your own engine than Dateserial.

Basiccoder2
I made a gui thingy a few years ago.
The engine was an old quickbasic format.
Here it is with integers changed to longs for the 64 bit compiler.
It should cover the whole lifetime of the oldest forum member and the whole lifetime, to come, of the youngest

Code: Select all



'CALENDAR
#include "fbgfx.bi"
Dim Shared As Integer xres,yres
Screen 19,32,1,FB.GFX_ALPHA_PRIMITIVES
Screeninfo xres,yres
Windowtitle "FreeBASIC CALENDAR"
#macro incircle(cx,cy,radius,x,y)
(cx-x)*(cx-x) +(cy-y)*(cy-y)<= radius*radius
#endmacro

Type box
    As String text
    As Ulong colour
    As Long value,tx,ty,bx,by
End Type
Type Calendar_Month
    Number As Long  
    Month_name As String 
End Type
Declare Sub digits(t As String,x As Long,y As Long,clr As Ulong,sz As Long,img As Any Pointer=0)
Declare Function IsLeapYear(N As Long) As Long
Declare Sub PrintCalendar (_year As Long, _month As Long)
Declare Sub ComputeMonth (_year As Long, _month As Long, Byref StartDay As Long, Byref TotalDays As Long)
Declare Sub inspect(mx As Long,my As Long,mw As Long)
Dim Shared MonthData(1 To 12)   As Calendar_Month
Declare Sub initdata
Declare Sub initmonth
Declare Sub inityear
Declare Sub initdigits
Declare Sub dropmonth
Declare Sub dropyear
Declare Sub dropdigit1
Declare Sub dropdigit2
Declare Sub monthheader()
Declare Sub yearheader
Declare Function inbox(colour As Ulong,x As Long,y As Long) As Long
Declare Sub paintscreen
Declare Sub mouseloop()
Declare Sub checkevents(mx As Long,my As Long)
Declare Function allflags() As Long
Declare Function checktext() As Long
Dim Shared As Single m1,m2,y1,y2,BOXWIDTH,d11,d12,d21,d22,digitboxwidth
Dim Shared As Long monthflag,yearflag,digit1flag,digit2flag,printflag,endflag,nowflag
Dim Shared As fb.event e
Dim Shared As Long _month,_year
Dim Shared As String monthtext,yeartext,digit1text,digit2text,mday,_yr,mn,verse
boxwidth=.07
m1=.1:m2=m1+.07'.2
y1=m2:y2=y1+.07
digitboxwidth=.04
d11=y2:d12=y2+digitboxwidth
d21=d12:d22=d21+digitboxwidth
Dim Shared  As box mon(1 To 13),montxt(1 To 13)
Dim Shared  As box yr(1 To 4),yrtxt(1 To 4)
Dim Shared  As box digit1(9),digit1txt(9)
Dim Shared  As box digit2(9),digit2txt(9)
Dim Shared As Ulong offwhite=Rgb(250,251,252)
'_ MAIN ___________
initdata
initmonth
inityear
initdigits
mouseloop
'___________________


'PROCEDURES __________________

Sub initdata
    Restore dat2
    For I As Long = 1 To 12
        Read MonthData(I).Month_name, MonthData(I).Number
    Next 
End Sub

Sub initmonth 
    Dim s As String
    Dim count As Long
    Restore dat1
    For x As Long=1 To 13
        Read s
        mon(x).text=s
        mon(x).value=x-1
        mon(x).colour=Rgb(0,200,x)
        montxt(x).colour=Rgb(255,255,200+x)
    Next x
    mon(1).colour=Rgb(200,200,1)
    Restore
End Sub
Sub inityear
    yr(1).text="Year"
    yr(2).text="18"
    yr(3).text="19"
    yr(4).text="20"
    For x As Long=1 To 4
        yr(x).colour=Rgb(200,0,x)
        yrtxt(x).colour=Rgb(254,254,200+x)
    Next x
    yr(1).colour=Rgb(0,0,200)
End Sub
Sub initdigits
    For x As Long=0 To 9
        digit1(x).text=Str(x)
        digit2(x).text=Str(x)
        digit1(x).colour=Rgb(101,101,101+x)
        digit2(x).colour=Rgb(102,102,102+x)
        digit1txt(x).colour=Rgb(253,253,200+x)
        digit2txt(x).colour=Rgb(252,252,200+x)
    Next x
End Sub
Sub dropmonth
    Dim k As Long:Dim sz As Long=30
    For x As Long=1 To 13
        Line(m1*xres,.1*yres+k)-(m2*xres,.1*yres+sz+k),mon(x).colour,BF
        Line(m1*xres,.1*yres+k)-(m2*xres,.1*yres+sz+k),Rgb(0,0,0),B
        mon(x).tx=m1*xres:mon(x).ty=.1*yres+k
        mon(x).bx=m2*xres:mon(x).by=.1*yres+sz+k
        Draw String((m1+.01)*xres,.11*yres+k),mon(x).text,montxt(x).colour
        k=k+sz
    Next x
End Sub

Sub dropyear
    Dim k As Long:Dim sz As Long=30
    For x As Long=1 To 4
        Line(y1*xres,.1*yres+k)-(y2*xres,.1*yres+sz+k),yr(x).colour,BF
        Line(y1*xres,.1*yres+k)-(y2*xres,.1*yres+sz+k),Rgb(0,0,0),B
        yr(x).tx=y1*xres:yr(x).ty=.1*yres+k
        yr(x).bx=y2*xres:yr(x).by=.1*yres+sz+k
        Draw String((y1+.01)*xres,.11*yres+k),yr(x).text,yrtxt(x).colour
        k=k+sz
    Next x
End Sub

Sub dropdigit1
    Dim k As Long:Dim sz As Long=30
    For x As Long=0 To 9
        Line(d11*xres,.1*yres+k)-(d12*xres,.1*yres+sz+k),digit1(x).colour,BF
        Line(d11*xres,.1*yres+k)-(d12*xres,.1*yres+sz+k),Rgb(0,0,0),B
        digit1(x).tx=d11*xres:digit1(x).ty=.1*yres+k
        digit1(x).bx=d12*xres:digit1(x).by=.1*yres+sz+k
        Draw String((d11+.01)*xres,.11*yres+k),digit1(x).text,digit1txt(x).colour
        k=k+sz
    Next x
End Sub
Sub dropdigit2
    Dim k As Long:Dim sz As Long=30
    For x As Long=0 To 9
        Line(d21*xres,.1*yres+k)-(d22*xres,.1*yres+sz+k),digit2(x).colour,BF
        Line(d21*xres,.1*yres+k)-(d22*xres,.1*yres+sz+k),Rgb(0,0,0),B
        digit2(x).tx=d21*xres:digit2(x).ty=.1*yres+k
        digit2(x).bx=d22*xres:digit2(x).by=.1*yres+sz+k
        Draw String((d21+.01)*xres,.11*yres+k),digit2(x).text,digit2txt(x).colour
        k=k+sz
    Next x
End Sub

Sub monthheader()
    Dim k As Long
    Dim sz As Long=30
    Dim count As Long=1
    Line(m1*xres,.1*yres+k)-(m2*xres,.1*yres+sz+k),mon(1).colour,BF
    Line(m1*xres,.1*yres+k)-(m2*xres,.1*yres+sz+k),Rgb(0,0,0),B
    Draw String((m1+.01)*xres,.11*yres+k),mon(1).text,montxt(1).colour
End Sub
Sub yearheader
    Dim k As Long
    Dim sz As Long=30
    Dim count As Long
    Line(y1*xres,.1*yres+k)-(y2*xres,.1*yres+sz+k),yr(1).colour,BF
    Line(y1*xres,.1*yres+k)-(y2*xres,.1*yres+sz+k),Rgb(0,0,0),B
    Draw String((y1+.01)*xres,.11*yres+k),yr(1).text,yrtxt(1).colour 
End Sub

Function inbox(colour As Ulong,x As Long,y As Long) As Long
    If Point(x,y)=colour  Then
        Return -1
    Else
        Return 0
        Endif
    End Function
    
    Sub paintscreen
        Line(.1*xres,.1*yres)-(.9*xres,.9*yres),Rgb(2,2,2),B
        Paint (0,0),Rgb(236,233,216),Rgb(2,2,2)
        Paint(xres/2,yres/2),Rgb(255,255,255),Rgb(2,2,2) 
        Line(.4*xres,.2*yres)-(.89*xres,.7*yres),Rgb(0,0,0),BF 'black box
        For k As Long=-3 To 3 'blue frame
            Line(.4*xres+k,.2*yres-k)-(.89*xres-k,.7*yres+k),Rgb(0,150+30*k,236),B 
        Next k
    End Sub
    
    Sub checkevents(mx As Long,my As Long)
        'highlight month
        For x As Long = 2 To 13 
            If  inbox(mon(x).colour,mx,my) Or inbox(montxt(x).colour,mx,my) Then
                Line(mon(x).tx,mon(x).ty)-(mon(x).bx,mon(x).by),Rgb(255,255,255),b
            End If
        Next x
        'highlight year
        For x As Long = 2 To 4 
            If inbox(yr(x).colour,mx,my) Or inbox(yrtxt(x).colour,mx,my)Then 
            Line(yr(x).tx,yr(x).ty)-(yr(x).bx,yr(x).by),Rgb(255,255,255),b
        End If
    Next x
    'highlight digits
    For x As Long = 0 To 9  
        If inbox(digit1(x).colour,mx,my) Or inbox(digit1txt(x).colour,mx,my)Then 
        Line(digit1(x).tx,digit1(x).ty)-(digit1(x).bx,digit1(x).by),Rgb(255,255,255),b
    End If
Next x
For x As Long = 0 To 9  
    If inbox(digit2(x).colour,mx,my) Or inbox(digit2txt(x).colour,mx,my)Then 
    Line(digit2(x).tx,digit2(x).ty)-(digit2(x).bx,digit2(x).by),Rgb(255,255,255),b
End If
Next x

'HEADERS
If (Screenevent(@e)) Then
    If e.type=13 Then End
    
    If e.type=fb.EVENT_MOUSE_BUTTON_PRESS Then
        
        If inbox(mon(1).colour,mx,my) Or inbox(montxt(1).colour,mx,my)Then 
        monthflag=1
        nowflag=0
        Exit Sub
    End If
    
    If  inbox(yr(1).colour,mx,my) Or inbox(yrtxt(1).colour,mx,my)Then 
    yearflag=1
    nowflag=0
    Exit Sub
End If
'OTHERS (drop menus)

For x As Long = 2 To 13  
    If  inbox(mon(x).colour,mx,my) Or inbox(montxt(x).colour,mx,my) Then 
        _month=mon(x).value
        monthtext=mon(x).text
        Line(mon(x).tx,mon(x).ty)-(mon(x).bx,mon(x).by),Rgb(255,255,255),bf
        Exit Sub
    End If
Next x

For x As Long = 2 To 4  
    If inbox(yr(x).colour,mx,my) Or inbox(yrtxt(x).colour,mx,my)Then 
    yeartext=yr(x).text
    '_year=yr(x).value
    Line(yr(x).tx,yr(x).ty)-(yr(x).bx,yr(x).by),Rgb(255,255,255),bf
    Exit Sub
End If
Next x

For x As Long = 0 To 9  
    If inbox(digit1(x).colour,mx,my) Or inbox(digit1txt(x).colour,mx,my)Then 
    digit1text=digit1(x).text
    digit1flag=1
    Line(digit1(x).tx,digit1(x).ty)-(digit1(x).bx,digit1(x).by),Rgb(255,255,255),bf
    Exit Sub
End If
Next x

For x As Long = 0 To 9  
    If  inbox(digit2(x).colour,mx,my) Or inbox(digit2txt(x).colour,mx,my)Then 
    digit2text=digit2(x).text
    digit2flag=1
    Line(digit2(x).tx,digit2(x).ty)-(digit2(x).bx,digit2(x).by),Rgb(255,255,255),bf
    Exit Sub
End If
Next x   
If incircle(.5*xres,.8*yres,35,mx,my) Then
    _year=Valint(_yr): _month= Valint(mn )
    nowflag=1
    yearflag=0
    monthflag=0
    monthtext=""
    yeartext=""
    digit1text=""
    digit2text=""
    Exit Sub
End If
'LAST EVENT REACHED (date filled)

If incircle(.5*xres,.05*yres,xres/30,mx,my) Then 
    printflag=1
    Exit Sub
End If

End If 'e.type  

End If 'screvent
End Sub
Function allflags() As Long
    Dim sum As Long=monthflag+yearflag+digit1flag+digit2flag
    If sum=4 Then
        Return -1
    Else
        Return 0
    End If
End Function

Function checktext() As Long
    If monthtext="" Then Return 0
    If yeartext="" Then Return 0
    If digit1text="" Then Return 0
    If digit2text="" Then Return 0
    Return -1
End Function


Sub mouseloop()
    
    Dim As Long mx,my
    Do
        Getmouse mx,my
        mday=Mid(Date,4,2)
        _yr=Mid(Date,7,4)
        mn=Mid(Date,1,2)
        Screenlock
        Cls
        paintscreen
        If allflags And printflag Then
            For z As Single=35 To 30 Step -.1
                Circle(.5*xres,.8*yres),z,Rgb(0,150+30*z,236)
            Next z
            Circle(.5*xres,.8*yres),30,Rgb(0,0,0),,,,f
            Draw String(.485*xres,.79*yres),"Now"
        End If
        If nowflag=1 Then
            digits(Time,.52*xres,.13*yres,Rgb(100,0,0),10)
            Draw String(.215*xres,.37*yres),"Now",Rgb(0,0,0)
            #define pt(n) Draw String(.2*xres-n,.8*yres),verse,Rgb(0,00,0)
            ' dim as long temp3=12 (for testing rymes)
            Select Case _month
            Case 1
                verse="January brings the snow, Makes our feet and fingers glow."
                Draw String(.2*xres,.8*yres),verse,Rgb(0,00,0)
            Case 2
                verse="February brings the rain, Thaws the frozen lake again."
                pt(Len(verse))
            Case 3
                verse="March brings breezes loud and shrill, Stirs the golden daffodil."
                pt(Len(verse))
            Case 4
                verse="April brings the primrose sweet, Scatters daisies at our feet."
                pt(Len(verse))
            Case 5
                verse="May brings flocks of pretty lambs, Skipping by their fleecy dams."
                pt(Len(verse))
            Case 6
                verse="June brings tulips, lillies, roses, Fills the children's hands with posies."
                pt(Len(verse))
            Case 7
                verse="Hot July brings cooling showers, Apricots and gillyflowers."
                pt(Len(verse))
            Case 8
                verse="August brings the sheaves of corn, Then the harvest home is borne."
                pt(Len(verse))
            Case 9
                verse="Warm September brings the fruit, Sportsmen then begin to shoot."
                pt(Len(verse))
            Case 10
                verse="Fresh October brings the pheasant, Then to gather nuts is pleasant."
                pt(Len(verse))
            Case 11
                verse="Dull November brings the blast, Then the leaves are falling past."
                pt(Len(verse))
            Case 12
                verse="Chill December brings the sleet, Blazing fire and Christmas treat."
                pt(Len(verse))
            End Select
            inspect(185,230,2.5)
        End If
        monthheader
        yearheader
        If printflag=1 Then PrintCalendar _year, _month
        If monthflag=1 Then dropmonth:Draw String (.1*xres,.05*yres),monthtext,Rgb(0,0,0)
        If yearflag=1 Then 
            dropyear:Draw String (.15*xres,.05*yres),yeartext,Rgb(0,0,0)
            dropdigit1:Draw String (.17*xres,.05*yres),digit1text,Rgb(0,0,0)
            dropdigit2:Draw String (.18*xres,.05*yres),digit2text,Rgb(0,0,0)
        End If
        If (allflags And checktext) Then 
            If printflag=0 Then  
                Circle(.5*xres,.05*yres),xres/30,Rgb(100,100,100),,,,f
                Draw String(.475*xres,.04*yres),"Start",offwhite
            End If
            If nowflag=0 Then  _year=Valint(yeartext+digit1text+digit2text)
            
        End If
        If _year<1899 Then 
            printflag=0
            Draw String(10,10),"NOT BEFORE 1899 PLEASE",Rgb(255,0,0)
        End If
        
        checkevents(mx,my)
        Screenunlock
        Sleep 1,1
    Loop Until Inkey=Chr(27) Or endflag=1
End Sub
Sub ComputeMonth (_year As Long, _month As Long, Byref StartDay As Long,Byref TotalDays As Long) 
    Const LEAP = 366 Mod 7
    Const NORMAL = 365 Mod 7
    Dim As Long NumDays,I
    For I  = 1899 To _year- 1
        If IsLeapYear(I) Then            
            NumDays = NumDays + LEAP   
        Else                               
            NumDays = NumDays + NORMAL 
        End If
    Next
    
    For I = 1 To _month - 1
        NumDays = NumDays + MonthData(I).Number
    Next
    TotalDays = MonthData(_month).Number
    If IsLeapYear(_year) Then
        If _month > 2 Then
            NumDays = NumDays + 1
        Elseif _month = 2 Then
            TotalDays = TotalDays + 1
        End If
    End If
    StartDay = NumDays Mod 7
End Sub
Function IsLeapYear (N As Long) As Long
    IsLeapYear = (N Mod 4 = 0 And N Mod 100 <> 0) Or (N Mod 400 = 0)
End Function

Sub inspect(mx As Long,my As Long,mw As Long)
    If mw=0 Then mw=1
    mw=Abs(mw)
    For z As Long=0 To 16
        Line(mx-40+z,my-40+z)-(mx+40-z,my+40-z),Rgb(50*z/40,50*z/4,50*z/3.2),B
    Next z
    Dim As Ulong array(1 To 6561)
    Dim As Long count
    For x As Long=mx-40 To mx+40
        For y As Long=my-40 To my+40
            count=count+1
            array(count)=Point(x,y)
        Next y
    Next x
    count=0
    For x As Long=mx-40 To mx+40
        For y As Long=my-40 To my+40
            count=count+1
            Var NewX=mw*(x-mx)+mx
            Var NewY=mw*(y-my)+my 
            Line(NewX-mw/2,NewY-mw/2)-(NewX+mw/2,NewY+mw/2),array(count),BF
        Next y
    Next x
End Sub
Sub PrintCalendar (_year As Long, _month As Long) 'STATIC
    Dim As String header
    Dim As Long totaldays,_pos,_csrlin
    Dim As Long startday,leftmargin
    ComputeMonth _year, _month, StartDay, TotalDays
    Header = Rtrim(MonthData(_month).Month_name) + ", " + Str(_year)
    LeftMargin = (35 - Len(Header)) \ 2 
    Locate 15
    Print Tab(LeftMargin+50); Header
    Print
    Print Tab(50);"Su    M   Tu    W   Th    F   Sa"
    Print
    LeftMargin = 5 * StartDay + 1 
    Print Tab(LeftMargin+49);
    For I As Long = 1 To TotalDays
        Print Using "##_   "; I;
        If I=Valint(mday) Then
            _pos=Pos
            _csrlin=Csrlin 
            If nowflag=1 Then Circle(  (xres*(_pos)/100)-38,yres*_csrlin/37-15),13,Rgba(200,0,0,150),,,,f
        End If
        If Pos(0) > 82 Then Print Tab(50);
        
    Next
    
End Sub

dat1: 'for boxes
Data "Month","JAN","FEB","MAR","APR","MAY","JUN","JUL","AUG","SEP","OCT","NOV","DEC"
dat2:'for calendar
Data "January", 31, "February", 28,  "March", 31
Data "April", 30,   "May", 31, "June", 30, "July", 31, "August", 31
Data "September",   30, "October", 31, "November", 30, "December", 31
Sub digits(t As String,x As Long,y As Long,clr As Ulong,sz As Long,img As Any Pointer=0)
    x=x-2*sz
    Dim As Single s=Any,c=Any
    #macro thickline(x1,y1,x2,y2)
    s=(y1-y2)/10
    c=(x2-x1)/10
    Line img,(x1-s,y1-c)-(x2+s,y2+c),clr,bf
    #endmacro
    #macro display(_a,_b,_c,_d,_e,_f,_g)
    x=x+2*sz
    If _a=1 Then :thickline(x,y,(x+sz),y):End If
    If _b=1 Then :thickline((x+sz),y,(x+sz),(y+sz)):End If
    If _c=1 Then :thickline((x+sz),(y+sz),(x+sz),(y+2*sz)):End If 
    If _d=1 Then :thickline((x+sz),(y+2*sz),x,(y+2*sz)):End If
    If _e=1 Then :thickline(x,(y+2*sz),x,(y+sz)):End If
    If _f=1 Then :thickline(x,(y+sz),x,y):End If
    If _g=1 Then :thickline(x,(y+sz),(x+sz),(y+sz)):End If
    #endmacro
    For z As Long=0 To Len(t)-1
        Select Case As Const t[z]
        Case 48 :display(1,1,1,1,1,1,0)             '"0"
        Case 49 :display(0,1,1,0,0,0,0)             '"1"
        Case 50 :display(1,1,0,1,1,0,1)             '"2"
        Case 51 :display(1,1,1,1,0,0,1)             '"3"
        Case 52 :display(0,1,1,0,0,1,1)             '"4"
        Case 53 :display(1,0,1,1,0,1,1)             '"5"
        Case 54 :display(1,0,1,1,1,1,1)             '"6"
        Case 55 :display(1,1,1,0,0,0,0)             '"7"
        Case 56 :display(1,1,1,1,1,1,1)             '"8"
        Case 57 :display(1,1,1,1,0,1,1)            '"9"
        Case 58                                     '":"                   
            Circle((x+2*sz),(y+sz/2)),(sz/5),clr,,,,f
            Circle((x+2*sz),(y+1.5*sz)),(sz/5),clr,,,,f
            x=x+sz 
        Case 45 :display(0,0,0,0,0,0,1)              '"-"                       
        Case 46                                      '"."                       
            Circle((x+2*sz),(y+1.9*sz)),(sz/5),clr,,,,f
            x=x+sz 
        Case 32                                      '" "
            x=x+sz 
        End Select
    Next z
End Sub  

 
Tourist Trap
Posts: 2958
Joined: Jun 02, 2015 16:24

Re: Simple Calendar (Show only one month)

Post by Tourist Trap »

lrcvs wrote:Hi, all!

Happy New Year 2.017!!!
As for you Ircvs, and all fb community :)
lrcvs
Posts: 578
Joined: Mar 06, 2008 19:27
Location: Spain

Re: Simple Calendar (Show only one month)

Post by lrcvs »

Hi!

@ dodicat:

As always thanks for your good opinion!

Here, in Spain, we say:
"... that inspiration finds me working ..."
... It has just been a moment of lucidity ...
The merit is from "Zeller's congruence".

@ Tourist Trap: Equally for you!
Post Reply