diff options
Diffstat (limited to 'system/base/1.7.5/src/date handling')
| -rw-r--r-- | system/base/1.7.5/src/date handling | 303 |
1 files changed, 303 insertions, 0 deletions
diff --git a/system/base/1.7.5/src/date handling b/system/base/1.7.5/src/date handling new file mode 100644 index 0000000..66da110 --- /dev/null +++ b/system/base/1.7.5/src/date handling @@ -0,0 +1,303 @@ +PACKET date handling DEFINES date, time, (* Autor: H. Indenbirken *) + time of day, (* Stand: 02.06.1986 (wk)*) + month, day , year , + hour , + minute, + second : + +LET middle yearlength = 31557380.0, + weeklength = 604800.0, + daylength = 86400.0, + hours = 3600.0, + minutes = 60.0, + seconds = 1.0; + + +(* Tage bis zum Jahr 01.01.1900: 693970.25 5.995903e10 Sekunden *) +(* Dieser Tag ist ein Montag *) + +REAL VAR begin of today := 0.0 , end of today := 0.0 ; + +TEXT VAR today , result ; + + +ROW 12 REAL CONST previous days :: ROW 12 REAL : (0.0, 2678400.0, 5097600.0, + 7776000.0, 10368000.0, 13046400.0, + 15638400.0, 18316800.0, 20995200.0, + 23587200.0, 26265600.0, 28857600.0); + +REAL PROC day: day length END PROC day; +REAL PROC hour: hours END PROC hour; +REAL PROC minute: minutes END PROC minute; +REAL PROC second: seconds END PROC second; + +TEXT PROC date : + + IF clock (1) < begin of today OR end of today <= clock (1) + THEN begin of today := clock (1) ; + end of today := floor (begin of today/daylength)*daylength+daylength; + today := date (begin of today) + FI ; + today + +ENDPROC date ; + +TEXT PROC date (REAL CONST datum): + INT VAR year :: int (datum/middle yearlength), + day :: int (((datum - datum MOD daylength) MOD middle yearlength) / daylength) + 1; + +correct kalendary day; + + calculate month and correct day; + result := daytext; + result CAT monthtext; + result CAT yeartext; + change all (result, " ", "0") ; + result . + +correct kalendary day: + IF day >= 60 AND NOT leapyear + THEN day INCR 1 FI . + +leapyear: + IF year MOD 100 = 0 + THEN year MOD 400 = 0 + ELSE year MOD 4 = 0 + FI. + +calculate month and correct day: + INT VAR month; + IF day > 182 + THEN IF day > 274 + THEN IF day > 305 + THEN IF day > 335 + THEN month := 12; + day DECR 335 + ELSE month := 11; + day DECR 305 + FI + ELSE month := 10; + day DECR 274 + FI + ELSE IF day > 213 + THEN IF day > 244 + THEN month := 9; + day DECR 244 + ELSE month := 8; + day DECR 213 + FI + ELSE month := 7; + day DECR 182 + FI + FI + ELSE IF day > 91 + THEN IF day > 121 + THEN IF day > 152 + THEN month := 6; + day DECR 152 + ELSE month := 5; + day DECR 121 + FI + ELSE month := 4; + day DECR 91 + FI + ELSE IF day > 31 + THEN IF day > 60 + THEN month := 3; + day DECR 60 + ELSE month := 2; + day DECR 31 + FI + ELSE month := 1 FI + FI + FI . + +daytext : + text (day, 2) + "." . + +monthtext : + text (month,2) + "." . + +yeartext: + IF 1900 <= year AND year < 2000 + THEN text (year - 1900, 2) + ELSE text (year, 4) + FI . + +END PROC date; + +TEXT PROC day (REAL CONST datum): + SELECT int ((datum MOD weeklength)/daylength) OF + CASE 1: "Donnerstag" + CASE 2: "Freitag" + CASE 3: "Samstag" + CASE 4: "Sonntag" + CASE 5: "Montag" + CASE 6: "Dienstag" + OTHERWISE "Mittwoch" ENDSELECT . +END PROC day; + +TEXT PROC month (REAL CONST datum): + SELECT int (subtext (date (datum), 4, 5)) OF + CASE 1: "Januar" + CASE 2: "Februar" + CASE 3: "März" + CASE 4: "April" + CASE 5: "Mai" + CASE 6: "Juni" + CASE 7: "Juli" + CASE 8: "August" + CASE 9: "September" + CASE 10: "Oktober" + CASE 11: "November" + OTHERWISE "Dezember" ENDSELECT . + +END PROC month; + +TEXT PROC year (REAL CONST datum) : + + TEXT VAR buffer := subtext (date (datum), 7) ; + IF LENGTH buffer = 2 + THEN "19" + buffer + ELSE buffer + FI . + +ENDPROC year ; + +TEXT PROC time of day : + time of day (clock (1)) +ENDPROC time of day ; + +TEXT PROC time of day (REAL CONST value) : + subtext (time (value MOD daylength), 1, 5) +ENDPROC time of day ; + +TEXT PROC time (REAL CONST value) : + time (value,10) +ENDPROC time ; + +TEXT PROC time (REAL CONST value, INT CONST length) : + result := "" ; + IF length > 7 + THEN result CAT hour ; + result CAT ":" + FI ; + result CAT minute ; + result CAT ":" ; + result CAT rest ; + change all (result, " ", "0") ; + result . + +hour : + text (int (value/hours), length-8) . + +minute : + text (int (value/minutes MOD 60.0), 2) . + +rest : + text (value MOD minutes, 4, 1) . + +END PROC time ; + +REAL PROC date (TEXT CONST datum) : + split and check datum; + real (day no)*daylength + + previous days [month no] + calendary day + + floor (real (year no)*middleyearlength / daylength)*daylength . + +split and check datum: + INT CONST day no :: first no; + IF NOT last conversion ok + THEN errorstop ("inkorrekte Datumsangabe (Tag) : " + datum) FI; + + INT CONST month no :: second no; + IF NOT last conversion ok OR month no < 1 OR month no > 12 + THEN errorstop ("inkorrekte Datumsangabe (Monat) : " + datum) FI; + + INT CONST year no :: third no + century; + IF NOT last conversion ok + THEN errorstop ("inkorrekte Datumsangabe (Jahr) : " + datum) FI; + + IF day no < 1 OR day no > size of month + THEN errorstop ("inkorrekte Datumsangabe (Tag) : " + datum) FI . + +century: + IF (length (datum) - second pos) <= 2 + THEN 1900 + ELSE 0 FI . + +size of month: + SELECT month no OF + CASE 1, 3, 5, 7, 8, 10, 12: 31 + CASE 4, 6, 9, 11: 30 + OTHERWISE february size ENDSELECT . + +february size: + IF leapyear + THEN 29 + ELSE 28 FI . + +calendary day: + IF month no > 2 AND leapyear + THEN daylength + ELSE 0.0 FI . + +leapyear: + year no MOD 4 = 0 AND year no MOD 400 <> 0 . + +first no: + INT CONST first pos :: pos (datum, "."); + int (subtext (datum, 1, first pos-1)) . + +second no: + INT CONST second pos :: pos (datum, ".", first pos+1); + int (subtext (datum, first pos + 1, second pos-1)) . + +third no: + int (subtext (datum, second pos + 1)) . + +END PROC date; + +REAL PROC time (TEXT CONST time) : + split and check time; + hour + min + sec . + +split and check time: + REAL CONST hour :: hour no * hours; + IF NOT last conversion ok + THEN errorstop ("inkorrekte Datumsangabe (Stunde) : " + time) FI; + + REAL CONST min :: min no * minutes; + IF NOT last conversion ok + THEN errorstop ("inkorrekte Datumsangabe (Minute) : " + time) FI; + + REAL CONST sec :: sec no; + IF NOT last conversion ok + THEN errorstop ("inkorrekte Datumsangabe (Sekunde) : " + time) FI; + + set conversion (hour ok AND min ok AND sec ok) . + +hour no: + INT CONST hour pos :: pos (time, ":"); + real (subtext (time, 1, hour pos-1)) . + +min no: + INT VAR min pos :: pos (time, ":", hour pos+1); + IF min pos = 0 + THEN real (subtext (time, hour pos + 1, LENGTH time)) + ELSE real (subtext (time, hour pos + 1, min pos-1)) + FI . + +sec no: + IF min pos = 0 + THEN 0.0 + ELSE real (subtext (time, min pos + 1)) + FI . + +hour ok: 0.0 <= hour AND hour < daylength . +min ok: 0.0 <= min AND min < hours . +sec ok: 0.0 <= sec AND sec < minutes . +END PROC time; + +END PACKET datehandling + |