program mendelx; (* legge della dominanza *) uses crt; var carattere,f1,f2,f12,fd,fr:string[20]; a1,a2:char; x:integer; procedure cancella; begin clrscr; end; procedure stampa; var s:string[4]; begin s:=' '; writeln('carattere :',carattere); textcolor(3);writeln('lettera codificante dominante :',a1); textcolor(6);writeln('lettera codificante recessivo :',a2); textcolor(3);writeln('allele dominante :',fd); textcolor(6);writeln('allele recessivo :',fr); writeln('--------------------------------'); textcolor(3);writeln('fenotipo dominante =',fd); writeln('genotipo dominante =',a1+a1,' gameti :',a1,s,a1); writeln('---------------------------------'); textcolor(6);writeln('fenotipo recessivo =',fr); writeln('genotipo recessivo =',a2+a2,' gameti :',a2,s,a2); writeln('---------------------------------'); textcolor(3);writeln('fenotipo filiale =',fd); writeln('genotipo filiale =',a1+a2); writeln('---------------------------------'); end; procedure chiede; var ris:char; begin cancella; textcolor(15); writeln('scrivere tutto minuscolo '); writeln('genitori entrambi omozigotici per il carattere considerato'); write('scrivi tipo carattere:es.colore ');readln(carattere); cancella; write('scrivi fenotipo 1 genitore =nero ');readln(f1); write('scrivi fenotipo 2 genitore =bianco ');readln(f2); repeat write('scrivi fenotipo generazione filiale 1 =nero ');readln(f12); until (f12=f1) or (f12=f2); writeln('----------------------------------------------------'); if f12=f1 then x:=1 else x:=2; case x of 1:begin a1:=upcase(f1[1]);a2:=f1[1];fd:=f1;fr:=f2;stampa;end; 2:begin a1:=upcase(f2[1]);a2:=f2[1];fd:=f2;fr:=f1;stampa;end; end; write('scrivi S per altra prova,scrivi N per finire ' );readln(ris); if upcase(ris)='S' then chiede; end; begin cancella; chiede; end.