Another update from ingydotnet^djgoku
This commit is contained in:
Ingy döt Net
parent
91df62d461
commit
948b86eafa
7604 changed files with 108452 additions and 22726 deletions
|
|
@ -0,0 +1,75 @@
|
|||
(QL:QUICKLOAD '(DATE-CALC))
|
||||
|
||||
(DEFPARAMETER *DAY-ROW* "SU MO TU WE TH FR SA")
|
||||
(DEFPARAMETER *CALENDAR-MARGIN* 3)
|
||||
|
||||
(DEFUN MONTH-TO-WORD (MONTH)
|
||||
"TRANSLATE A MONTH FROM 1 TO 12 INTO ITS WORD REPRESENTATION."
|
||||
(SVREF #("JANUARY" "FEBRUARY" "MARCH" "APRIL"
|
||||
"MAY" "JUNE" "JULY" "AUGUST"
|
||||
"SEPTEMBER" "OCTOBER" "NOVEMBER" "DECEMBER")
|
||||
(1- MONTH)))
|
||||
|
||||
(DEFUN MONTH-STRINGS (YEAR MONTH)
|
||||
"COLLECT ALL OF THE STRINGS THAT MAKE UP A CALENDAR FOR A GIVEN
|
||||
MONTH AND YEAR."
|
||||
`(,(DATE-CALC:CENTER (MONTH-TO-WORD MONTH) (LENGTH *DAY-ROW*))
|
||||
,*DAY-ROW*
|
||||
;; WE CAN ASSUME THAT A MONTH CALENDAR WILL ALWAYS FIT INTO A 7 BY 6 BLOCK
|
||||
;; OF VALUES. THIS MAKES IT EASY TO FORMAT THE RESULTING STRINGS.
|
||||
,@ (LET ((DAYS (MAKE-ARRAY (* 7 6) :INITIAL-ELEMENT NIL)))
|
||||
(LOOP :FOR I :FROM (DATE-CALC:DAY-OF-WEEK YEAR MONTH 1)
|
||||
:FOR DAY :FROM 1 :TO (DATE-CALC:DAYS-IN-MONTH YEAR MONTH)
|
||||
:DO (SETF (AREF DAYS I) DAY))
|
||||
(LOOP :FOR I :FROM 0 :TO 5
|
||||
:COLLECT
|
||||
(FORMAT NIL "~{~:[ ~;~2,D~]~^ ~}"
|
||||
(LOOP :FOR DAY :ACROSS (SUBSEQ DAYS (* I 7) (+ 7 (* I 7)))
|
||||
:APPEND (IF DAY (LIST DAY DAY) (LIST DAY))))))))
|
||||
|
||||
(DEFUN CALC-COLUMNS (CHARACTERS MARGIN-SIZE)
|
||||
"CALCULATE THE NUMBER OF COLUMNS GIVEN THE NUMBER OF CHARACTERS PER
|
||||
COLUMN AND THE MARGIN-SIZE BETWEEN THEM."
|
||||
(MULTIPLE-VALUE-BIND (COLS EXCESS)
|
||||
(TRUNCATE CHARACTERS (+ MARGIN-SIZE (LENGTH *DAY-ROW*)))
|
||||
(INCF EXCESS MARGIN-SIZE)
|
||||
(IF (>= EXCESS (LENGTH *DAY-ROW*))
|
||||
(1+ COLS)
|
||||
COLS)))
|
||||
|
||||
(DEFUN TAKE (N LIST)
|
||||
"TAKE THE FIRST N ELEMENTS OF A LIST."
|
||||
(LOOP :REPEAT N :FOR X :IN LIST :COLLECT X))
|
||||
|
||||
(DEFUN DROP (N LIST)
|
||||
"DROP THE FIRST N ELEMENTS OF A LIST."
|
||||
(COND ((OR (<= N 0) (NULL LIST)) LIST)
|
||||
(T (DROP (1- N) (CDR LIST)))))
|
||||
|
||||
(DEFUN CHUNKS-OF (N LIST)
|
||||
"SPLIT THE LIST INTO CHUNKS OF SIZE N."
|
||||
(ASSERT (> N 0))
|
||||
(LOOP :FOR X := LIST :THEN (DROP N X)
|
||||
:WHILE X
|
||||
:COLLECT (TAKE N X)))
|
||||
|
||||
(DEFUN PRINT-CALENDAR (YEAR &KEY (CHARACTERS 80) (MARGIN-SIZE 3))
|
||||
"PRINT OUT THE CALENDAR FOR A GIVEN YEAR, OPTIONALLY SPECIFYING
|
||||
A WIDTH LIMIT IN CHARACTERS AND MARGIN-SIZE BETWEEN MONTHS."
|
||||
(ASSERT (>= CHARACTERS (LENGTH *DAY-ROW*)))
|
||||
(ASSERT (>= MARGIN-SIZE 0))
|
||||
(LET* ((CALENDARS (LOOP :FOR MONTH :FROM 1 :TO 12
|
||||
:COLLECT (MONTH-STRINGS YEAR MONTH)))
|
||||
(COLUMN-COUNT (CALC-COLUMNS CHARACTERS MARGIN-SIZE))
|
||||
(TOTAL-SIZE (+ (* COLUMN-COUNT (LENGTH *DAY-ROW*))
|
||||
(* (1- COLUMN-COUNT) MARGIN-SIZE)))
|
||||
(FORMAT-STRING (CONCATENATE 'STRING
|
||||
"~{~A~^~" (WRITE-TO-STRING MARGIN-SIZE) ",0@T~}~%")))
|
||||
(FORMAT T "~A~%~A~%~%"
|
||||
(DATE-CALC:CENTER "[SNOOPY]" TOTAL-SIZE)
|
||||
(DATE-CALC:CENTER (WRITE-TO-STRING YEAR) TOTAL-SIZE))
|
||||
(LOOP :FOR ROW :IN (CHUNKS-OF COLUMN-COUNT CALENDARS)
|
||||
:DO (APPLY 'MAPCAR
|
||||
(LAMBDA (&REST HEADS)
|
||||
(FORMAT T FORMAT-STRING HEADS))
|
||||
ROW))))
|
||||
|
|
@ -6,8 +6,6 @@
|
|||
#define extensions'math.
|
||||
#define extensions'routines.
|
||||
|
||||
// --- calendar ---
|
||||
|
||||
#symbol MonthNames = ("JANUARY","FEBRUARY","MARCH","APRIL","MAY","JUNE","JULY","AUGUST","SEPTEMBER","OCTOBER","NOVEMBER","DECEMBER").
|
||||
#symbol DayNames = ("MO", "TU", "WE", "TH", "FR", "SA", "SU").
|
||||
|
||||
|
|
@ -19,60 +17,67 @@
|
|||
#field theYear.
|
||||
#field theRow.
|
||||
|
||||
#constructor new &Year:aYear &Month:aMonth
|
||||
#constructor new &year:aYear &month:aMonth
|
||||
[
|
||||
theMonth := aMonth.
|
||||
theYear := aYear.
|
||||
theLine := TextBuffer new.
|
||||
theRow := Integer new.
|
||||
theRow := Integer new &int:0.
|
||||
]
|
||||
|
||||
#method firstLine : aDay
|
||||
#method writeTitle
|
||||
[
|
||||
theRow << 0.
|
||||
theDate := Date new &Year:theYear &Month:theMonth &Day:aDay.
|
||||
control foreach:DayNames &do: aName
|
||||
[ theLine write:" " write:aName ].
|
||||
theDate := Date new &year:(theYear int) &month:(theMonth int) &day:1.
|
||||
DayNames run &each: aName
|
||||
[ theLine writeLiteral:" ":aName ].
|
||||
]
|
||||
|
||||
#method nextLine
|
||||
#method writeLine
|
||||
[
|
||||
theLine clear.
|
||||
|
||||
(theDate Month == theMonth)
|
||||
(theDate month == theMonth)
|
||||
? [
|
||||
theLine~stringOp write:" " &length:(((theDate DayOfWeek) => 0 ? [ 7 ] ! [ theDate DayOfWeek ]) subtract:1 int).
|
||||
theLine write:" " &length:(((theDate dayOfWeek) => 0 ? [ 7 ] ! [ theDate dayOfWeek ]) - 1).
|
||||
|
||||
control do:
|
||||
[
|
||||
theLine~stringOp write:(theDate Day) &paddingLeft:3 &with:" ".
|
||||
theLine write:(theDate day literal) &paddingLeft:3 &with:#32.
|
||||
|
||||
theDate := theDate add &Days:1.
|
||||
theDate := theDate add &days:1.
|
||||
]
|
||||
&until:[(theDate Month != theMonth)or:[theDate DayOfWeek == 1]].
|
||||
&until:[(theDate month != theMonth)or:[theDate dayOfWeek == 1]].
|
||||
].
|
||||
|
||||
#var(type:int) aLength := theLine length.
|
||||
(aLength < 21)
|
||||
? [ theLine~stringOp write:" " &length:(21 - aLength). ].
|
||||
? [ theLine write:" " &length:(21 - aLength). ].
|
||||
|
||||
theRow += 1.
|
||||
|
||||
^ theRow < 7.
|
||||
]
|
||||
|
||||
#method enumerator =
|
||||
#method iterator = Iterator
|
||||
{
|
||||
set &index:anIndex [ self firstLine:(anIndex + 1) ]
|
||||
available = theRow < 7.
|
||||
|
||||
next [ ^ self nextLine. ]
|
||||
readIndex &vint:anIndex [ anIndex << theRow int. ]
|
||||
|
||||
write &index:anIndex
|
||||
[
|
||||
(anIndex <= theRow)
|
||||
? [ self writeTitle. ].
|
||||
|
||||
#loop (anIndex > theRow) ?
|
||||
[ self writeLine. ].
|
||||
]
|
||||
|
||||
get = self.
|
||||
}.
|
||||
|
||||
#method printTitleTo : anOutput
|
||||
[
|
||||
anOutput~stringOp write:(MonthNames @(theMonth - 1)) &padding:21 &with:" ".
|
||||
anOutput write:(MonthNames @(theMonth - 1)) &padding:21 &with:#32.
|
||||
]
|
||||
|
||||
#method printTo : anOutput
|
||||
|
|
@ -83,8 +88,8 @@
|
|||
|
||||
#class Calendar
|
||||
{
|
||||
#field theYear.
|
||||
#field theRowLength.
|
||||
#field(type:int) theYear.
|
||||
#field(type:int) theRowLength.
|
||||
|
||||
#constructor new : aYear
|
||||
[
|
||||
|
|
@ -94,15 +99,19 @@
|
|||
|
||||
#method printTo:anOutput
|
||||
[
|
||||
anOutput~stringOp write:"[SNOOPY]" &padding:(theRowLength * 25) &with:" " writeLine.
|
||||
anOutput~stringOp write:theYear &padding:(theRowLength * 25) &with:" " writeLine writeLine.
|
||||
anOutput write:"[SNOOPY]" &padding:(theRowLength * 25) &with:#32.
|
||||
anOutput writeLine.
|
||||
anOutput write:(theYear literal) &padding:(theRowLength * 25) &with:#32.
|
||||
anOutput writeLine writeLine.
|
||||
|
||||
#var aRowCount := 12 / theRowLength.
|
||||
#var Months := matrixControl new &m:aRowCount &n:theRowLength &each: (:i:j) [ CalendarMonthPrinter new &Year:theYear &Month:(i * theRowLength + j + 1) ].
|
||||
#var Months := Array new &length:aRowCount set &every:(&index:i)
|
||||
[ Array new &length:theRowLength set &every:(&index:j)
|
||||
[ CalendarMonthPrinter new &year:(theYear int) &month:((i * theRowLength + j + 1) int) ]].
|
||||
|
||||
control foreach:Months &do: aRow
|
||||
Months run &each: aRow
|
||||
[
|
||||
control foreach:aRow &do: aMonth
|
||||
aRow run &each: aMonth
|
||||
[
|
||||
aMonth printTitleTo:anOutput.
|
||||
|
||||
|
|
@ -111,9 +120,9 @@
|
|||
|
||||
anOutput writeLine.
|
||||
|
||||
control for:(ParallelEnumerator new:aRow) &do: aLine
|
||||
ParallelEnumerator new:aRow run &each: aLine
|
||||
[
|
||||
control foreach:aLine &do: aPrinter
|
||||
aLine run &each: aPrinter
|
||||
[
|
||||
aPrinter printTo:anOutput.
|
||||
|
||||
|
|
@ -123,17 +132,14 @@
|
|||
anOutput writeLine.
|
||||
].
|
||||
].
|
||||
|
||||
]
|
||||
}
|
||||
|
||||
// --- program ---
|
||||
|
||||
#symbol program =
|
||||
[
|
||||
#var aCalender := Calendar new:(consoleEx write:"Enter the year:" readLine:(Integer new)).
|
||||
#var aCalender := Calendar new:(console write:"ENTER THE YEAR:" readLine:(Integer new)).
|
||||
|
||||
aCalender printTo:consoleEx.
|
||||
aCalender printTo:console.
|
||||
|
||||
consoleEx readChar.
|
||||
console readChar.
|
||||
].
|
||||
|
|
|
|||
|
|
@ -0,0 +1,175 @@
|
|||
MODULE DATEGNASH
|
||||
|
||||
TYPE DATEBAG
|
||||
INTEGER DAY,MONTH,YEAR
|
||||
END TYPE DATEBAG
|
||||
|
||||
CHARACTER*9 MONTHNAME(12),DAYNAME(0:6)
|
||||
PARAMETER (MONTHNAME = (/"JANUARY","FEBRUARY","MARCH","APRIL",
|
||||
1 "MAY","JUNE","JULY","AUGUST","SEPTEMBER","OCTOBER","NOVEMBER",
|
||||
2 "DECEMBER"/))
|
||||
PARAMETER (DAYNAME = (/"SUNDAY","MONDAY","TUESDAY","WEDNESDAY",
|
||||
1 "THURSDAY","FRIDAY","SATURDAY"/))
|
||||
|
||||
INTEGER*4 JDAYSHIFT
|
||||
PARAMETER (JDAYSHIFT = 2415020)
|
||||
CONTAINS
|
||||
INTEGER FUNCTION LSTNB(TEXT)
|
||||
CHARACTER*(*),INTENT(IN):: TEXT
|
||||
INTEGER L
|
||||
L = LEN(TEXT)
|
||||
1 IF (L.LE.0) GO TO 2
|
||||
IF (ICHAR(TEXT(L:L)).GT.ICHAR(" ")) GO TO 2
|
||||
L = L - 1
|
||||
GO TO 1
|
||||
2 LSTNB = L
|
||||
RETURN
|
||||
END FUNCTION LSTNB
|
||||
CHARACTER*2 FUNCTION I2FMT(N)
|
||||
INTEGER*4 N
|
||||
IF (N.LT.0) THEN
|
||||
IF (N.LT.-9) THEN
|
||||
I2FMT = "-!"
|
||||
ELSE
|
||||
I2FMT = "-"//CHAR(ICHAR("0") - N)
|
||||
END IF
|
||||
ELSE IF (N.LT.10) THEN
|
||||
I2FMT = " " //CHAR(ICHAR("0") + N)
|
||||
ELSE IF (N.LT.100) THEN
|
||||
I2FMT = CHAR(N/10 + ICHAR("0"))
|
||||
1 //CHAR(MOD(N,10) + ICHAR("0"))
|
||||
ELSE
|
||||
I2FMT = "+!"
|
||||
END IF
|
||||
END FUNCTION I2FMT
|
||||
CHARACTER*8 FUNCTION I8FMT(N)
|
||||
INTEGER*4 N
|
||||
CHARACTER*8 HIC
|
||||
WRITE (HIC,1) N
|
||||
1 FORMAT (I8)
|
||||
I8FMT = HIC
|
||||
END FUNCTION I8FMT
|
||||
|
||||
SUBROUTINE SAY(OUT,TEXT)
|
||||
INTEGER OUT
|
||||
CHARACTER*(*) TEXT
|
||||
WRITE (6,1) TEXT(1:LSTNB(TEXT))
|
||||
1 FORMAT (A)
|
||||
END SUBROUTINE SAY
|
||||
|
||||
INTEGER*4 FUNCTION DAYNUM(YY,M,D)
|
||||
INTEGER*4 JDAYN
|
||||
INTEGER YY,Y,M,MM,D
|
||||
Y = YY
|
||||
IF (Y.LT.1) Y = Y + 1
|
||||
MM = (M - 14)/12
|
||||
JDAYN = D - 32075
|
||||
A + 1461*(Y + 4800 + MM)/4
|
||||
B + 367*(M - 2 - MM*12)/12
|
||||
C - 3*((Y + 4900 + MM)/100)/4
|
||||
DAYNUM = JDAYN - JDAYSHIFT
|
||||
END FUNCTION DAYNUM
|
||||
|
||||
TYPE(DATEBAG) FUNCTION MUNYAD(DAYNUM)
|
||||
INTEGER*4 DAYNUM,JDAYN
|
||||
INTEGER Y,M,D,L,N
|
||||
JDAYN = DAYNUM + JDAYSHIFT
|
||||
L = JDAYN + 68569
|
||||
N = 4*L/146097
|
||||
L = L - (146097*N + 3)/4
|
||||
Y = 4000*(L + 1)/1461001
|
||||
L = L - 1461*Y/4 + 31
|
||||
M = 80*L/2447
|
||||
D = L - 2447*M/80
|
||||
L = M/11
|
||||
M = M + 2 - 12*L
|
||||
Y = 100*(N - 49) + Y + L
|
||||
IF (Y.LT.1) Y = Y - 1
|
||||
MUNYAD%YEAR = Y
|
||||
MUNYAD%MONTH = M
|
||||
MUNYAD%DAY = D
|
||||
END FUNCTION MUNYAD
|
||||
|
||||
INTEGER FUNCTION PMOD(N,M)
|
||||
INTEGER N,M
|
||||
PMOD = MOD(MOD(N,M) + M,M)
|
||||
END FUNCTION PMOD
|
||||
|
||||
SUBROUTINE CALENDAR(Y1,Y2,COLUMNS)
|
||||
|
||||
INTEGER Y1,Y2,YEAR
|
||||
INTEGER M,M1,M2,MONTH
|
||||
INTEGER*4 DN1,DN2,DN,D
|
||||
INTEGER W,G
|
||||
INTEGER L,LINE
|
||||
INTEGER COL,COLUMNS,COLWIDTH
|
||||
CHARACTER*200 STRIPE(6),SPECIAL(6),MLINE,DLINE
|
||||
W = 3
|
||||
G = 1
|
||||
COLWIDTH = 7*W + G
|
||||
Y:DO YEAR = Y1,Y2
|
||||
CALL SAY(MSG,"")
|
||||
IF (YEAR.EQ.0) THEN
|
||||
CALL SAY(MSG,"THERE IS NO YEAR ZERO.")
|
||||
CYCLE Y
|
||||
END IF
|
||||
MLINE = ""
|
||||
L = (COLUMNS*COLWIDTH - G - 8)/2
|
||||
IF (YEAR.GT.0) THEN
|
||||
MLINE(L:) = I8FMT(YEAR)
|
||||
ELSE
|
||||
MLINE(L - 1:) = I8FMT(-YEAR)//"BC"
|
||||
END IF
|
||||
CALL SAY(MSG,MLINE)
|
||||
DO MONTH = 1,12,COLUMNS
|
||||
M1 = MONTH
|
||||
M2 = MIN(12,M1 + COLUMNS - 1)
|
||||
MLINE = ""
|
||||
DLINE = ""
|
||||
STRIPE = ""
|
||||
SPECIAL = ""
|
||||
L0 = 1
|
||||
DO M = M1,M2
|
||||
L = (COLWIDTH - G - LSTNB(MONTHNAME(M)))/2 - 1
|
||||
MLINE(L0 + L:) = MONTHNAME(M)
|
||||
DO D = 0,6
|
||||
L = L0 + (3 - W) + D*W
|
||||
DLINE(L:L + 2) = DAYNAME(D)(1:W - 1)
|
||||
END DO
|
||||
DN1 = DAYNUM(YEAR,M,1)
|
||||
DN2 = DAYNUM(YEAR,M + 1,0)
|
||||
COL = MOD(PMOD(DN1,7) + 7,7)
|
||||
LINE = 1
|
||||
D = 1
|
||||
DO DN = DN1,DN2
|
||||
L = L0 + COL*W
|
||||
STRIPE(LINE)(L:L + 1) = I2FMT(D)
|
||||
D = D + 1
|
||||
COL = COL + 1
|
||||
IF (COL.GT.6) THEN
|
||||
LINE = LINE + 1
|
||||
COL = 0
|
||||
END IF
|
||||
END DO
|
||||
L0 = L0 + 7*W + G
|
||||
END DO
|
||||
CALL SAY(MSG,MLINE)
|
||||
CALL SAY(MSG,DLINE)
|
||||
DO LINE = 1,6
|
||||
IF (STRIPE(LINE).NE."") THEN
|
||||
CALL SAY(MSG,STRIPE(LINE))
|
||||
END IF
|
||||
END DO
|
||||
END DO
|
||||
END DO Y
|
||||
CALL SAY(MSG,"")
|
||||
END SUBROUTINE CALENDAR
|
||||
END MODULE DATEGNASH
|
||||
|
||||
PROGRAM SHOW1968
|
||||
USE DATEGNASH
|
||||
INTEGER NCOL
|
||||
DO NCOL = 1,6
|
||||
CALL CALENDAR(1969,1969,NCOL)
|
||||
END DO
|
||||
END
|
||||
Loading…
Add table
Add a link
Reference in a new issue