examples/geometri/convgraf.log

   1 PROGRAM convexhull;\r
   2 \r
   3             (* BAYEUL St\82phane Licence Informatique Groupe 1 *)\r
   4 \r
   5 VAR p                          : ARRAYOF points,\r
   6     taille,i,j,n,O12,guziki,c  : INTEGER,\r
   7     choix,souris,valeur,chaine : ARRAYOF CHAR,\r
   8     ligne                      : LINE,\r
   9     inst,quitter               : BOOLEAN;\r
  10 \r
  11 \r
  12 (***********************************************************************)\r
  13            UNIT POINTS : CLASS;\r
  14 (***********************************************************************)\r
  15 VAR x,y : INTEGER,\r
  16       z : CHAR;\r
  17 END points;\r
  18 \r
  19 (***********************************************************************)\r
  20            UNIT LINE : CLASS;\r
  21 (***********************************************************************)\r
  22 VAR p1,p2 : points;\r
  23 END line;\r
  24 \r
  25 (***********************************************************************)\r
  26            UNIT NEWPAGE : PROCEDURE;\r
  27 (***********************************************************************)\r
  28 BEGIN\r
  29    WRITE ( CHR (27), "[2J");\r
  30 END newpage;\r
  31 \r
  32 (***********************************************************************)\r
  33            UNIT SETCURSOR : PROCEDURE (ROW,COLUMN : INTEGER);\r
  34 (***********************************************************************)\r
  35 VAR c,d,e,f : CHAR,\r
  36     i,j     : INTEGER;\r
  37     BEGIN\r
  38        i := row DIV 10;\r
  39        j := row MOD 10;\r
  40        c := CHR (48+i);\r
  41        d := CHR (48+j);\r
  42        i := column DIV 10;\r
  43        j := column MOD 10;\r
  44        e := CHR (48+i);\r
  45        f := CHR (48+j);\r
  46        WRITE ( CHR (27), "[", c, d, ";", e, f, "H");\r
  47 END setcursor;\r
  48 \r
  49 (***********************************************************************)\r
  50             UNIT TRANSENTIER : PROCEDURE (INPUT  chaine : ARRAYOF char;\r
  51                                           OUTPUT nbr    : INTEGER);\r
  52 (***********************************************************************)\r
  53 \r
  54             (* TRANSFORME UNE CHAINE DE CARACTERES EN UN ENTIER *)\r
  55 \r
  56 VAR i : INTEGER;\r
  57 BEGIN\r
  58   nbr := 0;\r
  59   FOR i := 1 to UPPER (chaine) DO\r
  60     CASE chaine(i)\r
  61     WHEN '0','1','2','3','4','5','6','7','8','9' :\r
  62                         nbr := (nbr*10)+(ord(chaine(i))-48);\r
  63     ESAC;\r
  64   OD;\r
  65 END transentier;\r
  66 \r
  67 (***********************************************************************)\r
  68            UNIT FILL : PROCEDURE (X,Y,Large,Haut,Col:INTEGER) ;\r
  69 (***********************************************************************)\r
  70 \r
  71 VAR I : INTEGER ;\r
  72 BEGIN\r
  73   PREF IIUWGRAPH BLOCK\r
  74        BEGIN\r
  75             CALL COLOR (Col) ;\r
  76             FOR I:=Y TO Y+Haut\r
  77             DO\r
  78               CALL MOVE(X,I) ;\r
  79               CALL DRAW(X+Large,I) ;\r
  80             OD ;\r
  81        END ;\r
  82 END FILL;\r
  83 \r
  84 (***********************************************************************)\r
  85            UNIT TEXTE : PROCEDURE (X,Y : INTEGER;\r
  86                                    S   : STRING);\r
  87 (***********************************************************************)\r
  88 \r
  89            (*  Saisie d'un string en colonne X et ligne Y  *)\r
  90 \r
  91 BEGIN\r
  92    PREF IIUWGRAPH BLOCK\r
  93    BEGIN\r
  94         CALL MOVE (X,Y);\r
  95         CALL OUTSTRING(s);\r
  96    END ;\r
  97 END Texte;\r
  98 \r
  99 (***********************************************************************)\r
 100            UNIT SAISIECHAINE : PROCEDURE (INPUT Col,Lig : INTEGER;\r
 101                                           OUTPUT Valeur : ARRAYOF CHAR);\r
 102 (***********************************************************************)\r
 103 \r
 104          (*  Saisie d'une chaine de caract\8ares en graphique  *)\r
 105 \r
 106 VAR C,I,X   : INTEGER;\r
 107 \r
 108 BEGIN\r
 109 PREF IIUWGRAPH BLOCK\r
 110 BEGIN\r
 111     ARRAY VALEUR DIM (1:5);\r
 112     X := COL;\r
 113     C := 0;\r
 114     I := 1;\r
 115     DO\r
 116       C := 0 ;\r
 117       WHILE C = 0\r
 118       DO\r
 119         CALL COLOR (12) ;\r
 120         CALL TEXTE (X,LIG-4," ");\r
 121         C := INKEY;\r
 122         CALL TEXTE (X,LIG,"-");\r
 123       OD;\r
 124       CALL MOVE (X,LIG-4) ;\r
 125       IF (C=13) THEN CALL MOVE (X,LIG-4);CALL HASCII(0);EXIT; FI;\r
 126       IF (C=8) THEN\r
 127         IF X > COL THEN\r
 128               I := I-1;\r
 129               X := X-8;\r
 130               CALL MOVE (X,LIG-4);\r
 131               CALL HASCII (0);\r
 132               CALL TEXTE (X,LIG,"  ");\r
 133               CALL MOVE (X,LIG-4);\r
 134         FI;\r
 135       ELSE\r
 136         IF I <= 5 THEN\r
 137               CALL HASCII (0) ;\r
 138               CALL HASCII (c);\r
 139               VALEUR (i) := CHR (C);\r
 140               I:=I+1;\r
 141               X:=X+8;\r
 142         ELSE\r
 143               CALL COLOR(11);\r
 144               CALL TEXTE(105,258,"Chaine trop longue ");\r
 145               CALL TEXTE(105,274,"Appuyez sur une touche pour continuer");\r
 146               WHILE INKEY=0 DO OD;\r
 147               CALL FILL (101,251,398,58,0) ;\r
 148         FI;\r
 149       FI;\r
 150     OD;\r
 151 END;\r
 152 END SAISIECHAINE;\r
 153 \r
 154 (***********************************************************************)\r
 155            UNIT TAB_PREDEFINI : PROCEDURE;\r
 156 (***********************************************************************)\r
 157 BEGIN\r
 158           (******************************************************)\r
 159           (*             0 <= X >= 52    et    0 <= Y >= 26     *)\r
 160           (******************************************************)\r
 161   taille := 16;\r
 162   ARRAY p DIM (0:taille+1);\r
 163   FOR i:=0 TO taille+1 DO\r
 164       p(i) := NEW points;\r
 165   OD;\r
 166   p(1).x:=3  ;p(1).y:=9  ;p(1).z:='A' ;p(2).x:=11 ;p(2).y:=1  ;p(2).z:='B' ;\r
 167   p(3).x:=6  ;p(3).y:=8  ;p(3).z:='C' ;p(4).x:=4  ;p(4).y:=3  ;p(4).z:='D' ;\r
 168   p(5).x:=5  ;p(5).y:=15 ;p(5).z:='E' ;p(6).x:=8  ;p(6).y:=11 ;p(6).z:='F' ;\r
 169   p(7).x:=1  ;p(7).y:=6  ;p(7).z:='G' ;p(8).x:=7  ;p(8).y:=4  ;p(8).z:='H' ;\r
 170   p(9).x:=9  ;p(9).y:=7  ;p(9).z:='I' ;p(10).x:=14;p(10).y:=5 ;p(10).z:='J';\r
 171   p(11).x:=10;p(11).y:=13;p(11).z:='K';p(12).x:=15;p(12).y:=14;p(12).z:='L';\r
 172   p(13).x:=15;p(13).y:=2 ;p(13).z:='M';p(14).x:=13;p(14).y:=16;p(14).z:='N';\r
 173   p(15).x:=2 ;p(15).y:=12;p(15).z:='O';p(16).x:=12;p(16).y:=10;p(16).z:='P';\r
 174   p(0):=p(16);p(17):=p(1);\r
 175 END tab_predefini;\r
 176 \r
 177 (***********************************************************************)\r
 178            UNIT SAISIE_SOURIS : MOUSE PROCEDURE;\r
 179 (***********************************************************************)\r
 180   VAR h,v,t,b,nbr : INTEGER,\r
 181       l,r,c,fin   : BOOLEAN;\r
 182   BEGIN\r
 183     PREF IIUWgraph BLOCK\r
 184     BEGIN\r
 185          CALL cls; CALL affiche_grille;\r
 186          b:=0;\r
 187          inst := INIT (guziki);\r
 188          IF NOT inst THEN\r
 189             CALL TEXTE(100,100,"Erreur d'installation de la souris");EXIT;\r
 190          FI;\r
 191          CALL DEFCURSOR (1,11,12);\r
 192          CALL SHOWCURSOR;\r
 193          CALL STATUS (h,v,l,r,c);\r
 194          nbr := 1;\r
 195          fin := FALSE;\r
 196          WHILE NOT fin AND nbr<=taille DO\r
 197                CALL GETPRESS (b,h,v,t,l,r,c);\r
 198                IF l THEN\r
 199                  IF 0 <= h DIV 012 ANDIF h DIV O12 <= (640-11) DIV O12 ANDIF\r
 200                     0 <= (316-v) DIV O12 ANDIF (316-v) DIV O12 <= 319 DIV O12 THEN\r
 201                     (* COORDONNEES VALABLES *);\r
 202                     p(nbr)   := NEW points;\r
 203                     p(nbr).x := h DIV O12;\r
 204                     p(nbr).y := (316-v) DIV O12;\r
 205                     p(nbr).z := CHR (64+nbr);\r
 206                     CALL MOVE (h,v) ;\r
 207                     CALL MOVE (p(nbr).x*O12+9,316-(p(nbr).y*O12));\r
 208                     CALL HIDECURSOR ; CALL COLOR (2);\r
 209                     CALL HASCII (ord(p(nbr).z));\r
 210                     CALL SHOWCURSOR ; CALL COLOR (3);\r
 211                     FOR i:=1 TO 3000 DO OD;\r
 212                     nbr:=nbr+1;\r
 213                  ELSE (* COORDONNEES NON VALABLES *);\r
 214                     CALL GETPRESS (b,h,v,t,l,r,c);\r
 215                  FI;\r
 216                FI;\r
 217          OD;\r
 218          p(0) := p(taille); p(taille+1) := p(1);\r
 219          CALL HIDECURSOR;\r
 220     END;\r
 221 END saisie_souris;\r
 222 \r
 223 (***********************************************************************)\r
 224            UNIT SAISIE_POINTS : IIUWgraph PROCEDURE;\r
 225 (***********************************************************************)\r
 226 VAR\r
 227     size,i  : INTEGER,\r
 228     valable : BOOLEAN;\r
 229 BEGIN\r
 230      CALL TEXTE (100,230,"  0 <= X >= 52   et  0 <= Y >= 26  ");\r
 231      FOR i:=1 TO taille DO\r
 232          p(i)    := NEW points;\r
 233          valable := FALSE;\r
 234          WHILE NOT valable DO\r
 235               CALL COLOR (7);\r
 236               CALL TEXTE (100,240,"Abscisses du point nø      :      ");\r
 237               CALL TEXTE (100,250,"Ordonn\82es du point nø      :      ");\r
 238               CALL COLOR (10);\r
 239               CALL MOVE (290,240);CALL HASCII (64+i);\r
 240               CALL MOVE (290,250);CALL HASCII (64+i);\r
 241               CALL COLOR (4);\r
 242               CALL SAISIECHAINE (350,244,chaine);\r
 243               CALL TRANSENTIER (chaine,p(i).x);\r
 244               CALL SAISIECHAINE (350,254,chaine);\r
 245               CALL TRANSENTIER (chaine,p(i).y);\r
 246               IF p(i).x<0 ORIF p(i).x > ((640-11) DIV O12) THEN\r
 247                           valable:=FALSE;\r
 248               ELSE IF p(i).y<0 ORIF p(i).y > (319 DIV O12) THEN\r
 249                           valable:=FALSE;\r
 250                    ELSE valable := TRUE;\r
 251                    FI;\r
 252               FI;\r
 253               p(i).z := CHR (64+i);\r
 254               CALL TEXTE (290,254,"            ");\r
 255               CALL TEXTE (290,244,"            ");\r
 256          OD;\r
 257      OD;\r
 258      p(0) := p(taille); p(taille+1) := p(1);\r
 259 END saisie_points;\r
 260 \r
 261 (***********************************************************************)\r
 262            UNIT AFFICHE_GRILLE : mouse PROCEDURE;\r
 263 (***********************************************************************)\r
 264 VAR i : INTEGER;\r
 265 BEGIN\r
 266    PREF IIUWgraph BLOCK\r
 267    BEGIN                   (* Graduations *)\r
 268         CALL COLOR (7);\r
 269         FOR i := 11 STEP O12 TO 640 DO\r
 270               CALL TEXTE (i,314,".");\r
 271         OD;\r
 272         FOR i := 315 STEP O12 DOWNTO 0 DO\r
 273               CALL TEXTE (11,i,".");\r
 274         OD;                  (* Reperes *)\r
 275         CALL TEXTE (8,16,"Y");\r
 276         CALL TEXTE (8,26,"^");\r
 277         CALL TEXTE (614,316,"> X");\r
 278         CALL MOVE (618,319);\r
 279         CALL DRAW (11,319);     (* Ligne horizontale *)\r
 280         CALL DRAW (11,26);      (* Ligne verticale   *)\r
 281    END;\r
 282 END affiche_grille;\r
 283 \r
 284 (***********************************************************************)\r
 285            UNIT THETA : FUNCTION(P1,P2 : POINTS): REAL;\r
 286 (***********************************************************************)\r
 287 VAR dx,dy,ax,ay : INTEGER,\r
 288     t           : REAL;\r
 289 BEGIN\r
 290     dx := p2.x - p1.x;   ax := ABS (dx);\r
 291     dy := p2.y - p1.y;   ay := ABS (dy);\r
 292     IF (dx=0) AND (dy=0) THEN\r
 293               t := 0;\r
 294     ELSE t := dy/(ax+ay);\r
 295     FI;\r
 296     IF dx<0 THEN\r
 297             t := 2-t;\r
 298     ELSE IF dy<0 THEN\r
 299             t := 4+t;\r
 300          FI;\r
 301     FI;\r
 302     result := t*90.0;\r
 303 END theta;\r
 304 \r
 305 (***********************************************************************)\r
 306            UNIT WRAP : PROCEDURE (INOUT N : INTEGER);\r
 307 (***********************************************************************)\r
 308 VAR j,i,min,m       : INTEGER,\r
 309     minangle,v      : REAL,\r
 310     t,tb,p1,p2,prec : points,\r
 311     ligne           : line;\r
 312 BEGIN\r
 313     min :=1 ; tb := NEW points; t := NEW points;\r
 314     p1    := NEW points; p2   := NEW points;\r
 315     ligne := NEW line  ; prec := NEW points;\r
 316           (* Choix du premier point *)\r
 317     FOR i := 2 TO taille DO\r
 318        IF p(i).y<p(min).y THEN\r
 319                           min := i;\r
 320        ELSE IF p(i).y=p(min).y THEN\r
 321                  IF p(i).x>p(min).x THEN\r
 322                                     min := i;\r
 323                  FI;\r
 324             FI;\r
 325        FI;\r
 326     OD;\r
 327           (*    Initialisations     *)\r
 328     m := 0; p(taille+1) := p(min); minangle := 0.0;\r
 329           (*  Boucle de Recherche   *)\r
 330     DO\r
 331       m:=m+1       ; t:=p(m)    ; p(m):=p(min)     ;p(min):=t;\r
 332       min:=taille+1; v:=minangle; minangle:=360.0;\r
 333       FOR i:=m+1 TO taille+1 DO\r
 334                  (* Recherche du plus petit angle *)\r
 335           IF theta (p(m),p(i))>v THEN\r
 336                  (* Recherche du point suivant *)\r
 337              IF theta (p(m),p(i)) < minangle THEN\r
 338                    min := i; minangle := theta (p(m),p(min));\r
 339              FI;\r
 340                  (* Cas ou plusieurs points sont alignes *)\r
 341              IF theta (p(m),p(i)) = minangle ANDIF p(min)<>p(i) THEN\r
 342                    ligne.p1 := p(m); ligne.p2 := p(min);\r
 343                    IF NOT on (ligne,p(i)) THEN\r
 344                          min := i; minangle := theta (p(m),p(min));\r
 345                    FI;\r
 346              FI;\r
 347           FI;\r
 348       OD;\r
 349       IF min = taille+1 THEN EXIT;\r
 350       FI;\r
 351     OD;\r
 352     n:=M;\r
 353 END wrap;\r
 354 \r
 355 (***********************************************************************)\r
 356            UNIT ON : FUNCTION (L:LINE;P1:POINTS):BOOLEAN;\r
 357 (***********************************************************************)\r
 358 BEGIN\r
 359    result := FALSE;\r
 360    IF (l.p1.x=p1.x) THEN\r
 361        IF l.p1.y>=p1.y ANDIF p1.y>=l.p2.y THEN\r
 362                        result:=TRUE\r
 363        ELSE IF l.p2.y>=p1.Y ANDIF p1.Y>=l.p1.y THEN\r
 364                             result:=TRUE;\r
 365             FI;\r
 366        FI;\r
 367    ELSE\r
 368       IF (l.p1.y=p1.Y) THEN\r
 369          IF l.p1.x<=p1.x ANDIF p1.x<=l.p2.x THEN\r
 370                          result:=TRUE\r
 371          ELSE IF l.p2.x<=p1.x ANDIF p1.X<=l.p1.x THEN\r
 372                               result:=TRUE;\r
 373               FI;\r
 374          FI;\r
 375       FI;\r
 376    FI;\r
 377 END on;\r
 378 \r
 379 (***********************************************************************)\r
 380            UNIT AFFICHE_ENVELOPPE :  IIUWgraph PROCEDURE;\r
 381 (***********************************************************************)\r
 382 BEGIN\r
 383    PREF mouse BLOCK\r
 384    BEGIN\r
 385         CALL COLOR(8);\r
 386         CALL HIDECURSOR;\r
 387         FOR i:=1 TO n-1 DO\r
 388             CALL MOVE ((p(i).x*O12)+ O12,316-(p(i).y*O12)+O12 DIV 4);\r
 389             CALL DRAW ((p(i+1).x*O12)+ O12,316-(p(i+1).y*O12)+O12 DIV 4);\r
 390         OD;\r
 391         CALL MOVE ((p(n).x*O12)+ O12,316-(p(n).y*O12)+O12 DIV 4);\r
 392         CALL DRAW ((p(1).x*O12)+ O12,316-(p(1).y*O12)+O12 DIV 4);\r
 393         CALL SHOWCURSOR;\r
 394    END;\r
 395   CALL COLOR (6);\r
 396   CALL TEXTE (50,335,"L'enveloppe convexe est :");\r
 397   FOR i:=1 TO n DO\r
 398         CALL MOVE (300+(i*10),335);\r
 399         CALL HASCII (ord(p(i).z));\r
 400   OD;\r
 401   CALL COLOR (5);\r
 402   CALL TEXTE (150,325,"Appuyez sur ENTREE pour continuer");\r
 403   C := 0;\r
 404   WHILE C <> 13 DO\r
 405      C := INKEY;\r
 406   OD;\r
 407 END affiche_enveloppe;\r
 408 \r
 409 (***********************************************************************)\r
 410 (*                     Programme principal                             *)\r
 411 (***********************************************************************)\r
 412 BEGIN\r
 413   PREF IIUWgraph BLOCK\r
 414   BEGIN\r
 415     O12:=12;\r
 416     CALL GRON(nocard);\r
 417     quitter:=FALSE;\r
 418     WHILE NOT quitter DO\r
 419         CALL CLS; CALL COLOR (1);\r
 420         CALL TEXTE (100,10,"ÚÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ¿");\r
 421         CALL TEXTE (100,20,"³      Enveloppe convexe      ³");\r
 422         CALL TEXTE (100,30,"ÀÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÙ");\r
 423         CALL COLOR (2);\r
 424         CALL TEXTE (80,100,"Voulez_vous :  aisir des points");\r
 425         CALL TEXTE (80,110,"               tiliser des points pr\82d\82finis");\r
 426         CALL TEXTE (80,120,"               uitter");\r
 427         CALL COLOR (14);\r
 428         CALL MOVE (192,100);CALL OUTSTRING("S");\r
 429         CALL MOVE (192,110);CALL OUTSTRING("U");\r
 430         CALL MOVE (192,120);CALL OUTSTRING("Q");\r
 431         CALL COLOR (5);\r
 432         CALL TEXTE (80,140,"Votre choix : ");\r
 433         CALL SAISIECHAINE (190,144,choix);\r
 434         CALL COLOR (3);\r
 435         WHILE choix(1)<>'u' AND choix(1)<>'s' AND choix(1)<>'q' AND\r
 436                  choix(1)<>'U' AND choix(1)<>'S' AND choix(1)<>'Q' DO\r
 437                  CALL SAISIECHAINE (190,144,choix);\r
 438         OD;\r
 439         CASE choix(1)\r
 440            WHEN 'u','U' : CALL tab_predefini;\r
 441            WHEN 's','S' : CALL TEXTE (100,200,\r
 442                                  "Combien de points voulez_vous saisir :");\r
 443                           CALL  SAISIECHAINE (420,204,chaine);\r
 444                           CALL TRANSENTIER (chaine,taille);\r
 445                           ARRAY p DIM (0:taille+1);\r
 446                           CALL TEXTE (100,210,\r
 447                              "Voulez-vous utiliser la souris (o/n) ?");\r
 448                           CALL SAISIECHAINE (410,214,souris);\r
 449                           WHILE souris(1)<>'O' AND souris(1)<>'N'\r
 450                                    AND souris(1)<>'o' AND souris(1)<>'n' DO\r
 451                              CALL SAISIECHAINE (410,214,souris);\r
 452                           OD;\r
 453                           IF souris(1)='N' ORIF souris(1)='n' THEN\r
 454                                  CALL saisie_points;\r
 455                           ELSE   CALL saisie_souris;\r
 456                           FI;\r
 457            WHEN 'q','Q' : quitter:=TRUE;CALL GROFF; EXIT;\r
 458         ESAC;\r
 459         CALL CLS;\r
 460         CALL COLOR (9);\r
 461         FOR i:=1 TO taille DO\r
 462             CALL MOVE (p(i).x*O12+9,316-(p(i).y*O12));\r
 463             CALL HASCII (ord(p(i).z));\r
 464         OD;\r
 465         CALL affiche_grille;\r
 466         CALL wrap(n);\r
 467         CALL affiche_enveloppe;\r
 468         FOR i:=0 TO taille+1 DO KILL (p(i));OD;\r
 469     OD;\r
 470   END; (*block*)\r
 471 \r
 472 END convex_hull;\1a