home *** CD-ROM | disk | FTP | other *** search
/ Media Share 9 / MEDIASHARE_09.ISO / os2 / datofunk.zip / DATOFUNK.PAS < prev    next >
Pascal/Delphi Source File  |  1994-01-22  |  7KB  |  187 lines
  1. unit datofunk;
  2. {*****************************************************************************}
  3. {* Datoberegninger skrevet af Henrik Krebs 13.12.1993                        *}
  4. {*                                                                           *}
  5. {* Normalt benyttes "dag-numre" til beregningen. Dag-nummeret er et l¢benum- *}
  6. {* mer af typen dagnrt (=longint), hvor 1.1.1900 sættes lig 0.               *}
  7. {*     Bemærk, at dagnummer mod 7 giver ugedagen (0=s¢ndag..6=l¢rdag).       *}
  8. {*                                                                           *}
  9. {* Dato er en streng af typen yyyymmdd (= string[8]).                        *}
  10. {*                                                                           *}
  11. {* Uge er et heltal (type byte) i intervallet 1..53.                         *}
  12. {*     Bemærk, at der er dage i januar med ugenummer 53 og dage i december   *}
  13. {*     med ugenummer 1.                                                      *}
  14. {*                                                                           *}
  15. {* Arbejdsdag er false for f¢lgende dage (og true for resten):               *}
  16. {*     a) l¢rdage og s¢ndage.                                                *}
  17. {*     b) 1. jan, 5. jun, 24. dec, 25. dec, 26. dec, 31. dec                 *}
  18. {*     c) Forskydelige helligdage:                                           *}
  19. {*        skærtorsdag, langfredag, 2. påskedag                               *}
  20. {*        bededag, Kr. himmelfart, 2. pinsedag).                             *}
  21. {*                                                                           *}
  22. {* Programmet fungerer kun korrekt indenfor f¢lgende begrænsninger           *}
  23. {*     Datoer:    Datoer i tidsrummet 1.1.1900 .. 31.12.2099                 *}
  24. {*     Dag-numre: Numre i intervallet 0 .. 73049 (samme interval som datoer) *}
  25. {*                                                                           *}
  26. {* Der er ingen validering på korrekt input. Nonsens-input vil ikke medf¢re  *}
  27. {*     runtime-error; det vil kun medf¢re, at resultatet er nonsens.         *}
  28. {*                                                                           *}
  29. {* Unit'en indeholder 2 type-deklarationer:                                  *}
  30. {*                                                                           *}
  31. {* yyyymmdd = string[8]                                                      *}
  32. {* dagnrt =   longint                                                        *}
  33. {*                                                                           *}
  34. {* Unit'en indeholder 5 funktioner:                                          *}
  35. {*                                                                           *}
  36. {* DATO       Returnerer dato for dag'de dag efter 1.1.1900                  *}
  37. {* DAG        Returner l¢benummer for dato (Streng yyyymmdd). 19000101=0.    *}
  38. {* ARBEJDSDAG Retrunerer true, hvis dagnr er en arbejdsdag, ellers false.    *}
  39. {* UGE        Returnerer ugenummer for dagnr.                                *}
  40. {* IDAG       Returnerer dag-nummer for dags dato                            *}
  41. {*                                                                           *}
  42. {*****************************************************************************}
  43.  
  44. interface
  45. {-------}
  46. type
  47.   yyyymmdd = string[8];
  48.   dagnrt = longint;
  49. {Funktioner}
  50.   function dato(dag:dagnrt):yyyymmdd;
  51.   function dag(dato:yyyymmdd):dagnrt;
  52.   function arbejdsdag(dagnr: dagnrt): boolean;
  53.   function uge(dagnr: dagnrt): byte;
  54.   function idag: dagnrt;
  55.  
  56. implementation
  57. {------------}
  58.  
  59. uses dos;
  60.  
  61. function dato(dag:dagnrt):yyyymmdd;
  62. {----------------------------------}
  63. var
  64.   yyyymmddi,
  65.   wrk1: dagnrt;
  66.   wrk2: yyyymmdd;
  67.  
  68. begin{dato}
  69.   yyyymmddi:=(1900+dag*100 div 36525)*10000;
  70.   wrk1:=dag*100 mod 36525 + 3290;
  71.   if wrk1<9200 then dec(wrk1,180);
  72.   wrk1:=(wrk1 div 100)*100;
  73.   inc(yyyymmddi,wrk1 div 3056*100 + wrk1 mod 3056 div 100+1);
  74.   str(yyyymmddi:8,wrk2); dato:=wrk2;
  75. end{dato};
  76.  
  77. function dag(dato:yyyymmdd):dagnrt;
  78. {----------------------------------}
  79. var
  80.   wrk1, i: dagnrt;
  81.   yyyy, mm, dd: longint;
  82.   errpos: integer;
  83.  
  84. begin{dag}
  85.   val(copy(dato,1,4),yyyy,errpos);
  86.   val(copy(dato,5,2),mm,errpos);
  87.   val(copy(dato,7,2),dd,errpos);
  88.   i:=mm*3057 div 100 + dd;
  89.   wrk1:=(yyyy-1900)*36525;
  90.   if mm<=2 then inc(wrk1,180);
  91.   dag:=i+(wrk1 div 100) - 32;
  92. end{dag};
  93.  
  94. function idag: dagnrt;
  95. {---------------------}
  96.  
  97. var
  98.   yyyy,mm,dd,dow: word;
  99.   wdato, w: yyyymmdd;
  100.   i: byte;
  101.  
  102. begin{idag}
  103.   getdate(yyyy,mm,dd,dow);
  104.   str(yyyy:4,wdato);
  105.   str(mm:2,w); wdato:=wdato+w;
  106.   str(dd:2,w); wdato:=wdato+w;
  107.   for i:=1 to 8 do if wdato[i]=' ' then wdato[i]:='0';
  108.   idag:=dag(wdato);
  109. end{idag};
  110.  
  111. function sktdag(inyear: dagnrt): dagnrt;
  112. {----------------------------------------}
  113. var
  114.   wsktdag,yyyy: dagnrt;
  115.   a,c,d,f,g: integer;
  116.   errpos: integer;
  117.   wsktdato: yyyymmdd;
  118.  
  119. begin{sktdag}
  120.   val(copy(dato(inyear),1,4),yyyy,errpos);
  121.   a:=(yyyy-1900) mod 19; f:=yyyy mod 4 * 2; g:=yyyy mod 7 * 4;
  122.   d:=(a*19+24) mod 30; inc(f,g); g:=d*6; inc(f,g+5); f:= f mod 7;
  123.   wsktdag:=d+19+f;
  124.   if (wsktdag=54) or (wsktdag=53) and (a>10) and (d=28) and (f=6) then
  125.     dec(wsktdag,7);
  126.   str(yyyy,wsktdato);
  127.   sktdag:=dag(wsktdato+'0301')-1+wsktdag;
  128. end{sktdag};
  129.  
  130. function arbejdsdag(dagnr: dagnrt): boolean;
  131. {-------------------------------------------}
  132. const
  133.   fdoffset: set of byte = [0, 1, 4, 29, 42, 53]; {Forskydelige helligdage
  134.                                                   regnet ud fra skærtorsdag}
  135.   antalfaste = 6;
  136.   faste: array[1..antalfaste] of string[4] =
  137.     ('0101','0605','1224','1225','1226','1231'); {Faste fridage}
  138.  
  139. var
  140.   i: byte;
  141.   mmdd: string[4];
  142.   testoffset: integer;
  143.  
  144. begin{arbejdsdag}
  145.   if dagnr mod 7 in [0, 6] then arbejdsdag:=false
  146.   else begin
  147.     testoffset:=dagnr-sktdag(dagnr);
  148.     {$B- "in"-operatoren giver fejl hvis testoffset er udenfor 0..255}
  149.     if ((testoffset>=0) and (testoffset<=53)) and (testoffset in fdoffset)
  150.       then arbejdsdag:=false
  151.     else begin
  152.       arbejdsdag:=true; mmdd:=copy(dato(dagnr),5,4);
  153.       for i:=1 to antalfaste do if mmdd=faste[i] then arbejdsdag:=false;
  154.     end{if else};
  155.   end{if else};
  156.  
  157. end{arbejdsdag};
  158.  
  159. function uge(dagnr: dagnrt): byte;
  160. {---------------------------------}
  161. var
  162.   dag1, nextdag1, mandag1, uge1mandag, nextuge1mandag: dagnrt;
  163.   wuge: integer;
  164.  
  165. begin{uge}
  166.   dag1:=dag(copy(dato(dagnr),1,4)+'0101');
  167.   repeat
  168.     mandag1:=dag1; while mandag1 mod 7 <> 1 do inc(mandag1);
  169.     if mandag1-dag1<4 then uge1mandag:=mandag1 else uge1mandag:=mandag1-7;
  170.     if dagnr>=uge1mandag then wuge:=(dagnr-uge1mandag) div 7+1 else wuge:=0;
  171.     if wuge<=0 then begin
  172.       dag1:=dag(copy(dato(dag1-7),1,4)+'0101');
  173.     end{if};
  174.   until wuge>0;
  175.   nextdag1:=dag(copy(dato(dagnr),1,4)+'1232');
  176.   if ((wuge>=52) and
  177.       (nextdag1 mod 7 in [2..4])) then begin
  178.     nextuge1mandag:=nextdag1;
  179.     while nextuge1mandag mod 7 <> 1 do dec(nextuge1mandag);
  180.     if dagnr>=nextuge1mandag then wuge:=1;
  181.   end{if};
  182.   uge:=wuge;
  183. end{uge};
  184.  
  185. begin {initiering}
  186.  
  187. end{initiering}.