program mend124;     (* prima e seconda terza legge di mendel *)
                     (* inserire alleli per due caratteri *)

uses crt,graph;
var d1,r1,d2,r2:string;

procedure grafica;
var t,s:integer;
    stringa:string;
begin
t:=0;
s:=0;
stringa:=('c:\scheda\');....(ove si trova scheda grafica)
initgraph(s,t,stringa);
end;

procedure attende;
begin
delay(2000);
end;

procedure pausa1;
begin
setcolor(4);
outtextxy(430,10,'premi INVIO');readln;
setcolor(0);
outtextxy(430,10,'premi INVIO');
setcolor(15);
end;

procedure pausa;
begin
readln;cleardevice;
end;

procedure sosta;
begin
readln;
end;

procedure testo(x,y:integer;st:string);
begin
outtextxy(x,y,st);
end;

procedure ma(x1,y1,x2,y2,st,cm:integer);
begin
setfillstyle(st,cm);
bar(x1,y1,x2,y2);
end;


procedure programma;
begin
testo(20,20,'PRIMA E SECONDA e TERZA LEGGE DI MENDEL');
outtextxy(20,60,'trasmissione carattere COLORE-ALTEZZA ');
setcolor(4);
outtextxy(20,160,'nel caso di associazione a cromosomi somatici A,B ');
testo(20,180,'A dominante,a recessivo');
testo(20,200,'B dominante,b recessivo');
setcolor(15);
pausa1;cleardevice;
end;


procedure pro1;
begin
(* associato ad A  *)
ma(100,50,125,100,1,4);ma(125,50,150,100,2,4);
ma(300,50,325,100,1,3);ma(325,50,350,100,2,3);
line(125,75,350,75); line(240,245,240,75);
ma(50,220,75,270,8,3);ma(75,220,100,270,7,3);
ma(150,220,175,270,8,3);ma(175,220,200,270,7,3);
ma(300,220,325,270,8,3);ma(325,220,350,270,7,3);
ma(400,220,425,270,8,3);ma(425,220,450,270,7,3);
outtextxy(100,15,r1+'  '+r2);
outtextxy(350,15,d1+'  '+d2);
attende;
setcolor(15);
outtextxy(5,30,'genotipo genitori');
outtextxy(70,70,'aabb');
outtextxy(390,70,'AABB');
outtextxy(5,160,'gametogenesi');
outtextxy(150,160,'ab');
outtextxy(300,160,'AB');
setcolor(3);outtextxy(5,310,'allele dominante su A:'+d1);
testo(5,320,'allele dominante su B:'+d2);
setcolor(4);outtextxy(5,330,'allele recessivo su a: '+r1);
testo(5,340,'allele recessivo su b:'+r2);
setcolor(15);outtextxy(5,290,'genotipo f1');
outtextxy(50,275,'AaBb');
outtextxy(150,275,'AaBb');
outtextxy(300,275,'AaBb');
outtextxy(400,275,'AaBb');
attende;

setfillstyle(7,3);pieslice(530,70,0,180,50);
setfillstyle(8,3);pieslice(530,70,180,360,50);
setcolor(3);
outtextxy(430,150,'100% eterozigoti  AaBb ');
setcolor(15);
pausa1;
end;

procedure pro2;
begin
ma(100,50,125,100,8,3);ma(125,50,150,100,7,3);
ma(325,50,350,100,8,3);ma(350,50,375,100,7,3);
line(125,75,350,75); line(240,245,240,75);
outtextxy(100,15,d1+'  '+d2);
outtextxy(350,15,d1+'  '+d2);
testo(5,30,'genotipo F1 = BbAa');
attende;
setcolor(15);
outtextxy(5,120,'gametogenesi');
outtextxy(150,120,'AB Ab aB ab');
outtextxy(300,120,'AB Ab aB ab');
attende;
setcolor(3);
testo(480,190,'AA');ma(500,190,530,210,1,3);
testo(480,220,'BB');ma(500,220,530,240,2,3);
testo(480,250,'Aa');ma(500,250,530,270,7,3);
testo(480,280,'Bb');ma(500,280,530,300,8,3);
testo(480,310,'aa');ma(500,310,530,330,1,4);
testo(480,340,'bb');ma(500,340,530,360,2,4);
attende;
testo(100,180,'AB');testo(200,180,'Ab');testo(300,180,'aB');testo(400,180,'ab');
testo(50,200,'AB');testo(50,250,'Ab');testo(50,300,'aB');testo(50,350,'ab');
ma(100,200,125,240,1,3);ma(125,200,150,240,2,3);
ma(200,200,225,240,1,3);ma(225,200,250,240,8,3);
ma(300,200,325,240,7,3);ma(325,200,350,240,2,3);
ma(400,200,425,240,7,3);ma(425,200,450,240,8,3);
attende;
ma(100,250,125,290,1,3);ma(125,250,150,290,8,3);
ma(200,250,225,290,1,3);ma(225,250,250,290,2,4);
ma(300,250,325,290,7,3);ma(325,250,350,290,8,3);
ma(400,250,425,290,7,3);ma(425,250,450,290,2,4);
attende;
ma(100,300,125,340,7,3);ma(125,300,150,340,2,3);
ma(200,300,225,340,7,3);ma(225,300,250,340,8,3);
ma(300,300,325,340,1,4);ma(325,300,350,340,2,3);
ma(400,300,425,340,1,4);ma(425,300,450,340,8,3);
attende;
ma(100,350,125,390,7,3);ma(125,350,150,390,8,3);
ma(200,350,225,390,7,3);ma(225,350,250,390,2,4);
ma(300,350,325,390,1,4);ma(325,350,350,390,8,3);
ma(400,350,425,390,1,4);ma(425,350,450,390,2,4);
attende;
setcolor(3);testo(400,50,'25% omozigoti   AA');
setcolor(4);testo(400,60,'25% omozigoti   aa');
setcolor(6);testo(400,70,'50% eterozigoti Aa');
setcolor(3);testo(400,90,'25% omozigoti   BB');
setcolor(4);testo(400,100,'25% omozigoti   bb');
setcolor(6);testo(400,110,'50% eterozigoti Bb');
attende;
setcolor(15);testo(430,130,'fenotipi F2 ');
setcolor(3);testo(430,140,'9/16  AB');
setcolor(2);testo(430,150,'3/16  Ab');
setcolor(6);testo(430,160,'3/16  aB');
setcolor(4);testo(430,170,'1/16  ab');
pausa1;
end;


procedure scelta;
var sce:integer;
begin
setcolor(3);
testo(20,20,'selezionare tra leggi proposte');
setcolor(4);
testo(20,50,'1...prima e seconda legge');
testo(20,60,'2...terza legge');
setcolor(15);testo(20,200,'scelta =');readln(sce);cleardevice;
case sce of
1:pro1;2:pro2;end;
cleardevice;
testo(20,30,'per continuare premi 1..per finire 2 :scelta=');readln(sce);
cleardevice;
if sce=1 then scelta;
end;

begin
writeln('scrivere in lettere minuscole i fenotipi dei due genitori');
writeln('omozigotici dominante e recessivo,per due caratteri ');
write('allele dominante primo carattere =es.nero ');readln(d1);
repeat
write('allele recessivo primo carattere =es.bianco ');readln(r1);
until r1<>d1;
repeat
write('allele dominante secondo carattere =es.alto ');readln(d2);
until ((d2<>d1) and(d2<>r1));
repeat
write('allele recessivo secondo carattere =es.basso ');readln(r2);
until(( r2<>d1) and (r2<>r1) and (r2<>d2));
clrscr;
grafica;
programma;  (* scrivere nome procedura propria *)
scelta;
closegraph;
end.
scrivere in lettere minuscole i fenotipi dei due genitori
omozigotici dominante e recessivo,per due caratteri
allele dominante primo carattere =es.nero nero
allele recessivo primo carattere =es.bianco bianco
allele dominante secondo carattere =es.alto alto
allele recessivo secondo carattere =es.basso basso

ritorna