173 lines
8.7 KiB
Rexx
173 lines
8.7 KiB
Rexx
/*REXX PROGRAM TO SHOW ANY YEAR'S (MONTHLY) CALENDAR (WITH/WITHOUT GRID)*/
|
|
@ABC=
|
|
PARSE VALUE SCRSIZE() WITH SD SW .
|
|
DO J=0 TO 255;_=D2C(J);IF DATATYPE(_,'L') THEN @ABC=@ABC||_;END
|
|
@ABCU=@ABC; UPPER @ABCU
|
|
DAYS_='SUNDAY MONDAY TUESDAY WEDNESDAY THURSDAY FRIDAY SATURDAY'
|
|
MONTHS_='JANUARY FEBRUARY MARCH APRIL MAY JUNE JULY AUGUST SEPTEMBER OCTOBER NOVEMBER DECEMBER'
|
|
DAYS=; MONTHS=
|
|
DO J=1 FOR 7
|
|
_=LOWER(WORD(DAYS_,J))
|
|
DAYS=DAYS TRANSLATE(LEFT(_,1))SUBSTR(_,2)
|
|
END
|
|
DO J=1 FOR 12
|
|
_=LOWER(WORD(MONTHS_,J))
|
|
MONTHS=MONTHS TRANSLATE(LEFT(_,1))SUBSTR(_,2)
|
|
END
|
|
CALFILL=' '; MC=12; _='1 3 1234567890' "FB"X
|
|
PARSE VAR _ GRID CALSPACES # CHK . CV_ DAYS.1 DAYS.2 DAYS.3 DAYSN
|
|
_=0; PARSE VAR _ COLS 1 JD 1 LOWERCASE 1 MAXKALPUTS 1 NARROW 1,
|
|
NARROWER 1 NARROWEST 1 SHORT 1 SHORTER 1 SHORTEST 1,
|
|
SMALL 1 SMALLER 1 SMALLEST 1 UPPERCASE
|
|
PARSE ARG MM '/' DD "/" YYYY _ '(' OPS; UOPS=OPS
|
|
IF _\=='' | \IS#(MM) | \IS#(DD) | \IS#(YYYY) THEN CALL ERX 86
|
|
|
|
@CALMONTHS ='CALMON' || LOWER('THS')
|
|
@CALSPACES ='CALSP' || LOWER('ACES')
|
|
@DEPTH ='DEP' || LOWER('TH')
|
|
@GRIDS ='GRID' || LOWER('S')
|
|
@LOWERCASE ='LOW' || LOWER('ERCASE')
|
|
@NARROW ='NAR' || LOWER('ROW')
|
|
@NARROWER ='NARROWER'
|
|
@NARROWEST ='NARROWES' || LOWER('T')
|
|
@SHORT ='SHOR' || LOWER('T')
|
|
@SHORTER ='SHORTER'
|
|
@SHORTEST ='SHORTES' || LOWER('T')
|
|
@UPPERCASE ='UPP' || LOWER('ERCASE')
|
|
@WIDTH ='WID' || LOWER('TH')
|
|
DO WHILE OPS\==''; OPS=STRIP(OPS,'L'); PARSE VAR OPS _1 2 1 _ . 1 _O OPS
|
|
UPPER _
|
|
SELECT
|
|
WHEN ABB(@CALMONTHS) THEN MC=NAI()
|
|
WHEN ABB(@CALSPACES) THEN CALSPACES=NAI()
|
|
WHEN ABB(@DEPTH) THEN SD=NAI()
|
|
WHEN ABBN(@GRIDS) THEN GRID=NO()
|
|
WHEN ABBN(@LOWERCASE) THEN LOWERCASE=NO()
|
|
WHEN ABBN(@NARROW) THEN NARROW=NO()
|
|
WHEN ABBN(@NARROWER) THEN NARROWER=NO()
|
|
WHEN ABBN(@NARROWEST) THEN NARROWEST=NO()
|
|
WHEN ABBN(@SHORT) THEN SHORT=NO()
|
|
WHEN ABBN(@SHORTER) THEN SHORTER=NO()
|
|
WHEN ABBN(@SHORTEST) THEN SHORTEST=NO()
|
|
WHEN ABBN(@SMALL) THEN SMALL=NO()
|
|
WHEN ABBN(@SMALLER) THEN SMALLER=NO()
|
|
WHEN ABBN(@SMALLEST) THEN SMALLEST=NO()
|
|
WHEN ABBN(@UPPERCASE) THEN UPPERCASE=NO()
|
|
WHEN ABB(@WIDTH) THEN SW=NAI()
|
|
OTHERWISE NOP
|
|
END /*SELECT*/
|
|
END /*DO WHILE OPTS\== ...*/
|
|
|
|
IF SD==0 THEN SD= 43; SD= SD-3
|
|
IF SW==0 THEN SW= 80; SW= SW-1
|
|
MC=INT(MC,'MONTHSCALENDER'); IF MC>0 THEN CAL=1
|
|
DAYS=' 'DAYS; MONTHS=' 'MONTHS
|
|
CYYYY=RIGHT(DATE(),4); HYY=LEFT(CYYYY,2); LYY=RIGHT(CYYYY,2)
|
|
DY.=31; _=30; PARSE VAR _ DY.4 1 DY.6 1 DY.9 1 DY.11; DY.2=28+LY(YYYY)
|
|
YY=RIGHT(YYYY,2); CW=10; CINDENT=1; CALWIDTH=76
|
|
IF SMALL THEN DO; NARROW=1 ; SHORT=1 ; END
|
|
IF SMALLER THEN DO; NARROWER=1 ; SHORTER=1 ; END
|
|
IF SMALLEST THEN DO; NARROWEST=1; SHORTEST=1; END
|
|
IF SHORTEST THEN SHORTER=1
|
|
IF SHORTER THEN SHORT =1
|
|
IF NARROW THEN DO; CW=9; CINDENT=3; CALWIDTH=69; END
|
|
IF NARROWER THEN DO; CW=4; CINDENT=1; CALWIDTH=34; END
|
|
IF NARROWEST THEN DO; CW=2; CINDENT=1; CALWIDTH=20; END
|
|
CV_=CALWIDTH+CALSPACES+2
|
|
CALFILL=LEFT(COPIES(CALFILL,CW),CW)
|
|
DO J=1 FOR 7; _=WORD(DAYS,J)
|
|
DO JW=1 FOR 3; _D=STRIP(SUBSTR(_,CW*JW-CW+1,CW))
|
|
IF JW=1 THEN _D=CENTRE(_D,CW+1)
|
|
ELSE _D=LEFT(_D,CW+1)
|
|
DAYS.JW=DAYS.JW||_D
|
|
END /*JW*/
|
|
__=DAYSN
|
|
IF NARROWER THEN DAYSN=__||CENTRE(LEFT(_,3),5)
|
|
IF NARROWEST THEN DAYSN=__||CENTER(LEFT(_,2),3)
|
|
END /*J*/
|
|
_YYYY=YYYY; CALPUTS=0; CV=1; _MM=MM+0; MONTH=WORD(MONTHS,MM)
|
|
DY.2=28+LY(_YYYY); DIM=DY._MM; _DD=01; DOW=DOW(_MM,_DD,_YYYY); $DD=DD+0
|
|
|
|
/*─────────────────────────────NOW: THE BUSINESS OF THE BUILDING THE CAL*/
|
|
CALL CALGEN
|
|
DO _J=2 TO MC
|
|
IF CV_\=='' THEN DO
|
|
CV=CV+CV_
|
|
IF CV+CV_>=SW THEN DO; CV=1; CALL CALPUT
|
|
CALL FCALPUTS;CALL CALPB
|
|
END
|
|
ELSE CALPUTS=0
|
|
END
|
|
ELSE DO;CALL CALPB;CALL CALPUT;CALL FCALPUTS;END
|
|
_MM=_MM+1; IF _MM==13 THEN DO; _MM=1; _YYYY=_YYYY+1; END
|
|
MONTH=WORD(MONTHS,_MM); DY.2=28+LY(_YYYY); DIM=DY._MM
|
|
DOW=DOW(_MM,_DD,_YYYY); $DD=0; CALL CALGEN
|
|
END /*_J*/
|
|
CALL FCALPUTS
|
|
RETURN _
|
|
|
|
/*─────────────────────────────CALGEN SUBROUTINE────────────────────────*/
|
|
CALGEN: CELLX=;CELLJ=;CELLM=;CALCELLS=0;CALLINE=0
|
|
CALL CALPUT
|
|
CALL CALPUTL COPIES('─',CALWIDTH),"┌┐"; CALL CALHD
|
|
CALL CALPUTL MONTH ' ' _YYYY ; CALL CALHD
|
|
IF NARROWEST | NARROWER THEN CALL CALPUTL DAYSN
|
|
ELSE DO JW=1 FOR 3
|
|
IF SPACE(DAYS.JW)\=='' THEN CALL CALPUTL DAYS.JW
|
|
END
|
|
CALFT=1; CALFB=0
|
|
DO JF=1 FOR DOW-1; CALL CELLDRAW CALFILL,CALFILL; END
|
|
DO JY=1 FOR DIM; CALL CELLDRAW JY; END
|
|
CALFB=1
|
|
DO 7; CALL CELLDRAW CALFILL,CALFILL; END
|
|
IF SD>32 & \SHORTER THEN CALL CALPUT
|
|
RETURN
|
|
|
|
/*─────────────────────────────CELLDRAW SUBROUTINE──────────────────────*/
|
|
CELLDRAW: PARSE ARG ZZ,CDDOY;ZZ=RIGHT(ZZ,2);CALCELLS=CALCELLS+1
|
|
IF CALCELLS>7 THEN DO
|
|
CALLINE=CALLINE+1
|
|
CELLX=SUBSTR(CELLX,2)
|
|
CELLJ=SUBSTR(CELLJ,2)
|
|
CELLM=SUBSTR(CELLM,2)
|
|
CELLB=TRANSLATE(CELLX,,")(─-"#)
|
|
IF CALLINE==1 THEN CALL CX
|
|
CALL CALCSM; CALL CALPUTL CELLX; CALL CALCSJ; CALL CX
|
|
CELLX=; CELLJ=; CELLM=; CALCELLS=1
|
|
END
|
|
CDDOY=RIGHT(CDDOY,CW); CELLM=CELLM'│'CENTER('',CW)
|
|
CELLX=CELLX'│'CENTRE(ZZ,CW); CELLJ=CELLJ'│'CENTER('',CW)
|
|
RETURN
|
|
|
|
/*═════════════════════════════GENERAL 1-LINE SUBS══════════════════════*/
|
|
ABB:ARG ABBU;PARSE ARG ABB;RETURN ABBREV(ABBU,_,ABBL(ABB))
|
|
ABBL:RETURN VERIFY(ARG(1)LEFT(@ABC,1),@ABC,'M')-1
|
|
ABBN:PARSE ARG ABBN;RETURN ABB(ABBN)|ABB('NO'ABBN)
|
|
CALCSJ:IF SD>49&\SHORTER THEN CALL CALPUTL CELLB;IF SD>24&\SHORT THEN CALL CALPUTL CELLJ; RETURN
|
|
CALCSM:IF SD>24&\SHORT THEN CALL CALPUTL CELLM;IF SD>49&\SHORTER THEN CALL CALPUTL CELLB;RETURN
|
|
CALHD:IF SD>24&\SHORTER THEN CALL CALPUTL;IF SD>32&\SHORTEST THEN CALL CALPUTL;RETURN
|
|
CALPB:IF \GRID&SHORTEST THEN CALL PUT CHK;RETURN
|
|
CALPUT:CALPUTS=CALPUTS+1;MAXKALPUTS=MAX(MAXKALPUTS,CALPUTS);IF SYMBOL('CT.'CALPUTS)\=='VAR' THEN CT.CALPUTS=;CT.CALPUTS=OVERLAY(ARG(1),CT.CALPUTS,CV);RETURN
|
|
CALPUTL:CALL CALPUT COPIES(' ',CINDENT)LEFT(ARG(2)"│",1)CENTER(ARG(1),CALWIDTH)||RIGHT('│'ARG(2),1);RETURN
|
|
CX:CX_='├┤';CX=COPIES(COPIES('─',CW)'┼',7);IF CALFT THEN DO;CX=TRANSLATE(CX,'┬',"┼");CALFT=0;END;IF CALFB THEN DO;CX=TRANSLATE(CX,'┴',"┼");CX_='└┘';CALFB=0;END;CALL CALPUTL CX,CX_;RETURN
|
|
DOW:PROCEDURE;ARG M,D,Y;IF M<3 THEN DO;M=M+12;Y=Y-1;END;YL=LEFT(Y,2);YR=RIGHT(Y,2);W=(D+(M+1)*26%10+YR+YR%4+YL%4+5*YL)//7;IF W==0 THEN W=7;RETURN W
|
|
ER:PARSE ARG _1,_2;CALL '$ERR' "14"P(_1) P(WORD(_1,2) !FID(1)) _2;IF _1<0 THEN RETURN _1;EXIT RESULT
|
|
ERR:CALL ER '-'ARG(1),ARG(2);RETURN ''
|
|
ERX:CALL ER '-'ARG(1),ARG(2);EXIT ''
|
|
FCALPUTS: DO J=1 FOR MAXKALPUTS;CALL PUT CT.J;END;CT.=;MAXKALPUTS=0;CALPUTS=0;RETURN
|
|
INT:INT=NUMX(ARG(1),ARG(2));IF \ISINT(INT) THEN CALL ERX 92,ARG(1) ARG(2);RETURN INT/1
|
|
IS#:RETURN VERIFY(ARG(1),#)==0
|
|
ISINT:RETURN DATATYPE(ARG(1),'W')
|
|
LOWER:RETURN TRANSLATE(ARG(1),@ABC,@ABCU)
|
|
LY:ARG _;IF LENGTH(_)==2 THEN _=HYY||_;LY=_//4==0;IF LY==0 THEN RETURN 0;LY=((_//100\==0)|_//400==0);RETURN LY
|
|
NA:IF ARG(1)\=='' THEN CALL ERX 01,ARG(2);PARSE VAR OPS NA OPS;IF NA=='' THEN CALL ERX 35,_O;RETURN NA
|
|
NAI:RETURN INT(NA(),_O)
|
|
NAN:RETURN NUMX(NA(),_O)
|
|
NO:IF ARG(1)\=='' THEN CALL ERX 01,ARG(2);RETURN LEFT(_,2)\=='NO'
|
|
NUM:PROCEDURE;PARSE ARG X .,F,Q;IF X=='' THEN RETURN X;IF DATATYPE(X,'N') THEN RETURN X/1;X=SPACE(TRANSLATE(X,,','),0);IF DATATYPE(X,'N') THEN RETURN X/1;RETURN NUMNOT()
|
|
NUMNOT:IF Q==1 THEN RETURN X;IF Q=='' THEN CALL ER 53,X F;CALL ERX 53,X F
|
|
NUMX:RETURN NUM(ARG(1),ARG(2),1)
|
|
P:RETURN WORD(ARG(1),1)
|
|
PUT:_=ARG(1);_=TRANSLATE(_,,'_'CHK);IF \GRID THEN _=UNGRID(_);IF LOWERCASE THEN _=LOWER(_);IF UPPERCASE THEN UPPER _;IF SHORTEST&_=' ' THEN RETURN;CALL TELL _;RETURN
|
|
TELL:SAY ARG(1);RETURN
|
|
UNGRID:RETURN TRANSLATE(ARG(1),,"│║─═┤┐└┴┬├┼┘┌╔╗╚╝╟╢╞╡╫╪╤╧╥╨╠╣")
|