Questo sito utilizza cookies, anche di terze parti, per mostrare pubblicità e servizi in linea con il tuo account. Leggi l'informativa sui cookies.
Username: Password: oppure
Calendario Tau - calendario.pas

calendario.pas

Caricato da: Phi
Scarica il programma completo

  1. program calendario;
  2. {$r calendario.res}
  3.  
  4. uses crt, dos, windows;
  5.  
  6. type
  7. data = record
  8.  a, m, g, w : word;
  9. end;
  10.  
  11. const
  12. im:array[1..12]of byte=(0,3,3,6,1,4,6,2,5,0,3,5);
  13. gm:array[1..12]of byte=(3,0,3,2,3,2,3,3,2,3,2,3);
  14. nm:array[1..12]of string[9]=('Gennaio','Febbraio','Marzo','Aprile','Maggio',
  15.     'Giugno','Luglio','Agosto','Settembre','Ottobre','Novembre','Dicembre');
  16. ng:array[0..7]of string[9]=('Domenica','Luned','Marted','Mercoled','Gioved','Venerd','Sabato','Domenica');
  17. greg=1582;
  18. mess1:pchar='Attenzione'#13+
  19.             'L''anno inserito è antecedente al 1582: in anno in cui è entrato in vigore il calandario gregoriano'#13+
  20.             'Fino a quest''anno era in vigore il calendario Giuliano.'#13+
  21.             'Questo software non è in grado di calcolare correttamente il giorno della settimana della data inserita.'#13+
  22.             'Si desidera continuare comunque ??'#13+
  23.             '(scegliendo NO vi sara'' richiesto di inserire un nuovo anno)'#13;
  24. mess2:pchar='Attenzione'#13+
  25.             'Questo software è basato sul calendario attualmente utilizzato(Calendario Gregoriano)'#13+
  26.             'Tuttavia, dato che l''anno inserito è molto avanti nel futuro, potrebbero venire introdotte modifiche al calendario.'#13+
  27.             'Non garantiamo quindi di calcolare il giorno della settimana della data inserita in corretto'#13+
  28.             'Si desidera continuare comunque ??'#13+
  29.             '(scegliendo NO vi sara'' richiesto di inserire un nuovo anno)'#13;
  30.  
  31. function str(n:integer):string;
  32. begin
  33. system.str(n,str);
  34. end;
  35.  
  36. function isbis(a:word):boolean;
  37. begin
  38. isbis := ((a mod 4)=0) and ((a mod 100) <> 0) or (a=0);
  39. end;
  40.  
  41. function oggi:data;
  42. begin
  43. with oggi do getdate(a, m, g, w);
  44. end;
  45.  
  46. function weekday(var d:data):word;
  47. var am:word;
  48. begin
  49. with d do if (w = 0) or (w > 7) then begin
  50.  am:=a mod 400;
  51.  if isbis(am) and (m>2) then w := (am div 4) + am - (am div 100) + im[m] + g
  52.  else w := (am div 4) + am - (am div 100) + im[m] + g - 1;
  53.  w := w mod 7;
  54. end;
  55. weekday := d.w;
  56. end;
  57.  
  58. function scrivi(d:data):string;
  59. begin
  60. weekday(d);
  61. with d do scrivi:=concat(ng[w],#32,str(g),#32,nm[m],#32,str(a));
  62. end;
  63.  
  64. var
  65. chiudi:boolean;
  66. i:word;
  67. d:data;
  68.  
  69. function check(n : byte; val : word):boolean;
  70. begin
  71. if ioresult<>0 then begin
  72.  check:=false;
  73.  messagebox(0,'Errore durante l''inserimento. Immetti valori numerici interi','Calendario',mb_iconexclamation or mb_ok);
  74.  repeat until ioresult=0;
  75.  exit;
  76. end;
  77. case n of
  78.  1:
  79.   if (val >= greg) and (val <= 5000) then begin check:= true; exit; end
  80.   else begin
  81.    if val < greg then check:=messagebox(0,mess1,'Calendario',mb_iconexclamation or mb_yesno)=idyes
  82.    else check:=messagebox(0,mess2,'Calendario',mb_iconexclamation or mb_yesno)=idyes;
  83.   end;
  84.  2: begin
  85.   check:=(val>=1)and(val<=12);
  86.   if not check then messagebox(0,'Immetti un numero tra 1 e 12','Calendario',mb_iconexclamation);
  87.  end;
  88.  3: begin
  89.   check:=((val>=1)and(val<=(28+gm[d.m]))) or (isbis(d.a) and (d.m=2) and (val=29));
  90.   if not check then messagebox(0,'Questo giorno non esiste','Calendario',mb_iconexclamation);
  91.  end;
  92. end;
  93. end;
  94.  
  95. procedure scrivimese(d:data);
  96. var gg:byte;
  97. begin
  98. writeln('   L   M   M   G   V   S   D');
  99. d.g:=0;
  100. gg := 0;
  101. for i := 1 to weekday(d) do write(space(4));
  102. if isbis(d.a) then inc(gm[2]);
  103. for i := 1 to (28+gm[d.m]) do begin
  104.  inc(gg);
  105.  if gg < 10 then write(space(3)) else write(space(2));
  106.  write(gg);
  107.  if ((gg+d.w)mod 7)=0 then writeln;
  108. end;
  109. if isbis(d.a) then dec(gm[2]);
  110. end;
  111.  
  112. procedure scrivioggi;
  113. var today:data;
  114. begin
  115. today:=oggi;
  116. window(1,5,40,10);
  117. textcolor(15);
  118. textbackground(4);
  119. clrscr;
  120. writeln(#13#10'OGGI: ',#13#10#13#10, scrivi(today));
  121. textcolor(4);
  122. textbackground(7);
  123. window(1,4,40,4);
  124. clrscr;
  125. writeln(nm[today.m], ' ', today.a);
  126. window(41,4,80,10);
  127. clrscr;
  128. scrivimese(today);
  129. window(1,11,80,25);
  130. textcolor(15);
  131. textbackground(0);
  132. clrscr;
  133. end;
  134.  
  135. procedure disegno;
  136. begin
  137. window(1,1,80,3);
  138. textbackground(1);
  139. textcolor(14);
  140. clrscr;
  141. write(#13#10,space(32),'Calendario Tau');
  142. end;
  143.  
  144. function menu(op:array of string; vaigiu:boolean):byte;
  145. var
  146. x, y : array of byte;
  147. i: byte;
  148. finito: boolean;
  149. procedure setmenu(n:byte);
  150.  begin
  151.  gotoxy(x[menu],y[menu]);
  152.  write('[',op[menu],']');
  153.  textcolor(0);
  154.  textbackground(7);
  155.  menu:=n;
  156.  gotoxy(x[menu],y[menu]);
  157.  write('[',op[menu],']');
  158.  textcolor(15);
  159.  textbackground(0);
  160.  end;
  161. begin
  162. menu:=0;
  163. finito:=false;
  164. setlength(x,high(op)+1);
  165. setlength(y,high(op)+1);
  166. for i := 0 to high(op) do begin
  167.  x[i]:= wherex;
  168.  y[i]:= wherey;
  169.  write('[',op[i],'] ');
  170.  if vaigiu then write(#10);
  171. end;
  172. setmenu(0);
  173. repeat
  174.  case readkey of
  175.   #13 : finito:=true;
  176.   #0 : case readkey of
  177.    #77, #80 : if (menu<>high(op)) then setmenu(menu+1);
  178.    #72, #75 : if (menu<>0) then setmenu(menu-1);
  179.   end;
  180.  end;
  181. until finito;
  182. end;
  183.  
  184. procedure vaiadata;
  185. begin
  186.  writeln;
  187.  writeln('--> Visualizza un giorno specifico -->'#13#10'Immetti mese e anno (sotto forma di numero minore di 5000)');
  188.  {$i-}
  189.  repeat
  190.   write('Anno:');readln(d.a);
  191.  until check(1,d.a);
  192.  repeat
  193.  write('Mese:');readln(d.m);
  194.   until check(2,d.m);
  195.  repeat
  196.   write('Giorno:');readln(d.g);
  197.  until check(3,d.g);
  198.  {$i+}
  199.  writeln(#13#10);
  200.  textcolor(14);writeln(scrivi(d));textcolor(15);
  201.  writeln('Il giorno immesso Š ',ng[d.w]);
  202.  writeln;
  203.  textbackground(8);
  204.  writeln(nm[d.m], ' ', d.a);
  205.  scrivimese(d);
  206.  textbackground(0);
  207.  writeln;
  208. end;
  209.  
  210. BEGIN
  211. chiudi:=false;
  212. clrscr;
  213. disegno;
  214. scrivioggi;
  215. repeat
  216.  writeln;writeln('Scegli cosa fare:  ');
  217.  case menu(['Visualizza una data','Aggiorna Oggi','Chiudi'],false) of
  218.   0 : vaiadata;
  219.   1 : begin
  220.    scrivioggi;
  221.    writeln('Schermata oggi e mese attuale aggiornata');
  222.    writeln;
  223.   end;
  224.   2 : chiudi:=true;
  225.  end;
  226. until chiudi;
  227. END.