home *** CD-ROM | disk | FTP | other *** search
/ rtsi.com / 2014.01.www.rtsi.com.tar / www.rtsi.com / OS9 / OSK / EFFO / forum8.lzh / PROGRAMME / MODULA / WINDOW / dateio.mod < prev   
Text File  |  1989-01-19  |  28KB  |  771 lines
  1. (*
  2. -------------------------------------------------------------------------------
  3. @@@@@@@@@@@@@@@@@@*)  IMPLEMENTATION  MODULE  DateIO;  (*@@@@@@@@@@@@@@@@@@@@@@
  4. -------------------------------------------------------------------------------
  5. -------------------------------------------------------------------------------
  6. | Kurzbeschreibung   | formatierte Ausgabe von Datum und Zeit                 |
  7. |                    | formatfreie Eingabe von Datum und Zeit                 |
  8. ---------------------+---------------------------------------------------------
  9. | Programm - Version |  1.0   |   Text - Version        |   V#002             |
  10. ---------------------+--------+-------------------------+----------------------
  11. | Modulholder        |  WS    |   Urversion     |  WS   |   Januar 89         |
  12. ---------------------+---------------------------------------------------------
  13. | System - Version   | OS-9, Miele-Modula-2 3.5                               |
  14. ---------------------+---------------------------------------------------------
  15. | Copyright          | Freigegeben fuer nichtkommerzielle Nutzung             |
  16. |                    |  durch Teilnehmer am EFFO                              |
  17. ---------------------+---------------------------------------------------------
  18. | Hardware           | GEPARD 68010, 1 MByte RAM, 80Zeichen-Textkarte         |
  19. ---------------------+---------------------------------------------------------
  20. | besondere Importe  |                                                        |
  21. ---------------------+---------------------------------------------------------
  22. | Autoren            |  WS    | Werner Stehling, Seilerwis 3,                 |
  23. |                    |        | CH-8606 Greifensee, Tel. 01/256 42 21         |
  24. ---------------------+---------------------------------------------------------
  25. |   U P D A T E S    |                                                        |
  26. ----------------------                                                        |
  27. |   Datum   Version  Autor  Bemerkungen                                       |
  28. | --------  -------  -----  -----------                                       |
  29. |                                                                             |
  30. -------------------------------------------------------------------------------
  31. | Modul-Beschreibung |   siehe Definition Modul                               |
  32. ----------------------                                                        |
  33. -------------------------------------------------------------------------------
  34. *)
  35.  
  36. FROM  SYSTEM    IMPORT  ADDRESS;
  37. FROM  SysUtil   IMPORT  FTime, FJulian;
  38. FROM  Strings   IMPORT  SearchPos, Assign, Length, Delete, Insert;
  39. FROM  ConNum    IMPORT  NumToStr;
  40. FROM  Area      IMPORT  GotoXY, GetXY;
  41. FROM  AreaIO    IMPORT  WriteStr, ReadStr;
  42.  
  43. CONST   maxstr = 39;
  44.         shortyear = 80;         (* 80 - 99 = 1980 - 1999 *)
  45.                                 (* 00 - 79 = 2000 - 2079 *)
  46.  
  47. TYPE    String3  = ARRAY [0..2] OF CHAR;
  48.         Stringv  = ARRAY [0..9] OF CHAR;
  49.  
  50. VAR     mon3    : ARRAY [1..12],[0..3] OF String3;
  51.         day3    : ARRAY [0.. 6],[0..3] OF String3;
  52.         monv    : ARRAY [1..12],[0..3] OF Stringv;
  53.         dayv    : ARRAY [0.. 6],[0..3] OF Stringv;
  54.         monday  : ARRAY [1..12]        OF CARDINAL;
  55.         
  56. (*--------------------------------------------------------------------------*)
  57.      PROCEDURE  JulToGreg (VAR time, date : ADDRESS; sec, juldate : ADDRESS);
  58. (*--------------------------------------------------------------------------*)
  59. (* Lit.: Orion 195/47 (Apr. 1983);                                          *)
  60.  
  61. VAR     year, mon, day              : CARDINAL;
  62.         secs, mins, hour            : ADDRESS;
  63.         a, A, B, C, D, E, F, G, I, j: REAL;
  64.  
  65.     (*----------------------------------------------------------------------*)
  66.         PROCEDURE  INT (x : REAL) : REAL;
  67.     (*----------------------------------------------------------------------*)
  68.     VAR     i       : REAL;
  69.             sig     : BOOLEAN;
  70.     BEGIN
  71.       IF  x < 0.0  THEN
  72.         x := -x;
  73.         sig := TRUE
  74.       ELSE
  75.         sig := FALSE
  76.       END;
  77.       i := FLOAT (TRUNC (x / 65536.0));
  78.       i := i * 65536.0;
  79.       IF  sig  THEN
  80.         i := -i
  81.       END;
  82.       RETURN  FLOAT (TRUNC (x - i)) + i;
  83.     END  INT;
  84.     (*----------------------------------------------------------------------*)
  85.  
  86. BEGIN
  87.   j := FLOAT (juldate) + 1.5;   (* !OS-9! richtig waere: + 0.5  *)
  88.   I := INT (j);
  89.   IF  I < 2299161.0  THEN
  90.     A := I
  91.   ELSE
  92.     a := INT ((I - 1867216.25) / 36524.25);
  93.     A := a - INT (a / 4.0) + I + 1.0
  94.   END;
  95.   B := A + 1524.0;
  96.   C := INT ((B - 122.1) / 365.25);
  97.   D := B - INT (365.25 * C);
  98.  
  99.   E := INT (D / 30.6001);
  100.   F := j - I;
  101.   G := D - INT (30.6001 * E) + F;
  102.  
  103.   day := TRUNC (G);
  104.   IF  E < 13.5  THEN
  105.     mon := TRUNC (E) - 1
  106.   ELSE
  107.     mon := TRUNC (E) - 13
  108.   END;
  109.   IF  mon >= 3  THEN
  110.     year := TRUNC (C) - 4716
  111.   ELSE
  112.     year := TRUNC (C) - 4715
  113.   END;
  114.   date := (ADDRESS (year) * 256 + ADDRESS (mon)) * 256 + ADDRESS (day);
  115.   
  116.   secs := sec MOD 60;
  117.   hour := sec DIV 3600;
  118.   mins := (sec MOD 3600) DIV 60;
  119.   time := (hour * 256 + mins) * 256 + secs;
  120. END  JulToGreg;
  121.  
  122. (*--------------------------------------------------------------------------*)
  123.         PROCEDURE  StringCap (VAR source, dest : ARRAY OF CHAR);
  124. (*--------------------------------------------------------------------------*)
  125.  
  126. VAR     i   : CARDINAL;
  127.  
  128. BEGIN
  129.   Assign (source, dest);
  130.   FOR  i := 0  TO  Length (dest)-1  DO
  131.     dest[i] := CAP (dest[i])
  132.   END
  133. END  StringCap;
  134.  
  135. (*--------------------------------------------------------------------------*)
  136.         PROCEDURE  NumToStr2 (val, len : CARDINAL; fill : CHAR;
  137.                                 VAR s : ARRAY OF CHAR);
  138. (*--------------------------------------------------------------------------*)
  139.  
  140. VAR     fc      : ARRAY [0..0] OF CHAR;
  141.  
  142. BEGIN
  143.   fc[0] := fill;
  144.   NumToStr (val, 10, s);
  145.   WHILE  Length (s) < len  DO
  146.     Insert (fc, s, 0)
  147.   END
  148. END  NumToStr2;
  149.  
  150. (*--------------------------------------------------------------------------*)
  151.         PROCEDURE  DecDate (date : ADDRESS; VAR day, month, year,
  152.                                                            syear : CARDINAL);
  153. (*--------------------------------------------------------------------------*)
  154.  
  155. BEGIN
  156.   day   := CARDINAL (date MOD 256);
  157.   month := CARDINAL ((date DIV 256) MOD 256);
  158.   year  := CARDINAL (date DIV 65536);
  159.   IF  (year >= 1900+shortyear) AND (year < 2000)  THEN
  160.     syear := year - 1900
  161.   ELSIF  (year >= 2000) AND (year < 2000+shortyear)  THEN
  162.     syear := year - 2000
  163.   ELSE
  164.     syear := year
  165.   END
  166. END  DecDate;
  167.  
  168. (*--------------------------------------------------------------------------*)
  169.         PROCEDURE  EncDate (VAR date : ADDRESS; day, month, year : CARDINAL);
  170. (*--------------------------------------------------------------------------*)
  171.  
  172. VAR     juldat, sec             : ADDRESS;
  173.         lday                    : CARDINAL;
  174.  
  175. BEGIN
  176.   IF  year < 100  THEN
  177.     IF  year < shortyear  THEN
  178.       year := year + 2000
  179.     ELSE
  180.       year := year + 1900
  181.     END
  182.   END;
  183.   lday := monday[month];     (* test for last day of month   *)
  184.   IF  month = 2  THEN
  185.     IF  (((year MOD 4) = 0) AND (NOT (year MOD 100 = 0)))
  186.                             OR ((year MOD 400) = 0)  THEN
  187.       lday := lday + 1
  188.     END
  189.   END;
  190.   IF  day > lday  THEN
  191.     day := lday
  192.   END;
  193.   date := (ADDRESS (year)*256 + ADDRESS (month))*256 + ADDRESS (day);
  194. END  EncDate;
  195.  
  196. (*--------------------------------------------------------------------------*)
  197.         PROCEDURE  DateStr (VAR form, s : ARRAY OF CHAR; date : ADDRESS;
  198.                                                      language : CARDINAL);
  199. (*--------------------------------------------------------------------------*)
  200.  
  201. VAR     s1                      : ARRAY [0..maxstr] OF CHAR;
  202.         day, month, year, syear, lens, pos, weekday   : CARDINAL;
  203.  
  204. BEGIN
  205.   Assign (form, s);
  206.   lens := Length (s);
  207.   weekday := Weekday (date);
  208.   DecDate (date, day, month, year, syear);
  209.   WHILE  SearchPos ('y2', s, 0, pos)  DO
  210.     Delete (s, pos, 2);
  211.     NumToStr2 (syear, 2, '0', s1);
  212.     Insert (s1, s, pos)
  213.   END;
  214.   WHILE  SearchPos ('y4', s, 0, pos)  DO
  215.     Delete (s, pos, 2);
  216.     NumToStr2 (year, 4, '0', s1);
  217.     Insert (s1, s, pos)
  218.   END;
  219.   WHILE  SearchPos ('m2', s, 0, pos)  DO
  220.     Delete (s, pos, 2);
  221.     NumToStr2 (month, 2, ' ', s1);
  222.     Insert (s1, s, pos)
  223.   END;
  224.   WHILE  SearchPos ('m3', s, 0, pos)  DO
  225.     Delete (s, pos, 2);
  226.     Insert (mon3[month, language], s, pos)
  227.   END;
  228.   WHILE  SearchPos ('mv', s, 0, pos)  DO
  229.     Delete (s, pos, 2);
  230.     Insert (monv[month, language], s, pos)
  231.   END;
  232.   WHILE  SearchPos ('d2', s, 0, pos)  DO
  233.     Delete (s, pos, 2);
  234.     NumToStr2 (day, 2, ' ', s1);
  235.     Insert (s1, s, pos)
  236.   END;
  237.   WHILE  SearchPos ('w3', s, 0, pos)  DO
  238.     Delete (s, pos, 2);
  239.     Insert (day3[weekday, language], s, pos)
  240.   END;
  241.   WHILE  SearchPos ('wv', s, 0, pos)  DO
  242.     Delete (s, pos, 2);
  243.     Insert (dayv[weekday, language], s, pos)
  244.   END;
  245. END  DateStr;
  246.  
  247. (*--------------------------------------------------------------------------*)
  248.         PROCEDURE  Weekday (date : ADDRESS) : CARDINAL;
  249. (*--------------------------------------------------------------------------*)
  250.  
  251. VAR     time, sec, juldat       : ADDRESS;
  252.  
  253. BEGIN
  254.   time := 0;
  255.   FJulian (time, date, sec, juldat);
  256.   RETURN  CARDINAL ((juldat + 2) MOD 7);
  257. END  Weekday;
  258.  
  259. (*--------------------------------------------------------------------------*)
  260.         PROCEDURE  WriteDate (VAR form : ARRAY OF CHAR; date : ADDRESS;
  261.                               language : CARDINAL; space : INTEGER);
  262. (*--------------------------------------------------------------------------*)
  263.  
  264. VAR     s                       : ARRAY [0..maxstr] OF CHAR;
  265.  
  266. BEGIN
  267.   DateStr (form, s, date, language);
  268.   WriteStr (s, space)
  269. END  WriteDate;
  270.  
  271. (*--------------------------------------------------------------------------*)
  272.         PROCEDURE  WriteToday (VAR form : ARRAY OF CHAR; 
  273.                               language : CARDINAL; space : INTEGER);
  274. (*--------------------------------------------------------------------------*)
  275.  
  276. VAR     tim, dat, tic   : ADDRESS;
  277.         wd              : CARDINAL;
  278.         s               : ARRAY [0..maxstr] OF CHAR;
  279.         
  280. BEGIN
  281.   FTime (0, tim, dat, tic, wd);
  282.   DateStr (form, s, dat, language);
  283.   WriteStr (s, space)
  284. END  WriteToday;
  285.  
  286. (*--------------------------------------------------------------------------*)
  287.         PROCEDURE  TimeStr (VAR form, s : ARRAY OF CHAR; time : ADDRESS);
  288. (*--------------------------------------------------------------------------*)
  289.  
  290. VAR     s2, aps                         : ARRAY [0..1]      OF CHAR;
  291.         hour, min, sec, lens, pos, ho12 : CARDINAL;
  292.         hflag                           : BOOLEAN;
  293.  
  294. BEGIN
  295.   Assign (form, s);
  296.   lens := Length (s);
  297.   sec := CARDINAL (time MOD 256);
  298.   min := CARDINAL ((time DIV 256) MOD 256);
  299.   hour := CARDINAL (time DIV 65536);
  300.   IF  hour >= 13  THEN
  301.     ho12 := hour - 12;
  302.     aps := 'pm'
  303.   ELSIF  hour = 0  THEN
  304.     ho12 := 12;
  305.     aps := 'pm'
  306.   ELSE
  307.     ho12 := hour;
  308.     aps := 'am'
  309.   END;
  310.   WHILE  SearchPos ('h24', s, 0, pos)  DO
  311.     Delete (s, pos, 3);
  312.     NumToStr2 (hour, 2, '0', s2);
  313.     Insert (s2, s, pos)
  314.   END;
  315.   hflag := FALSE;
  316.   WHILE  SearchPos ('h12', s, 0, pos)  DO
  317.     hflag := TRUE;
  318.     Delete (s, pos, 3);
  319.     NumToStr2 (ho12, 2, '0', s2);
  320.     Insert (s2, s, pos);
  321.   END;
  322.   WHILE  SearchPos ('apm', s, 0, pos)  DO
  323.     Delete (s, pos, 3);
  324.     IF  hflag  THEN
  325.       Insert (aps, s, pos)
  326.     END
  327.   END;
  328.   WHILE  SearchPos ('min', s, 0, pos)  DO
  329.     Delete (s, pos, 3);
  330.     NumToStr2 (min, 2, '0', s2);
  331.     Insert (s2, s, pos)
  332.   END;
  333.   WHILE  SearchPos ('sec', s, 0, pos)  DO
  334.     Delete (s, pos, 3);
  335.     NumToStr2 (sec, 2, '0', s2);
  336.     Insert (s2, s, pos)
  337.   END;
  338. END  TimeStr;
  339.  
  340. (*--------------------------------------------------------------------------*)
  341.         PROCEDURE  WriteTime (VAR form : ARRAY OF CHAR; time : ADDRESS;
  342.                                                        space : INTEGER);
  343. (*--------------------------------------------------------------------------*)
  344.  
  345. VAR     s                       : ARRAY [0..maxstr] OF CHAR;
  346.  
  347. BEGIN
  348.   TimeStr (form, s, time);
  349.   WriteStr (s, space);
  350. END  WriteTime;
  351.  
  352. (*--------------------------------------------------------------------------*)
  353.         PROCEDURE  WriteNow (VAR form : ARRAY OF CHAR; space : INTEGER);
  354. (*--------------------------------------------------------------------------*)
  355.  
  356. VAR     tim, dat, tic   : ADDRESS;
  357.         wd              : CARDINAL;
  358.         
  359. BEGIN
  360.   FTime (0, tim, dat, tic, wd);
  361.   WriteTime (form, tim, space);
  362. END  WriteNow;
  363.  
  364. (*--------------------------------------------------------------------------*)
  365.         PROCEDURE  GetNum (VAR s : ARRAY OF CHAR; VAR pos, val : CARDINAL;
  366.                                                   VAR ok : BOOLEAN);
  367. (*--------------------------------------------------------------------------*)
  368.  
  369. VAR     pss, lens       : CARDINAL;
  370.  
  371. BEGIN
  372.   val  := 0;
  373.   lens := Length (s);
  374.   ok   := FALSE;
  375.   pss  := pos;
  376.   WHILE  (pss < lens) AND ((s[pss] < '0') OR (s[pss] > '9'))  DO
  377.     INC (pss)
  378.   END;
  379.   IF  pss < lens  THEN
  380.     WHILE  (pss < lens) AND (s[pss] >= '0') AND (s[pss] <= '9')  DO
  381.       val := 10 * val + ORD (s[pss]) - ORD ('0');
  382.       INC (pss)
  383.     END;
  384.     ok  := TRUE;
  385.     pos := pss
  386.   END;
  387. END  GetNum;
  388.  
  389. (*--------------------------------------------------------------------------*)
  390.         PROCEDURE  ReadDate (VAR form : ARRAY OF CHAR; VAR date : ADDRESS;
  391.                                  language : CARDINAL; space : INTEGER) : CHAR;
  392. (*--------------------------------------------------------------------------*)
  393.  
  394. TYPE    Datum = (year, month, day, nix);
  395.         DFolge = ARRAY [1..3] OF Datum;
  396.  
  397. VAR     s                       : ARRAY [0..maxstr] OF CHAR;
  398.         ok                      : BOOLEAN;
  399.         axc, ayc                : CARDINAL;
  400.         df                      : DFolge;
  401.         ch                      : CHAR;
  402.         yval, mval, dval, sy    : CARDINAL;
  403.  
  404.     (*----------------------------------------------------------------------*)
  405.         PROCEDURE  DateForm (VAR form : ARRAY OF CHAR; VAR df : DFolge);
  406.     (*----------------------------------------------------------------------*)
  407.     VAR     pos, i  : CARDINAL;
  408.             p       : ARRAY [1..3] OF CARDINAL;
  409.             h       : Datum;
  410.     BEGIN
  411.       FOR  i := 1  TO  3  DO
  412.         df[i] := nix;
  413.         p [i] := 999
  414.       END;
  415.       IF  SearchPos ('y2', form, 0, pos) OR SearchPos ('y4', form, 0, pos)  THEN
  416.         p [1] := pos;
  417.         df[1] := year
  418.       END;
  419.       IF  SearchPos ('m2', form, 0, pos) OR SearchPos ('m3', form, 0, pos)
  420.        OR SearchPos ('mv', form, 0, pos)  THEN
  421.         IF  pos < p[1]  THEN
  422.           p [2] := p [1];
  423.           df[2] := df[1];
  424.           i := 1
  425.         ELSE
  426.           i := 2
  427.         END;
  428.         p [i] := pos;
  429.         df[i] := month
  430.       END;
  431.       IF  SearchPos ('d2', form, 0, pos)  THEN
  432.         IF  pos < p[2]  THEN
  433.           p [3] := p [2];
  434.           df[3] := df[2];
  435.           i := 2
  436.         ELSE
  437.           i := 3
  438.         END;
  439.         IF  pos < p[1]  THEN
  440.           p [2] := p [1];
  441.           df[2] := df[1];
  442.           i := 1
  443.         END;
  444.         p [i] := pos;
  445.         df[i] := day
  446.       END;
  447.     END  DateForm;
  448.  
  449.     (*----------------------------------------------------------------------*)
  450.         PROCEDURE  TestMon (VAR s : ARRAY OF CHAR; VAR pos, val : CARDINAL;
  451.                                                    VAR ok : BOOLEAN);
  452.     (*----------------------------------------------------------------------*)
  453.     VAR     s1                          : ARRAY [0..maxstr] OF CHAR;
  454.             pss                         : CARDINAL;
  455.     BEGIN
  456.       val := 0;
  457.       REPEAT
  458.         INC (val);
  459.         StringCap (mon3[val, language], s1);
  460.         ok := SearchPos (s1, s, pos, pss)
  461.       UNTIL  ok OR (val >= 12);
  462.       IF  NOT ok  THEN
  463.         val := 0;
  464.         REPEAT
  465.           INC (val);
  466.           StringCap (monv[val, language], s1);
  467.           ok := SearchPos (s1, s, pos, pss)
  468.         UNTIL  ok OR (val >= 12);
  469.       END;
  470.       IF  ok  THEN
  471.         pos := pss + Length (s1)
  472.       ELSE
  473.         val := 0
  474.       END
  475.     END  TestMon;
  476.     
  477.     (*----------------------------------------------------------------------*)
  478.         PROCEDURE  TestDate (VAR s : ARRAY OF CHAR; VAR date : ADDRESS;
  479.                                 df : DFolge; VAR ok : BOOLEAN);
  480.     (*----------------------------------------------------------------------*)
  481.     VAR     s1                          : ARRAY [0..maxstr] OF CHAR;
  482.             pos, i    : CARDINAL;
  483.     BEGIN
  484.       StringCap (s, s1);
  485.       pos := 0;
  486.       i := 1;
  487.       REPEAT
  488.         CASE  df[i]  OF
  489.           year :    GetNum (s1, pos, yval, ok)          |
  490.           month:    TestMon (s1, pos, mval, ok);
  491.                     IF  NOT ok  THEN
  492.                       GetNum (s1, pos, mval, ok);
  493.                     END;
  494.                     IF  (mval < 1) OR (mval > 12)  THEN
  495.                       ok := FALSE
  496.                     END                                 |
  497.           day  :    GetNum (s1, pos, dval, ok);
  498.                     IF  (dval < 1) OR (dval > 31) THEN
  499.                       ok := FALSE
  500.                     END
  501.         ELSE
  502.         END;
  503.         INC (i)
  504.       UNTIL  (NOT (ok)) OR (i > 3);
  505.       IF  ok  THEN
  506.         EncDate (date, dval, mval, yval);
  507.       END
  508.     END  TestDate;
  509.     
  510.     (*----------------------------------------------------------------------*)
  511.  
  512. BEGIN
  513.   GetXY (axc, ayc);
  514.   DateForm (form, df);
  515.   DecDate (date, dval, mval, yval, sy);
  516.   REPEAT
  517.     GotoXY (axc, ayc);
  518.     DateStr (form, s, date, language);
  519.     ch := ReadStr (s, space);
  520.     TestDate (s, date, df, ok)
  521.   UNTIL  ok;
  522.   GotoXY (axc, ayc);
  523.   WriteDate (form, date, language, space);
  524.   RETURN  ch
  525. END  ReadDate;
  526.  
  527. (*--------------------------------------------------------------------------*)
  528.         PROCEDURE  ReadToday (VAR form : ARRAY OF CHAR; VAR date : ADDRESS;
  529.                                  language : CARDINAL; space : INTEGER) : CHAR;
  530. (*--------------------------------------------------------------------------*)
  531.  
  532. VAR     tim, tic        : ADDRESS;
  533.         wd              : CARDINAL;
  534.         
  535. BEGIN
  536.   FTime (0, tim, date, tic, wd);
  537.   RETURN  ReadDate (form, date, language, space)
  538. END  ReadToday;
  539.  
  540. (*--------------------------------------------------------------------------*)
  541.         PROCEDURE  ReadTime (VAR form : ARRAY OF CHAR; VAR time : ADDRESS;
  542.                                                       space : INTEGER): CHAR;
  543. (*--------------------------------------------------------------------------*)
  544.  
  545. TYPE    Zeit   = (stunde, minute, sekunde, nix);
  546.         ZFolge = ARRAY [1..3] OF Zeit;
  547.  
  548. VAR     s                       : ARRAY [0..maxstr] OF CHAR;
  549.         ok                      : BOOLEAN;
  550.         axc, ayc                : CARDINAL;
  551.         zf                      : ZFolge;
  552.         ch                      : CHAR;
  553.         hval, mval, sval        : CARDINAL;
  554.  
  555.     (*----------------------------------------------------------------------*)
  556.         PROCEDURE  TimeForm (VAR form : ARRAY OF CHAR; VAR zf : ZFolge);
  557.     (*----------------------------------------------------------------------*)
  558.     VAR     pos, i  : CARDINAL;
  559.             p       : ARRAY [1..3] OF CARDINAL;
  560.             h       : Zeit;
  561.     BEGIN
  562.       FOR  i := 1  TO  3  DO
  563.         zf[i] := nix;
  564.         p [i] := 999
  565.       END;
  566.       IF  SearchPos ('h12', form, 0, pos) OR SearchPos ('h24', form, 0, pos)  THEN
  567.         p [1] := pos;
  568.         zf[1] := stunde
  569.       END;
  570.       IF  SearchPos ('min', form, 0, pos)  THEN
  571.         IF  pos < p[1]  THEN
  572.           p [2] := p [1];
  573.           zf[2] := zf[1];
  574.           i := 1
  575.         ELSE
  576.           i := 2
  577.         END;
  578.         p [i] := pos;
  579.         zf[i] := minute
  580.       END;
  581.       IF  SearchPos ('sec', form, 0, pos)  THEN
  582.         IF  pos < p[2]  THEN
  583.           p [3] := p [2];
  584.           zf[3] := zf[2];
  585.         ELSE
  586.           i := 3
  587.         END;
  588.         IF  pos < p[1]  THEN
  589.           p [2] := p [1];
  590.           zf[2] := zf[1];
  591.           i := 1
  592.         END;
  593.         p [i] := pos;
  594.         zf[i] := sekunde
  595.       END;
  596.     END  TimeForm;
  597.  
  598.     (*----------------------------------------------------------------------*)
  599.         PROCEDURE  TestTime (VAR s : ARRAY OF CHAR; VAR time : ADDRESS;
  600.                                 zf : ZFolge; VAR ok : BOOLEAN);
  601.     (*----------------------------------------------------------------------*)
  602.     VAR     s1                          : ARRAY [0..maxstr] OF CHAR;
  603.             pos, i, k : CARDINAL;
  604.     BEGIN
  605.       StringCap (s, s1);
  606.       pos := 0;
  607.       i := 1;
  608.       REPEAT
  609.         CASE  zf[i]  OF
  610.           stunde:   GetNum (s1, pos, hval, ok);
  611.                     IF  (hval > 0) AND (hval < 13)
  612.                                    AND (SearchPos ('PM', s1, pos, k))  THEN
  613.                       hval := hval + 12;
  614.                       IF  hval = 24  THEN
  615.                         hval := 0
  616.                       END
  617.                     END;
  618.                     IF  hval > 23  THEN
  619.                       ok := FALSE
  620.                     END                                 |
  621.           minute:   GetNum (s1, pos, mval, ok);
  622.                     IF  mval >= 60  THEN
  623.                       ok := FALSE
  624.                     END                                 |
  625.           sekunde:  GetNum (s1, pos, sval, ok);
  626.                     IF  sval >= 60  THEN
  627.                       ok := FALSE
  628.                     END                                 |
  629.         ELSE
  630.         END;
  631.         INC (i)
  632.       UNTIL  (NOT (ok)) OR (i > 3);
  633.       IF  ok  THEN
  634.         time := (ADDRESS (hval) * 256 + ADDRESS (mval)) * 256 + ADDRESS (sval)
  635.       END
  636.     END  TestTime;
  637.     
  638.     (*----------------------------------------------------------------------*)
  639.  
  640. BEGIN
  641.   GetXY (axc, ayc);
  642.   TimeForm (form, zf);
  643.   sval := CARDINAL (time MOD 256);
  644.   mval := CARDINAL ((time DIV 256) MOD 256);
  645.   hval := CARDINAL (time DIV 65536);
  646.   REPEAT
  647.     GotoXY (axc, ayc);
  648.     TimeStr (form, s, time);
  649.     ch := ReadStr (s, space);
  650.     TestTime (s, time, zf, ok)
  651.   UNTIL  ok;
  652.   GotoXY (axc, ayc);
  653.   WriteTime (form, time, space);
  654.   RETURN  ch
  655. END  ReadTime;
  656.  
  657. (*--------------------------------------------------------------------------*)
  658.         PROCEDURE  ReadNow (VAR form : ARRAY OF CHAR; VAR time : ADDRESS;
  659.                                                       space : INTEGER) : CHAR;
  660. (*--------------------------------------------------------------------------*)
  661.  
  662. VAR     dat, tic        : ADDRESS;
  663.         wd              : CARDINAL;
  664.         
  665. BEGIN
  666.   FTime (0, time, dat, tic, wd);
  667.   RETURN  ReadTime (form, time, space)
  668. END  ReadNow;
  669.  
  670. (*--------------------------------------------------------------------------*)
  671.         PROCEDURE  Init;
  672. (*--------------------------------------------------------------------------*)
  673.  
  674. BEGIN
  675.   mon3[ 1, 0] := 'Jan';         monv[ 1, 0] := 'Januar';
  676.   mon3[ 2, 0] := 'Feb';         monv[ 2, 0] := 'Februar';
  677.   mon3[ 3, 0] := 'Mdr';         monv[ 3, 0] := 'Mdrz';
  678.   mon3[ 4, 0] := 'Apr';         monv[ 4, 0] := 'April';
  679.   mon3[ 5, 0] := 'Mai';         monv[ 5, 0] := 'Mai';
  680.   mon3[ 6, 0] := 'Jun';         monv[ 6, 0] := 'Juni';
  681.   mon3[ 7, 0] := 'Jul';         monv[ 7, 0] := 'Juli';
  682.   mon3[ 8, 0] := 'Aug';         monv[ 8, 0] := 'August';
  683.   mon3[ 9, 0] := 'Sep';         monv[ 9, 0] := 'September';
  684.   mon3[10, 0] := 'Okt';         monv[10, 0] := 'Oktober';
  685.   mon3[11, 0] := 'Nov';         monv[11, 0] := 'November';
  686.   mon3[12, 0] := 'Dez';         monv[12, 0] := 'Dezember';
  687.  
  688.   mon3[ 1, 1] := 'Jan';         monv[ 1, 1] := 'January';
  689.   mon3[ 2, 1] := 'Feb';         monv[ 2, 1] := 'February';
  690.   mon3[ 3, 1] := 'Mar';         monv[ 3, 1] := 'March';
  691.   mon3[ 4, 1] := 'Apr';         monv[ 4, 1] := 'April';
  692.   mon3[ 5, 1] := 'May';         monv[ 5, 1] := 'May';
  693.   mon3[ 6, 1] := 'Jun';         monv[ 6, 1] := 'June';
  694.   mon3[ 7, 1] := 'Jul';         monv[ 7, 1] := 'July';
  695.   mon3[ 8, 1] := 'Aug';         monv[ 8, 1] := 'August';
  696.   mon3[ 9, 1] := 'Sep';         monv[ 9, 1] := 'September';
  697.   mon3[10, 1] := 'Oct';         monv[10, 1] := 'October';
  698.   mon3[11, 1] := 'Nov';         monv[11, 1] := 'November';
  699.   mon3[12, 1] := 'Dec';         monv[12, 1] := 'December';
  700.  
  701.   mon3[ 1, 2] := 'Jan';         monv[ 1, 2] := 'Janvier';
  702.   mon3[ 2, 2] := 'Fev';         monv[ 2, 2] := 'Fevrier';
  703.   mon3[ 3, 2] := 'Mar';         monv[ 3, 2] := 'Mars';
  704.   mon3[ 4, 2] := 'Avr';         monv[ 4, 2] := 'Avril';
  705.   mon3[ 5, 2] := 'Mag';         monv[ 5, 2] := 'Maggio';
  706.   mon3[ 6, 2] := 'Jun';         monv[ 6, 2] := 'Juin';
  707.   mon3[ 7, 2] := 'Jul';         monv[ 7, 2] := 'Juillet';
  708.   mon3[ 8, 2] := 'Aou';         monv[ 8, 2] := 'Aout';
  709.   mon3[ 9, 2] := 'Sep';         monv[ 9, 2] := 'Septembre';
  710.   mon3[10, 2] := 'Oct';         monv[10, 2] := 'Octobre';
  711.   mon3[11, 2] := 'Nov';         monv[11, 2] := 'Novembre';
  712.   mon3[12, 2] := 'Dec';         monv[12, 2] := 'Decembre';
  713.  
  714.   mon3[ 1, 3] := 'Gen';         monv[ 1, 3] := 'Gennaio';
  715.   mon3[ 2, 3] := 'Feb';         monv[ 2, 3] := 'Febbraio';
  716.   mon3[ 3, 3] := 'Mar';         monv[ 3, 3] := 'Marzo';
  717.   mon3[ 4, 3] := 'Apr';         monv[ 4, 3] := 'Aprile';
  718.   mon3[ 5, 3] := 'Mag';         monv[ 5, 3] := 'Maggio';
  719.   mon3[ 6, 3] := 'Giu';         monv[ 6, 3] := 'Giugno';
  720.   mon3[ 7, 3] := 'Lug';         monv[ 7, 3] := 'Luglio';
  721.   mon3[ 8, 3] := 'Ago';         monv[ 8, 3] := 'Augosto';
  722.   mon3[ 9, 3] := 'Set';         monv[ 9, 3] := 'Settembre';
  723.   mon3[10, 3] := 'Ott';         monv[10, 3] := 'Ottobre';
  724.   mon3[11, 3] := 'Nov';         monv[11, 3] := 'Novembre';
  725.   mon3[12, 3] := 'Dic';         monv[12, 3] := 'Dicembre';
  726.  
  727.   day3[ 0, 0] := 'Son';         dayv[ 0, 0] := 'Sonntag';
  728.   day3[ 1, 0] := 'Mon';         dayv[ 1, 0] := 'Montag';
  729.   day3[ 2, 0] := 'Die';         dayv[ 2, 0] := 'Dienstag';
  730.   day3[ 3, 0] := 'Mit';         dayv[ 3, 0] := 'Mittwoch';
  731.   day3[ 4, 0] := 'Don';         dayv[ 4, 0] := 'Donnerstag';
  732.   day3[ 5, 0] := 'Fre';         dayv[ 5, 0] := 'Freitag';
  733.   day3[ 6, 0] := 'Sam';         dayv[ 6, 0] := 'Samstag';
  734.  
  735.   day3[ 0, 1] := 'Sun';         dayv[ 0, 1] := 'Sunday';
  736.   day3[ 1, 1] := 'Mon';         dayv[ 1, 1] := 'Monday';
  737.   day3[ 2, 1] := 'Tue';         dayv[ 2, 1] := 'Tuesday';
  738.   day3[ 3, 1] := 'Wed';         dayv[ 3, 1] := 'Wednesday';
  739.   day3[ 4, 1] := 'Thu';         dayv[ 4, 1] := 'Thursday';
  740.   day3[ 5, 1] := 'Fri';         dayv[ 5, 1] := 'Friday';
  741.   day3[ 6, 1] := 'Sat';         dayv[ 6, 1] := 'Saturday';
  742.  
  743.   day3[ 0, 2] := 'Dim';         dayv[ 0, 2] := 'Dimanche';
  744.   day3[ 1, 2] := 'Lun';         dayv[ 1, 2] := 'Lundi';
  745.   day3[ 2, 2] := 'Mar';         dayv[ 2, 2] := 'Mardi';
  746.   day3[ 3, 2] := 'Mer';         dayv[ 3, 2] := 'Mercredi';
  747.   day3[ 4, 2] := 'Jeu';         dayv[ 4, 2] := 'Jeudi';
  748.   day3[ 5, 2] := 'Ven';         dayv[ 5, 2] := 'Vendredi';
  749.   day3[ 6, 2] := 'Sam';         dayv[ 6, 2] := 'Samedi';
  750.  
  751.   day3[ 0, 3] := 'Dom';         dayv[ 0, 3] := 'Domenica';
  752.   day3[ 1, 3] := 'Lun';         dayv[ 1, 3] := 'Lunedi';
  753.   day3[ 2, 3] := 'Mar';         dayv[ 2, 3] := 'Martedi';
  754.   day3[ 3, 3] := 'Mer';         dayv[ 3, 3] := 'Mercoledi';
  755.   day3[ 4, 3] := 'Gio';         dayv[ 4, 3] := 'Giovedi';
  756.   day3[ 5, 3] := 'Ven';         dayv[ 5, 3] := 'Venerdi';
  757.   day3[ 6, 3] := 'Sab';         dayv[ 6, 3] := 'Sabato';
  758.   
  759.   monday[ 1]  := 31;    monday[ 2]   := 28;     monday[ 3]   := 31;
  760.   monday[ 4]  := 30;    monday[ 5]   := 31;     monday[ 6]   := 30;
  761.   monday[ 7]  := 31;    monday[ 8]   := 31;     monday[ 9]   := 30;
  762.   monday[10]  := 31;    monday[11]   := 30;     monday[12]   := 31;
  763. END  Init;
  764.  
  765. (*--------------------------------------------------------------------------*)
  766.  
  767. BEGIN
  768.   Init;
  769. END  DateIO.
  770.  
  771.