examples/examples.old/geometri.log

   1  \r
   2 program geometrie;\r
   3  \r
   4  \r
   5 (***************************************************************************)\r
   6 (* DULON Benjamin                                                          *)\r
   7 (* CORITON Willy                                                           *)\r
   8 (* Licence Informatique                                                    *)\r
   9 (* Groupe 1                                                                *)\r
  10 (*                                                                         *)\r
  11 (*                          P R O J E T     L I 1                          *)\r
  12 (*                                                                         *)\r
  13 (*      ****   ****   ****   *   *   ****   *****   ****   *   ****        *)\r
  14 (*      *      *      *  *   * * *   *        *     *  *   *   *           *)\r
  15 (*      * **   **     *  *   *   *   **       *     ****   *   **          *)\r
  16 (*      *  *   *      *  *   *   *   *        *     * *    *   *           *)\r
  17 (*      ****   ****   ****   *   *   ****     *     *  *   *   ****        *)\r
  18 (*                                                                         *)\r
  19 (***************************************************************************)\r
  20  \r
  21 BEGIN\r
  22  \r
  23 (************************************************************)\r
  24 (* CLASSE DEFINISSANT LES PROCEDURES DE GRAPHISME UTILISEES *)\r
  25 (************************************************************)\r
  26 pref IIUWGRAPH block\r
  27  \r
  28     (*---------------------------------------------------*)\r
  29     (* PROCEDURE permettant d'utiliser le mode GRAPHIQUE *)\r
  30     (*---------------------------------------------------*)\r
  31     unit initgraph : procedure;\r
  32     begin\r
  33       CALL GRON(1);\r
  34     end  initgraph;\r
  35  \r
  36     (*---------------------------------------------------*)\r
  37     (* PROCEDURE permettant de fermer le mode GRAPHIQUE  *)\r
  38     (*---------------------------------------------------*)\r
  39     unit closegraph : procedure;\r
  40     begin\r
  41       CALL GROFF;\r
  42     end closegraph;\r
  43  \r
  44     (*-----------------------------------------------------------------*)\r
  45     (* AFFICHAGE en (x,y) d'un RECTANGLE de longueur l et de hauteur h *)\r
  46     (*-----------------------------------------------------------------*)\r
  47     unit rectangle : procedure(x,y,l,h : integer);\r
  48     begin\r
  49       call move(x,y);\r
  50       call draw (x+l,y);\r
  51       call draw(x+l,y+h);\r
  52       call draw(x,y+h);\r
  53       CALL DRAW(x,y);\r
  54     end rectangle;\r
  55  \r
  56     (*--------------------------------------------------------------------*)\r
  57     (*                 Definition du repere orthonorme                    *)\r
  58     (*--------------------------------------------------------------------*)\r
  59     Unit reportho:procedure;\r
  60     begin\r
  61       call move(425,10);\r
  62       call draw(425,294);\r
  63       call move(225,154);\r
  64       call draw(625,154);\r
  65     end reportho;\r
  66  \r
  67     (*--------------------------------------------------------------------*)\r
  68     (* ECRITURE d'une CHAINE de caracteres sur l'ecran graphique en (x,y) *)\r
  69     (*--------------------------------------------------------------------*)\r
  70     unit ecrit_text : procedure(x,y : integer;str : string);\r
  71     var ch : arrayof character,\r
  72         lg,i : integer;\r
  73     begin\r
  74       call move (x,y);\r
  75       ch := unpack(str);\r
  76       lg := upper(ch) - lower(ch) + 1;\r
  77       for i := 1 to lg do\r
  78         call hascii(0);\r
  79         call hascii(ord(ch(i)));\r
  80       od;\r
  81     end ecrit_text;\r
  82  \r
  83     (*---------------------------------*)\r
  84     (* LECTURE d'une touche au clavier *)\r
  85     (*---------------------------------*)\r
  86     unit inchar : function : integer;\r
  87     var i : integer;\r
  88     begin\r
  89       do\r
  90       i := inkey;\r
  91       if i =/= 0 then exit;\r
  92       fi;\r
  93       od;\r
  94       result := i;\r
  95     end inchar;\r
  96  \r
  97     (*-------------------------------------------------------------------*)\r
  98     (* LECTURE d'un ENTIER au clavier et AFFICHAGE sur l'ecran graphique *)\r
  99     (*-------------------------------------------------------------------*)\r
 100     unit lire_entier: function(x,y:real):real;\r
 101     var nbchiffre,key,i : integer, valeur : real, negatif : boolean;\r
 102     begin\r
 103       negatif := false;\r
 104       valeur:=0;\r
 105       call move(x,y);\r
 106       for i:=1 to 4\r
 107       do\r
 108         call hascii(0);\r
 109       od;\r
 110       call move(x,y);\r
 111       DO\r
 112          (* Lecture de la touche *)\r
 113         key := inchar;\r
 114         if key = 45 then negatif := true ;\r
 115                     call hascii(key);\r
 116         fi;\r
 117         if (key >= 48 and key <= 57)\r
 118         then\r
 119           call hascii(key);\r
 120             (* Saisie de chiffres *)\r
 121           if (nbchiffre < 3 )\r
 122           then\r
 123             valeur := valeur*10 + key - 48;\r
 124           fi;\r
 125         fi;\r
 126  \r
 127         if (key = 27) or (key = 13)  (* touche ESC ou RETOUR chariot *)\r
 128         then exit;\r
 129         fi;\r
 130       od;\r
 131       if negatif then result := -valeur\r
 132       else\r
 133       result:=valeur;\r
 134       fi;\r
 135     end lire_entier;\r
 136  \r
 137     (*---------------------------------------------------------------------*)\r
 138     (* ECRITURE d'un ENTIER sur l'\82cran graphique au coordonn\82es courantes *)\r
 139     (*---------------------------------------------------------------------*)\r
 140     unit ecrit_entier : procedure (posx,posy:integer, x : real);\r
 141     var val,i,j,val2 : integer,\r
 142         ch,ch2 : arrayof character,\r
 143         dec:boolean;\r
 144     begin\r
 145       array ch dim(1:4);\r
 146       array ch2 dim(1:4);\r
 147       for i:=1 to 4\r
 148       do\r
 149         ch(i):=chr(48);\r
 150         ch2(i):=chr(48);\r
 151       od;\r
 152       i := 4;\r
 153       j:=4;\r
 154  \r
 155       val:=entier(x);\r
 156       val2:=x-val;\r
 157  \r
 158       do\r
 159         ch(i) := chr(48+(val mod 10));\r
 160         val := val div 10;\r
 161         if (val = 0) then exit; fi;\r
 162         i := i - 1;\r
 163       od;\r
 164       if val2 = 0 then\r
 165         dec:=true;\r
 166       else\r
 167         do\r
 168           ch2(i):= chr(48+(val2 mod 10));\r
 169           val2:= val2 div 10;\r
 170           if (val2 = 0) then exit; fi;\r
 171           j := j - 1;\r
 172         od;\r
 173       fi;\r
 174       if x < 0\r
 175       then\r
 176         call hascii(0);\r
 177         call hascii(45);\r
 178         posx:=posx+4;\r
 179       fi;\r
 180  \r
 181       while i <= 4\r
 182       do\r
 183         posx:=posx+i;\r
 184         call move(posx,posy);\r
 185         call hascii(0);\r
 186         call hascii(ord(ch(i)));\r
 187         i := i + 1;\r
 188       od;\r
 189       if not dec then\r
 190         call move(posx+8,posy);\r
 191         call hascii(0);\r
 192         call hascii(46);\r
 193         while j <= 4\r
 194         do\r
 195           call move(posx+8*(j+1),posy);\r
 196           call hascii(0);\r
 197           call hascii(ord(ch2(j)));\r
 198           j := j + 1;\r
 199         od;\r
 200       fi;\r
 201   end ecrit_entier;\r
 202  \r
 203   (*\r
 204     unit ecrit_entier : procedure (x:real);\r
 205  \r
 206     var i,j,n,tail : integer,\r
 207         ch : arrayof character,\r
 208         ok:boolean;\r
 209     begin\r
 210       tail:=0;\r
 211       array ch dim(1:7);\r
 212       for i:=1 to 7 do ch(i):=chr(48); od;\r
 213       i := 7;\r
 214       j:=1;\r
 215       n:=x*100;\r
 216       do;\r
 217         ch(i):=chr(48+(n mod 10));\r
 218         n:=n div 10;\r
 219         tail:=tail+1;\r
 220         i:=i-1;\r
 221         if (n=0) then exit; fi;\r
 222       od;\r
 223       if tail<3 then\r
 224         ch(j):=chr(48);\r
 225         i:=1;\r
 226       else\r
 227         for i:=1 to tail-2\r
 228         do\r
 229           ch(i+j-1):=ch(i+8-j-tail);\r
 230         od;\r
 231       fi;\r
 232       ch(i+j):='.';\r
 233       ch(i+j+1):=ch(6);\r
 234       ch(i+j+2):=ch(7);\r
 235       if ok then tail:=tail+1; fi;\r
 236       for i:=1 to tail+j\r
 237       do\r
 238         call hascii(0);\r
 239         call hascii(ord(ch(i)));\r
 240       od;\r
 241     end ecrit_entier;*)\r
 242  \r
 243     (*----------------------------------------------------------------*)\r
 244     (* PROCEDURE EQUATION QUI RENVOIE LES COORDONNEES DE DEUX DROITES *)\r
 245     (*----------------------------------------------------------------*)\r
 246     unit equation:procedure(output x1,y1,x2,y2:real);\r
 247     begin\r
 248       call ecrit_text(430,320,"abscisse premier point: ");\r
 249       x1:=lire_entier(622,320);\r
 250       call ecrit_text(430,330,"ordonnee premier point: ");\r
 251       y1:=lire_entier(622,330);\r
 252       call ecrit_text(430,320,"                            ");\r
 253       call ecrit_text(430,330,"                            ");\r
 254       call ecrit_text(430,320,"abscisse deuxieme point: ");\r
 255       x1:=lire_entier(622,320);\r
 256       call ecrit_text(430,330,"ordonnee deuxieme point: ");\r
 257       y1:=lire_entier(622,330);\r
 258       call ecrit_text(430,320,"                             ");\r
 259       call ecrit_text(430,330,"                             ");\r
 260     end equation;\r
 261  \r
 262     (*---------------------------------------------------------------*)\r
 263     (* PROCEDURE EQUAT QUI SAISIE LES COORDONNEES A B C DE LA DROITE *)\r
 264     (*---------------------------------------------------------------*)\r
 265     unit equat:procedure(output a,b,c:real);\r
 266     begin\r
 267       call ecrit_text(470,317,"valeur de a: ");\r
 268       a:=lire_entier(574,317);\r
 269       call ecrit_text(470,327,"valeur de b: ");\r
 270       b:=lire_entier(574,327);\r
 271       call ecrit_text(470,337,"valeur de c: ");\r
 272       c:=lire_entier(574,337);\r
 273       call ecrit_text(470,317,"                ");\r
 274       call ecrit_text(470,327,"                ");\r
 275       call ecrit_text(470,337,"                ");\r
 276     end equat;\r
 277  \r
 278     (*--------------------------------*)\r
 279     (* PROCEDURE DE SAISIE D'UN POINT *)\r
 280     (*--------------------------------*)\r
 281     unit def_point:procedure(output x1,y1:real);\r
 282  \r
 283     begin\r
 284       call ecrit_text(500,320,"Abscisse: ");\r
 285       x1:=lire_entier(580,320);\r
 286       call ecrit_text(500,330,"Ordonnee: ");\r
 287       y1:=lire_entier(580,330);\r
 288       call ecrit_text(500,320,"              ");\r
 289       call ecrit_text(500,330,"              ");\r
 290     end def_point;\r
 291  \r
 292     (*--------------------------------------------------------*)\r
 293     (* PROCEDURE SOMMAIRE DES DIFFERENTES FONCTIONS PROPOSEES *)\r
 294     (*--------------------------------------------------------*)\r
 295     unit sommaire:procedure;\r
 296     begin\r
 297       call rectangle(1,0,210,306);\r
 298       call ecrit_text  (2,10,"         SOMMAIRE");\r
 299       call ecrit_text  (2,40,"  1: Forme geometrique");\r
 300       call ecrit_text  (2,60,"  2: Dessiner cercle");\r
 301       call ecrit_text  (2,80,"  3: Intersection droites");\r
 302       call ecrit_text (2,100,"  4: Parallelisme ");\r
 303       call ecrit_text (2,120,"  5: Perpendicularite");\r
 304       call ecrit_text (2,140,"  6: Point appart. droite");\r
 305       call ecrit_text (2,160,"  7: Point appart. cercle");\r
 306       call ecrit_text (2,180,"  8: Intersection cercles");\r
 307       call ecrit_text (2,200,"  9: Points/droite");\r
 308       call ecrit_text (2,220," 10: Quitter");\r
 309       call ecrit_text (2,250,"     Votre choix : ");\r
 310     end sommaire;\r
 311  \r
 312     unit ecran:procedure;\r
 313     begin\r
 314       call cls;\r
 315       call sommaire;\r
 316       call texte;\r
 317       call graphique;\r
 318     end ecran;\r
 319  \r
 320     unit graphique:procedure;\r
 321     begin\r
 322       call reportho;\r
 323       call rectangle(215,0,420,306);\r
 324     end graphique;\r
 325  \r
 326     unit texte:procedure;\r
 327     begin\r
 328       call rectangle(1,307,635,42);\r
 329     end texte;\r
 330  \r
 331     (*---------------------------------------------------*)\r
 332     (* PROCEDURE POUR SAISIR LES COORDONNEES D'UN CERCLE *)\r
 333     (*---------------------------------------------------*)\r
 334     unit def_cercle:procedure(output x1,y1,r:real);\r
 335     begin\r
 336       call ecrit_text(350,325,"Rayon: ");\r
 337       r:=lire_entier(406,325);\r
 338       call ecrit_text(450,320,"Abscisse du centre: ");\r
 339       x1:=lire_entier(610,320);\r
 340       call ecrit_text(450,330,"Ordonnee du centre: ");\r
 341       y1:=lire_entier(610,330);\r
 342       call ecrit_text(350,325,"           ");\r
 343       call ecrit_text(450,320,"                       ");\r
 344       call ecrit_text(450,330,"                       ");\r
 345     end def_cercle;\r
 346  \r
 347     (*----------------------------------*)\r
 348     (* PROCEDURE DE DESSIN D'UNE DROITE *)\r
 349     (*----------------------------------*)\r
 350     unit des_droite:procedure(a,b,c:real;output pb:boolean);\r
 351     begin\r
 352       pb:=false;\r
 353       if b=0 then\r
 354         if a=0 then\r
 355           pb:=true;\r
 356         else\r
 357           call move(425-10*c/a,5);\r
 358           call draw(425-10*c/a,295);\r
 359         fi;\r
 360       else\r
 361         call move(625,154+10*((c+20*a)/b));\r
 362         call draw(225,154+10*((c-20*a)/b));\r
 363       fi;\r
 364     end des_droite;\r
 365  \r
 366     (*------------------------------------------*)\r
 367     (* PROCEDURE MISE EN ATTENTE MODE GRAPHIQUE *)\r
 368     (*------------------------------------------*)\r
 369     unit attente:procedure;\r
 370     var reponse,rep:integer;\r
 371     begin\r
 372       call ecrit_text (20,295,"< TAPER SUR ENTREE >");\r
 373       reponse := inkey; (*:=lire_entier(180,295);*)\r
 374          (*reponse := rep + 48 -rep*10;*)\r
 375       while reponse<>13\r
 376       do\r
 377           (*rep:=lire_entier(180,295);*)\r
 378         reponse := inkey ; (*rep + 48 -rep*10;*)\r
 379       od;\r
 380     end attente;\r
 381  \r
 382  \r
 383 (********************************************************)\r
 384 (* CLASSE DEFINISSANT LES FORMES GEOMETRIQUES UTILISEES *)\r
 385 (********************************************************)\r
 386  \r
 387 unit geoplan :CLASS;\r
 388  \r
 389 (*---------------------*)\r
 390 (* DEFINITION DU POINT *)\r
 391 (*---------------------*)\r
 392 unit pt:class(x,y:real);\r
 393  \r
 394     unit equal:function(q:pt):boolean;\r
 395        (* renvoie une valeur booleenne sur l'egalite de deux points *)\r
 396  \r
 397     begin\r
 398       result:=((q.x=x) and (q.y=y));\r
 399     end equal;\r
 400  \r
 401     unit dist:function(p:pt):real;\r
 402        (* renvoie la distance entre deux points *)\r
 403     begin\r
 404       if p=none\r
 405       then\r
 406         call erreur;\r
 407       else\r
 408         result:=sqrt((x-p.x)*(x-p.x)+(y-p.y)*(y-p.y));\r
 409       fi;\r
 410     end dist;\r
 411  \r
 412     unit memecote:function(l:line,p1:pt):boolean;\r
 413        (* vrai si les deux points sont du meme cote de la droite *)\r
 414  \r
 415     var dx1,dx2:real;\r
 416     begin\r
 417       dx1:=l.a*p1.x+l.b*p1.y+l.c;\r
 418       dx2:=l.a*x+l.b*y+l.c;\r
 419       if (dx1>0 and dx2>0) or (dx1<0 and dx2<0)\r
 420       then\r
 421         result:= true;\r
 422       else\r
 423         result:=false;\r
 424       fi;\r
 425     end memecote;\r
 426  \r
 427     unit calculeq:procedure(p1:pt;output a,b,c:real);\r
 428        (* calcul l'equation de la droite en fonction des deux points *)\r
 429  \r
 430     begin\r
 431       a:=y-p1.y;\r
 432       b:=p1.x-x;\r
 433       c:=x*p1.y - p1.x*y;\r
 434     end calculeq;\r
 435  \r
 436     unit virtual  erreur:procedure;\r
 437     begin\r
 438       call ecrit_text(200,325,"Il n'y a pas de point");\r
 439     end erreur;\r
 440  \r
 441 end pt;\r
 442  \r
 443 (*----------------------*)\r
 444 (* DEFINITION DU CERCLE *)\r
 445 (*----------------------*)\r
 446 unit cercle :class(q:pt,r:real);\r
 447  \r
 448     unit intersec:function(c:cercle):line;\r
 449        (* renvoie la ligne d'intersection entre deux cercles *)\r
 450  \r
 451     var r1,r2:real;\r
 452     begin\r
 453       if c<> none\r
 454       then\r
 455         r1:=-r*r-q.x*q.x-q.y*q.y;\r
 456         r2:=c.r*c.r-c.q.x*c.q.x-c.q.y*c.q.y;\r
 457         result:=new line(q.x-c.q.x,q.y-c.q.y,(r1-r2)/2);\r
 458       else\r
 459         call erreur;\r
 460       fi;\r
 461     end intersec;\r
 462  \r
 463     unit ptappartcercle:function(p:pt,epsilon:real):boolean;\r
 464        (* renvoie une valeur booleenne sur l'appartenance de p au cercle *)\r
 465  \r
 466     begin\r
 467       if (p.x-q.x)*(p.x-q.x) + (p.y-q.y)*(p.y-q.y) >= (r-epsilon)*(r-epsilon)\r
 468       and (p.x-q.x)*(p.x-q.x) + (p.y-q.y)*(p.y-q.y) <= (r+epsilon)*(r+epsilon)\r
 469       then\r
 470         result:=true;\r
 471       else\r
 472         result:=false;\r
 473      fi;\r
 474     end ptappartcercle;\r
 475  \r
 476     unit virtual erreur:procedure;\r
 477     begin\r
 478       call ecrit_text(200,325,"Il n'y a pas de cercles");\r
 479       writeln("Il n'y a pas de cercle");\r
 480     end erreur;\r
 481  \r
 482 end cercle;\r
 483  \r
 484 (*-------------------------*)\r
 485 (* DEFINITION DE LA DROITE *)\r
 486 (*-------------------------*)\r
 487 unit line:class(a,b,c:real);\r
 488  \r
 489     unit meet:function(l:line):pt;\r
 490        (* renvoie le point d'intersection de deux droites *)\r
 491  \r
 492     var t:real;\r
 493     begin\r
 494       if parallele(l) then\r
 495         call ecrit_text(200,325,"Les deux droites sont paralleles");\r
 496       else\r
 497         if l<> none\r
 498         then\r
 499           t:=1/(l.a*b-l.b*a);\r
 500           result:=new pt((c*l.b-b*l.c)/t,(a*l.c-c*l.a)/t);\r
 501         else call erreur;\r
 502         fi;\r
 503       fi;\r
 504     end meet;\r
 505  \r
 506     unit parallele:function(l:line):boolean;\r
 507        (* renvoie une valeur booleenne sur le parallelisme de deux droites *)\r
 508  \r
 509     begin\r
 510       if l <> none\r
 511       then\r
 512         if a*l.b -b*l.a=0\r
 513         then\r
 514           result:=true;\r
 515         else\r
 516           result:=false;\r
 517         fi;\r
 518       else call erreur;\r
 519       fi;\r
 520     end parallele;\r
 521  \r
 522     unit perpendiculaire:function(l:line):boolean;\r
 523        (* renvoie une valeur booleenne sur la perpendicularite de deux droites *)\r
 524  \r
 525     begin\r
 526       if l <> none\r
 527       then\r
 528         if a*l.a + b*l.b=0\r
 529         then\r
 530           result:=true;\r
 531         else\r
 532           result:=false;\r
 533         fi;\r
 534       else call erreur;\r
 535       fi;\r
 536     end perpendiculaire;\r
 537  \r
 538     unit ptappartligne:function(p:pt):boolean;\r
 539        (* renvoie une valeur booleenne sur l'appartenance de p a la droite *)\r
 540  \r
 541     begin\r
 542       if a*p.x + b*p.y +c=0\r
 543       then\r
 544         result:=true;\r
 545       else\r
 546         result:=false;\r
 547      fi;\r
 548     end ptappartligne;\r
 549  \r
 550     unit virtual erreur:procedure;\r
 551     begin\r
 552       call ecrit_text(200,325,"Pas de droite");\r
 553     end erreur;\r
 554  \r
 555 var d:real;\r
 556 begin\r
 557   d:=sqrt(a*a+b*b);\r
 558   if d<>0\r
 559   then\r
 560     a:=a/d;\r
 561     b:=b/d;\r
 562     c:=c/d;\r
 563   fi;\r
 564 end line;\r
 565  \r
 566 END geoplan;\r
 567  \r
 568  \r
 569 (*---------------------------------------------------------*)\r
 570 (* PROCEDURE GOTOXY POUR DEPLACER LE CURSEUR EN MODE TEXTE *)\r
 571 (*---------------------------------------------------------*)\r
 572 unit gotoxy:procedure(ligne,colonne:integer);\r
 573 var  i,j:integer,\r
 574      c,d,e,f:char;\r
 575  \r
 576 begin\r
 577  \r
 578   i:=ligne div 10;\r
 579   j:=ligne mod 10;\r
 580   c:=chr(48+i);\r
 581   d:=chr(48+j);\r
 582   i:=colonne div 10;\r
 583   j:=colonne mod 10;\r
 584   e:=chr(48+i);\r
 585   f:=chr(48+j);\r
 586  \r
 587   write(chr(27), "[",c,d,";",e,f,"H");\r
 588 end gotoxy;\r
 589  \r
 590 (*----------------------------------------------*)\r
 591 (* PROCEDURE POUR EFFACER L'ECRAN EN MODE TEXTE *)\r
 592 (*----------------------------------------------*)\r
 593 unit effacecran:procedure;\r
 594 begin\r
 595   write(chr(27),"[2J");\r
 596 end effacecran;\r
 597  \r
 598 (*--------------------------------------------------------*)\r
 599 (* PROCEDURE POUR METTRE L'ECRAN EN ATTENTE EN MODE TEXTE *)\r
 600 (*--------------------------------------------------------*)\r
 601 unit attent:procedure;\r
 602 var reponse:char;\r
 603 begin\r
 604   call gotoxy(25,45);\r
 605   writeln("taper sur entree");\r
 606   reponse:='r';\r
 607   while reponse='r'\r
 608   do\r
 609     read(reponse);\r
 610   od;\r
 611 end attent;\r
 612  \r
 613  \r
 614 (*****************************************************************************)\r
 615 (*                             PROGRAMME PRINCIPAL                           *)\r
 616 (*****************************************************************************)\r
 617  \r
 618 begin\r
 619 pref geoplan block\r
 620  \r
 621 const epsilon=0.1;\r
 622 var  p,q,centre,p1,p2:pt,\r
 623      l2,l1:line,\r
 624      c2,c3:cercle,\r
 625      x1,y1,x2,y2,r,a,b,c,a1,b1,c1:real,\r
 626      ch,n,rep,rep2,i:integer,\r
 627      fin,pb,pb1:boolean,\r
 628      t:arrayof arrayof real,\r
 629      tab1,tab2: arrayof integer;\r
 630  \r
 631 begin\r
 632   call effacecran;\r
 633   call gotoxy(3,10);\r
 634   writeln("CORITON willy");\r
 635   call gotoxy(5,10);\r
 636   writeln("DULON Benjamin");\r
 637   call gotoxy(7,10);\r
 638   writeln("Licence informatique");\r
 639   call gotoxy(9,10);\r
 640   writeln("Groupe 1");\r
 641   call gotoxy(12,10);\r
 642   writeln("PROJET LI1");\r
 643   call gotoxy(13,10);\r
 644   writeln("----------");\r
 645   call gotoxy(16,10);\r
 646   writeln("*****   *****   *****   **  **   *****   *****   *****   *   *****");\r
 647   call gotoxy(17,10);\r
 648   writeln("*       *       *   *   * ** *   *         *     *   *   *   *   ");\r
 649   call gotoxy(18,10);\r
 650   writeln("* ***   **      *   *   *    *   **        *     *****   *   **  ");\r
 651   call gotoxy(19,10);\r
 652   writeln("*   *   *       *   *   *    *   *         *     *  *    *   *   ");\r
 653   call gotoxy(20,10);\r
 654   writeln("*****   *****   *****   *    *   *****     *     *   *   *   *****");\r
 655   call attent;\r
 656  \r
 657   (* OUVERTURE DU MODE GRAPHIQUE *)\r
 658   call initgraph;\r
 659   rep:=0;\r
 660   fin:=false;\r
 661   while not fin\r
 662   do\r
 663     rep:=0;\r
 664     while rep<=0 or rep>10\r
 665     do\r
 666       call ecran;\r
 667       rep:=lire_entier(160,250);\r
 668       case rep\r
 669                    (* dessiner une forme *)\r
 670         when 1: call ecrit_text(10,325,"Combien de sommets : ");\r
 671                 n := lire_entier(178,325);\r
 672                 array t dim(1:n);\r
 673                 for i:=1 to n\r
 674                 do\r
 675                   array t(i) dim (1:2);\r
 676                 od;\r
 677                 for i:=1 to n\r
 678                 do\r
 679                   call ecrit_text(250,315,"Pour le point numero ");\r
 680                   call hascii(0);\r
 681                   call hascii(i);\r
 682                   call ecrit_text(250,325,"Abscisse: ");\r
 683                   t(i,1):= lire_entier(338,325);\r
 684                   call ecrit_text(250,335,"Ordonn\82e: ");\r
 685                   call ecrit_text(250,325,"              ");\r
 686                   call ecrit_text(250,335,"              ");\r
 687                   t(i,2):= lire_entier(338,335);\r
 688                 od;\r
 689                 call move(10*t(1,1)+425,154-10*t(1,2));\r
 690                 for i:=2 to n\r
 691                 do\r
 692                   call draw(10*t(i,1)+425,154-10*t(i,2));\r
 693                 od;\r
 694                 call draw(10*t(1,1)+425,154-10*t(1,2));\r
 695                 rep:=0;\r
 696                 CALL ecrit_text (20,295,"< TAPER SUR ENTREE >");\r
 697                 call attente;\r
 698  \r
 699                    (* dessiner un cercle *)\r
 700         when 2: call def_cercle(x1,y1,r);\r
 701                 call point(x1*10+425,154-y1*10);\r
 702                 call cirb(x1*10+425,154-y1*10,r*10,0,0,15,0,1,1);\r
 703                 p1:=new pt(x1,y1);\r
 704                 c2:= new cercle(p1,r);\r
 705                 call ecrit_text (20,295,"< TAPER SUR ENTREE >");\r
 706                 call attente;\r
 707                 rep:=0;\r
 708  \r
 709                    (* intersection de deux droites *)\r
 710         when 3: call ecrit_text(10,325,"Equation/P (1/2): ");\r
 711                 rep2:=lire_entier(154,325);\r
 712                 if rep2 = 2\r
 713                 then\r
 714                   call ecrit_text(280,325,"Premiere droite");\r
 715                   call equation(x1,y1,x2,y2);\r
 716                   p1:= new pt(x1,y1);\r
 717                   p2:= new pt(x2,y2);\r
 718                   call p1.calculeq(p2,a,b,c);\r
 719                   call ecrit_text(280,325,"Deuxieme droite");\r
 720                   call equation(x1,y1,x2,y2);\r
 721                   p1:= new pt(x1,y1);\r
 722                   p2:= new pt(x2,y2);\r
 723                   call p1.calculeq(p2,a1,b1,c1);\r
 724                 else\r
 725                   call ecrit_text(200,325,"Coordonnes premiere droite");\r
 726                   call equat(a,b,c);\r
 727                   call ecrit_text(200,325,"Coordonnes deuxieme droite");\r
 728                   call equat(a1,b1,c1);\r
 729                 fi;\r
 730  \r
 731                 l1:= new line(a,b,c);\r
 732                 l2:= new line(a1,b1,c1);\r
 733                 centre:=l1.meet(l2);\r
 734  \r
 735                 array tab1 dim(1:5000);\r
 736                 call move(1,307);\r
 737                 tab1:=getmap(636,349);\r
 738                 call des_droite(a,b,c,pb);\r
 739                 call des_droite(a1,b1,c1,pb1);\r
 740                 call move(1,307);\r
 741                 call putmap(tab1);\r
 742  \r
 743                 if pb or pb1 then\r
 744                   call ecrit_text(250,325,"Probleme de saisie de droite   ");\r
 745                 else\r
 746                   if centre=/=none\r
 747                   then\r
 748                     call ecrit_text(200,325,"Le point d'intersection a pour coordonnee : ");\r
 749                     call ecrit_entier(560,325,centre.x);\r
 750    (*           call ecrit_entier(560,335,centre.y); *)\r
 751                   else\r
 752                     call ecrit_text(200,325,"Il n'y a pas de point d'intersection");\r
 753                   fi;\r
 754                 fi;\r
 755                 rep:=0;\r
 756                 CALL ecrit_text (20,295,"< TAPER SUR ENTREE >");\r
 757                 call attente;\r
 758  \r
 759                    (* parallelisme de deux droites *)\r
 760         when 4: call ecrit_text(10,325,"Equation/P (1/2): ");\r
 761                 rep2:=lire_entier(154,325);\r
 762                 if rep2 = 2\r
 763                 then\r
 764                   call ecrit_text(280,325,"Premiere droite");\r
 765                   call equation(x1,y1,x2,y2);\r
 766                   p1:= new pt(x1,y1);\r
 767                   p2:= new pt(x2,y2);\r
 768                   call p1.calculeq(p2,a,b,c);\r
 769                   call ecrit_text(280,325,"Deuxieme droite");\r
 770                   call equation(x1,y1,x2,y2);\r
 771                   p1:= new pt(x1,y1);\r
 772                   p2:= new pt(x2,y2);\r
 773                   call p1.calculeq(p2,a1,b1,c1);\r
 774                 else\r
 775                   call ecrit_text(280,325,"Premiere droite");\r
 776                   call equat(a,b,c);\r
 777                   call ecrit_text(280,325,"Deuxieme droite");\r
 778                   call equat(a1,b1,c1);\r
 779                 fi;\r
 780  \r
 781                 l1:= new line(a,b,c);\r
 782                 l2:= new line(a1,b1,c1);\r
 783  \r
 784                 array tab1 dim(1:5000);\r
 785                 call move(1,307);\r
 786                 tab1:=getmap(636,349);\r
 787                 call des_droite(a,b,c,pb);\r
 788                 call des_droite(a,b,c,pb1);\r
 789                 call move(1,307);\r
 790                 call putmap(tab1);\r
 791  \r
 792                 if pb or pb1 then\r
 793                   call ecrit_text(250,325,"Probleme de saisie de droite   ");\r
 794                 else\r
 795                   if l1.parallele(l2)\r
 796                   then\r
 797                     call ecrit_text(280,325,"Les droites sont paralleles");\r
 798                   else\r
 799                     call ecrit_text(280,325,"Les droites ne sont pas paralleles");\r
 800                   fi;\r
 801                 fi;\r
 802                 rep:=0;\r
 803                 call ecrit_text (20,295,"< TAPER SUR ENTREE >");\r
 804                 call attente;\r
 805  \r
 806                    (* perpendicularite de deux droites *)\r
 807         when 5: call ecrit_text(10,325,"Equation/P (1/2): ");\r
 808                 rep2:=lire_entier(154,325);\r
 809                 if rep2 = 2\r
 810                 then\r
 811                   call ecrit_text(280,325,"Premiere droite");\r
 812                   call equation(x1,y1,x2,y2);\r
 813                   p1:= new pt(x1,y1);\r
 814                   p2:= new pt(x2,y2);\r
 815                   call p1.calculeq(p2,a,b,c);\r
 816                   call ecrit_text(280,325,"Deuxieme droite");\r
 817                   call equation(x1,y1,x2,y2);\r
 818                   p1:= new pt(x1,y1);\r
 819                   p2:= new pt(x2,y2);\r
 820                   call p1.calculeq(p2,a1,b1,c1);\r
 821                 else\r
 822                   call ecrit_text(280,325,"Premiere droite");\r
 823                   call equat(a,b,c);\r
 824                   call ecrit_text(280,325,"Deuxieme droite");\r
 825                   call equat(a1,b1,c1);\r
 826                 fi;\r
 827  \r
 828                 array tab1 dim(1:5000);\r
 829                 call move(1,307);\r
 830                 tab1:=getmap(636,349);\r
 831                 call des_droite(a,b,c,pb);\r
 832                 call des_droite(a,b,c,pb);\r
 833                 call move(1,307);\r
 834                 call putmap(tab1);\r
 835                 l1:= new line(a,b,c);\r
 836                 l2:= new line(a1,b1,c1);\r
 837  \r
 838                 if pb or pb1 then\r
 839                   call ecrit_text(250,325,"Probleme de saisie de droite   ");\r
 840                 else\r
 841                   if l1.perpendiculaire(l2)\r
 842                   then\r
 843                     call ecrit_text(280,325,"Les droites sont perpendiculaires");\r
 844                   else\r
 845                     call ecrit_text(280,325,"Les droites ne sont pas perpendiculaires");\r
 846                   fi;\r
 847                 fi;\r
 848                 rep:=0;\r
 849                 call ecrit_text (20,295,"< TAPER SUR ENTREE >");\r
 850                 call attente;\r
 851  \r
 852                    (* appartenance d'un point a une droite *)\r
 853         when 6: call ecrit_text(10,320,"Determination de la droite");\r
 854                 call ecrit_text(10,330,"Equation/P (1/2): ");\r
 855                 rep2:=lire_entier(154,330);\r
 856                 if rep2 = 2\r
 857                 then\r
 858                   call equation(x1,y1,x2,y2);\r
 859                   p1:= new pt(x1,y1);\r
 860                   p2:= new pt(x2,y2);\r
 861                   call p1.calculeq(p2,a,b,c);\r
 862                 else\r
 863                   call ecrit_text(300,325,"Coordonnees droite");\r
 864                   call equat(a,b,c);\r
 865                 fi;\r
 866                 call ecrit_text(300,325,"Coordonnees point ");\r
 867                 call def_point(x1,y1);\r
 868                 p1:= new pt(x1,y1);\r
 869                 l1:= new line(a,b,c);\r
 870                 call point(x1,y1);\r
 871  \r
 872                 array tab1 dim(1:5000);\r
 873                 call move(1,307);\r
 874                 tab1:=getmap(636,349);\r
 875                 call des_droite(a,b,c,pb);\r
 876                 call move(1,307);\r
 877                 call putmap(tab1);\r
 878  \r
 879                 if pb\r
 880                 then\r
 881                   call ecrit_text(250,325,"Probleme de saisie de la droite   ");\r
 882                 else\r
 883                   if l1.ptappartligne(p1)\r
 884                   then\r
 885                     call ecrit_text(250,325,"Le point appartient a la droite");\r
 886                   else\r
 887                     call ecrit_text(250,325,"Le point n'appartient pas a la droite");\r
 888                   fi;\r
 889                 fi;\r
 890                 rep:=0;\r
 891                 call ecrit_text (20,295,"< TAPER SUR ENTREE >");\r
 892                 call attente;\r
 893  \r
 894                    (* appartenance d'un point a un cercle *)\r
 895         when 7: call ecrit_text(200,325,"Determination du point");\r
 896                 call def_point(x1,y1);\r
 897                 p1:=new pt(x1,y1);\r
 898                 call point(454+10*x1,154-10*y1);\r
 899                 call ecrit_text(200,325,"                      ");\r
 900                 call ecrit_text(100,325,"Determination du cercle");\r
 901                 call def_cercle(x1,y1,r);\r
 902                 call point(x1*10+425,154-y1*10);\r
 903                 call cirb(x1*10+425,154-y1*10,r*10,0,0,15,0,1,1);\r
 904                 p2:=new pt(x1,y1);\r
 905                 c2:= new cercle(p2,r);\r
 906                 call ecrit_text(100,325,"                      ");\r
 907  \r
 908                 if c2.ptappartcercle(p1,epsilon)\r
 909                 then\r
 910                   call ecrit_text(250,325,"Le point appartient au cercle");\r
 911                 else\r
 912                   call ecrit_text(250,325,"Le point n'appartient pas au cercle");\r
 913                 fi;\r
 914                 rep:=0;\r
 915                 call ecrit_text (20,295,"< TAPER SUR ENTREE >");\r
 916                 call attente;\r
 917  \r
 918                    (* intersection entre deux cercles *)\r
 919         when 8: call ecrit_text(10,325,"Pour le premier cercle");\r
 920                 call def_cercle(x1,y1,r);\r
 921                 call point(x1*10+425,154-y1*10);\r
 922                 call cirb(x1*10+425,154-y1*10,r*10,0,0,15,0,1,1);\r
 923                 p1:=new pt(x1,y1);\r
 924                 c2:= new cercle(p1,r);\r
 925                 call ecrit_text(10,325,"Pour le second cercle ");\r
 926                 call def_cercle(x1,y1,r);\r
 927                 call point(x1*10+425,154-y1*10);\r
 928                 call cirb(x1*10+425,154-y1*10,r*10,0,0,15,0,1,1);\r
 929                 p2:=new pt(x1,y1);\r
 930                 c3:= new cercle(p2,r);\r
 931  \r
 932                 l1:=c2.intersec(c3);\r
 933                 call ecrit_text(10,325,"                      ");\r
 934                 call ecrit_text(200,325,"La droite a pour equation");\r
 935                 rep:=0;\r
 936                 call ecrit_text (20,295,"< TAPER SUR ENTREE >");\r
 937                 call attente;\r
 938  \r
 939                    (* deux points d'un meme cote d'une droite *)\r
 940         when 9: call ecrit_text(10,320,"Determination de la droite");\r
 941                 call ecrit_text(10,330,"Equation/P (1/2): ");\r
 942                 rep2:=lire_entier(154,330);\r
 943                 if rep2 = 2\r
 944                 then\r
 945                   call equation(x1,y1,x2,y2);\r
 946                   p1:= new pt(x1,y1);\r
 947                   p2:= new pt(x2,y2);\r
 948                   call p1.calculeq(p2,a,b,c);\r
 949                 else\r
 950                   call ecrit_text(280,325,"Coordonnees droite");\r
 951                   call equat(a,b,c);\r
 952                 fi;\r
 953                 call ecrit_text(280,325,"Coordonnees premier point ");\r
 954                 call def_point(x1,y1);\r
 955                 call point(425+10*x1,154-10*y1);\r
 956                 p1:= new pt(x1,y1);\r
 957                 call ecrit_text(280,325,"Coordonnees second point ");\r
 958                 call def_point(x1,y1);\r
 959                 call point(425+10*x1,154-10*y1);\r
 960                 p2:= new pt(x1,y1);\r
 961  \r
 962                 array tab1 dim(1:5000);\r
 963                 call move(1,307);\r
 964                 tab1:=getmap(636,349);\r
 965                 call des_droite(a,b,c,pb);\r
 966                 call move(1,307);\r
 967                 call putmap(tab1);\r
 968  \r
 969                 l1:= new line(a,b,c);\r
 970                 if pb\r
 971                 then\r
 972                   call ecrit_text(250,325,"Probleme de saisie de la droite  ");\r
 973                 else\r
 974                   if p1.memecote(l1,p2)\r
 975                   then\r
 976                     call ecrit_text(280,325,"Les deux points sont du meme cote");\r
 977                   else\r
 978                     call ecrit_text(280,325,"Les deux points ne sont pas du meme cote");\r
 979                   fi;\r
 980                 fi;\r
 981                 rep:=0;\r
 982                 call ecrit_text (20,295,"< TAPER SUR ENTREE >");\r
 983                 call attente;\r
 984  \r
 985                    (* quitter *)\r
 986         when 10: ch:=0;\r
 987                  while ch<1 or ch>2\r
 988                  do\r
 989                    call ecrit_text(10,325,"Voulez-vous vraiment : ");\r
 990                    call ecrit_text(220,320,"1: Quitter le programme ");\r
 991                    call ecrit_text(220,335,"2: Continuer ");\r
 992                    call ecrit_text(450,325,"Votre choix : ");\r
 993                    ch:=lire_entier(562,325);\r
 994                    call ecrit_text (20,295,"< TAPER SUR ENTREE >");\r
 995                    case ch\r
 996                      when 1: fin:=true;\r
 997                      when 2: exit;exit;rep:=0;\r
 998                    esac;\r
 999                  od;\r
1000       esac;\r
1001     od;\r
1002   od;\r
1003  \r
1004   (* FERMETURE DU MODE GRAPHIQUE *)\r
1005   call closegraph;\r
1006 end;\r
1007 end;\r
1008 end;\r
1009 end geometrie;\r