summaryrefslogtreecommitdiff
path: root/system/base/1.7.5/src/date handling
blob: 66da110a6f043839fe6d78000734dd2040e13c37 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
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