/*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),,"│║─═┤┐└┴┬├┼┘┌╔╗╚╝╟╢╞╡╫╪╤╧╥╨╠╣")