astronomia con pascal

esci turboastro.htm

program solare1;
(* su disco 65 dispensa 45 \tu56\solare1.mar *)
(* moto diurno del sole e della luna*)
(* novilunio,quadratura,plenilunio  *)

uses crt,graph;

type vet=array[1..800] of byte;
             var sole,luna:vet;
                 luogo1,luogo2,culmina:string;
                 t,orbite,sosta:integer;

procedure simula;               (* introduzione a programma *)
begin
 writeln('simulazione moto diurno del sole e della luna');
 writeln('novilunio,quadratura,plenilunio     ');
 writeln('il sole e la luna si muovono da est verso ovest');
 writeln('viene indicata la fase');
 writeln('viene indicata ora del sorgere,culminazione,tramonto');
 writeln('---------------------------------------------');
 writeln('premere tasto PAUSE per fermare rotazione ');
 writeln('premere tasto RETURN per riprendere rotazione');
 writeln('---------------------------------------------');
 writeln('indica velocita moto solare    ');
 writeln('numero 1    =moto rapido        ');
 writeln('numero 100  =moto lento        ');
 writeln('prova prima con 1 e poi altri valori...10..20..');
 readln(t);
 writeln('indicare numero rotazioni 1,2,3,4..');
 readln(orbite);
 orbite:=360*orbite;
 writeln('scrivi valore pausa punti speciali');
 writeln('1000...2000...5000....prova 1000 ');
 readln(sosta);
 clrscr;
end;

procedure fine;                 (* fine e ritorno a pascal *)
begin
 exit;
end;



procedure grafica(x1,y1,x2,y2,f:integer);   (* attiva pagina grafica*)
(* coordinate finestra,colore sfondo e disegno *)
var sc,tp:integer;
    stringa:string;

begin
 sc:=0;                         (* valore risoluzione 0,1,2,3,4,5,8,9 *)
 tp:=0;                         (* valore valido 1 - 0 palette *)
 stringa:='c\scheda';                (* indica ove cercare GRAPH *)
 initgraph(sc,tp,stringa);      (* attiva scheda grafica *)
 rectangle(x1,y1,x2,y2);        (* cornice area grafica *)
 setbkcolor(f);                 (* colore sfondo *)
end;

procedure pausa;                (* premere return per proseguire *)
var ch:char;
begin
 ch:=readkey;
end;

procedure testo(x,y:integer;nome:string); (* stampa legenda testo *)
begin
 outtextxy(x,y,nome);
end;

procedure moto(r1,r2,g3,p1,q1,q2,cu:integer;disco1,disco2:vet;luogo1,luogo2:string);
   (* raggi r1,r2,q1,q2,gradi g3,figura...animazione figura*)
var m,s1,c1,s2,c2,sosta1:integer;
    rad,rad1,s,c:real;
begin
 for m:=0 to orbite do
  begin
  rad:=m*3.14/180;
  rad1:=(m+g3)*3.14/180;
  s:=r1*sin(rad);        (* disco1 *)
  c:=r2*cos(rad);
  s1:=trunc(s);
  c1:=trunc(c);
  s2:=trunc(q1*sin(rad1));(* disco2 *)
  c2:=trunc(q2*cos(rad1));
   setwritemode(0);
   putimage(300+s1,200+c1,disco1,1); (* rotazione disco1 pieno singolo *)
   putimage(300+s2,200+c2,disco2,1); (* rotazione disco2 *)
   putimage(300+s1,200+c1,disco1,0);
   putimage(300+s2,200+c2,disco2,0);
   delay(t);
   if m=90 then outtextxy(20,p1,luogo1);
   if m=270 then outtextxy(480,p1,luogo2);
   if m=180 then outtextxy(270,cu,culmina);
   if (m=90) or(m=180) or(m=270) or (m=360) then sosta1:=sosta;
   delay(sosta1);
   sosta1:=0;
  end;
   delay(t);
   putimage(300+s1,200+c1,disco1,1); (* cancella disco1 tramonto *)
   putimage(300+s2,200+c2,disco2,1); (* cancella disco 2 *)
 end;

 procedure costante;                  (* disegno e testo fisso *)
 begin
 setfillstyle(1,4);                   (* tratto e colore terra *)
 bar(290,250,310,200);                (* terra *)
 setfillstyle(1,2);                   (* orizzonte terra *)
 fillellipse(300,250,40,40);
 line(150,210,450,210);
 testo(40,80,'sole');
 testo(550,80,'luna');
 setcolor(15);
 testo(250,240,'orizzonte terra');
 setcolor(4);
 testo(270,220,'MERIDIANO');
 setcolor(2);
 testo(210,220,'EST');
 testo(390,220,'OVEST');
 setcolor(15);
 testo(20,470,'attendere inizio simulazione,prego');
 setfillstyle(1,14);
 fillellipse(20,20,10,10);            (* sole *)
 getimage(5,5,35,35,sole);            (* vettore sole *)
 setfillstyle(3,5);
 fillellipse(500,20,10,10);           (* luna*)
 getimage(485,5,515,35,luna);         (* vettore luna *)
 end;

procedure programma;                  (* contiene parte principale *)

procedure scelta;                     (* opzione fine o riprova *)
var ch:char;
 begin
 (* textmode(1); *)
 restorecrtmode;
 writeln('per rivedere,premi S,per finire premi N');
 readln(ch);
 if ch='S' then programma
           else fine
 end;

begin

 clrscr;
 simula;                              (* introduzione a programma *)
 grafica(1,1,639,470,1);              (* attiva pagina grafica *)
 costante;                            (* disegno sfondo fisso  *)
 setcolor(5);
 testo(290,450,'LA LUNA');
 setcolor(15);
 testo(270,290,'novilunio');
 luogo1:='sorge alle 6';
 luogo2:='tramonta alle 18';
 culmina:='culmina alle 12';
 moto(-280,190,0,400,-250,160,150,sole,luna,luogo1,luogo2); (* animazione *)
 setcolor(4);
 testo(270,300,'primo quarto');
 luogo1:='sorge alle 12';
 luogo2:='tramonta alle 24 ';
 culmina:='culmina alle 18';
 moto(-280,190,90,410,250,-160,160,sole,luna,luogo1,luogo2);
 setcolor(5);
 testo(270,310,'plenilunio');
 luogo1:='sorge alle 18';
 luogo2:='tramonta alle 6';
 culmina:='culmina alle 24';
 moto(-250,190,180,420,-250,160,170,luna,sole,luogo1,luogo2);
 setcolor(2);
 testo(270,320,'ultimo quarto');
 luogo1:='sorge alle 24';
 luogo2:='tramonta alle 12';
 culmina:='culmina alle 6';
 moto(-250,190,90,430,250,-160,180,luna,sole,luogo1,luogo2);
 readln;
 scelta;                (* opzione fine o rivedere *)
 end;

 begin
 programma;             (* programma principale *)
 pausa;
 end.