doc/examples/graf96.log

   1
   2 program GRAF;
   3 #include "classes/gui.inc"
   4
   5  (* wersja z usuwaniem lukow grafu i tablica list reprezentujaca graf     *)
   6  (* Algorithmes : search *)
   7  (* BFS + DFS + STRANGE-STACK chodzenie po grafie                         *)
   8  (* path, cycle, topological sort ???*)
   9  (* Program wykorzystuje plik z przygotowanym grafem /graf.dta *)
  10  (* oraz plik /graf.txt z odrobina informacji o programie      *)
  11  (* Wykonanie algorytmow mozna przerywac, naciskajac prawy klawisz myszy*)
  12  (* gdy pojawi sie  STOP? *)
  13 const
  14         dimX = 640,
  15         dimY = 480,
  16         MinX =  10,
  17         MinY =  5,
  18         MaxX = dimX-10,
  19         MaxY = 372,
  20         comX = MinX+10,
  21         comY = dimY-40,
  22         piszX = MinX+10,
  23         piszY = MaxY-17,
  24         StrMinY = dimY-100,
  25         StrMaxY = dimY-20,
  26         wrnX = MinX+ 10, (*  miejsce na ostrzezenia*)
  27         wrnY = StrMinY+ 20,
  28
  29         mysz = 1,
  30         klawiatura = 1,
  31         nie_klawiatura =0;
  32
  33 unit punkt : class(x,y:integer);
  34 end punkt;
  35
  36
  37 begin
  38         pref GUI block
  39
  40
  41
  42
  43 (*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)
  44 (*                    STRUKTURA  LIST                                      *)
  45 (* first - funkcja bez parametrow, ktorej wynikiem jest pierwszy element   *)
  46 (*         dodatkowo ustawia biezacy element jako poczatek listy           *)
  47 (* out   - procedura powalajaca usunac pierwszy element listy              *)
  48 (* insert- procedura z jednym parametrem typu elem, ktora pozwala dolaczyc *)
  49 (*         nowy element na koncu listy                                     *)
  50 (* next  - nastepny element listy lub none, jesli go nie ma                *)
  51 (* prev  - poprzedni element listy lub none, jesli go nie ma               *)
  52 (* link  - jest typem pomocniczym, ogniwem w liscie                        *)
  53 (*-------------------------------------------------------------------------*)
  54
  55     unit Liste : class;
  56     var premier, dernier, courant : link;
  57
  58     unit link : class(e: elem, prec:link, suiv: link);
  59     var used: boolean;
  60        unit use :procedure;
  61        begin
  62             used:= true;
  63        end use;
  64     begin
  65        used := false;
  66     end link;
  67
  68     unit debut : procedure;
  69     (* post condition: (courant= x)  => debut (courant= premier)) *)
  70     begin
  71          courant := premier;
  72     end debut;
  73
  74     unit restore : procedure;
  75     begin
  76          courant := premier;
  77          while courant<>none
  78          do courant.used:= false; courant:= courant.suiv od;
  79          courant := premier;
  80     end restore;
  81
  82     unit next : function : elem;
  83     begin
  84          result := none;
  85          if courant<>none then
  86             courant := courant.suiv;
  87             if courant<>none then
  88                 result := courant.e
  89             fi
  90          fi;
  91     end next;
  92
  93     unit prev : function : elem;
  94     begin
  95          result := none;
  96          if courant<>none then
  97             if courant.prec<> none then
  98                 courant := courant.prec;
  99                 result := courant.e
 100             fi
 101          fi;
 102     end prev;
 103
 104     unit first : function : elem;
 105     begin
 106         result:= none;
 107         if premier <> none then
 108             result := premier.e;
 109         fi;
 110     end first;
 111
 112     unit insert: procedure(e:elem);
 113     (* post condition: (courant=x) => insert(e)(courant=x and e is_in_this_list) *)
 114     var l : link;
 115     begin
 116       l := new link(e,dernier,none);
 117       if premier=none then
 118          premier := l;
 119       else
 120          dernier.suiv := l;
 121       fi;
 122       dernier := l;
 123     end insert;
 124
 125     unit delete : procedure(e : elem);
 126     (* delete an element e;   *)
 127     (* post condition : delete(e)(courant=premier  and e is_not_in_this_list) *)
 128     var l,l1,aux : link, trouve : boolean;
 129     begin
 130         aux := premier;
 131         while  aux<>none
 132         do
 133            if aux.e.egal(e) then
 134                trouve := true; exit
 135            else
 136                 aux := aux.suiv
 137            fi
 138         od;
 139         if trouve then
 140             l := aux.prec;
 141             l1 := aux.suiv;
 142             if l<>none then
 143                 l.suiv := l1;
 144                 if l1<>none then
 145                     l1.prec := l
 146                 fi;
 147                 kill(aux)
 148             else
 149                 premier := premier.suiv;
 150             fi;
 151         fi;
 152         courant := premier
 153     end delete;
 154
 155     unit empty : function: Boolean;
 156     begin
 157        result := (premier = none)
 158     end empty;
 159
 160    begin
 161        premier := none; dernier := none; courant := premier;
 162    end liste;
 163
 164
 165 (*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)
 166 (*  ELEM jest typem elementow uzywanych we wszystkich strukturach tego progr.*)
 167
 168    unit elem : class;
 169       unit virtual visite : function : boolean;
 170       end visite;
 171       unit virtual egal : function (e:elem) : boolean;
 172       end egal;
 173       unit virtual affichage : procedure;
 174       end affichage;
 175    end elem;
 176
 177 (*++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)
 178 (*      OGOLNY MODEL STRUKTURY ABSTRAKCYJNEJ                                *)
 179
 180    unit structure : class;
 181     const x0= MinX+40,
 182           y0= StrMinY+40,
 183           delta= 30;
 184     var speedL : integer;
 185     (*pozycja poczatkowa i przesuniecie dla ilustracji zawartosci struktury*)
 186
 187       unit virtual first : function : elem;
 188       end first;
 189       unit virtual delete :  procedure;
 190       end delete;
 191       unit virtual insert :  procedure (e:elem);
 192       end insert;
 193       unit virtual empty :  function : boolean;
 194       end empty;
 195
 196       unit box : class;
 197       var   e : elem,
 198             next : box;
 199       end box;
 200
 201       UNIT TRAVERSE :  procedure (G : Graph );
 202       (* przegladanie grafu(ktory ma postac tablicy list) z uzyciem*)
 203       (* nieznanej struktury danych z operacjami: empty,first,insert,delete*)
 204       var  i,debut,fin : integer,
 205            aux, aux1    : node;
 206       begin
 207         debut:= G.root; fin:= G.nr;
 208         i:= debut;
 209         while i <= fin
 210         do
 211           aux := G.lista(i);
 212           if not aux.visite
 213           then
 214             call aux.visite_le;
 215             call insert(aux);
 216             aux.father := none;
 217             while not empty
 218             do
 219                  aux := first;
 220                  call delete;
 221                  if aux.father<>none then
 222                     call G.strzalka(aux.father,aux,i mod 7,c_black)
 223                  fi;
 224                  call aux.wypisz(i mod 7);(* i wyznacza kolor *)
 225
 226                  if not aux.lista.empty then
 227                        aux1 := aux.lista.first;
 228                        while  aux1<>none
 229                        do
 230                          if not aux1.visite then
 231                               call aux1.visite_le;
 232                               call insert(aux1) ;
 233                               aux1.father := aux
 234                          fi;
 235                          aux1 := aux.lista.next
 236                        od;
 237                   fi;
 238                   if arret then
 239                      call comment("This execution has been stopped! Use MENU now.");
 240                      exit exit
 241                  fi;
 242              od (* not empty *);
 243           fi;
 244           (* dla kazdego i inna  skladowa *)
 245            call waittt;
 246            i:= i+1;
 247            if (i>fin and debut<>1) then debut,i:=1; fin:= G.root-1; fi
 248         od
 249       end traverse;
 250
 251       UNIT TRAVERSE_bis :  procedure (G : Graph );
 252       (* przegladanie grafu(ktory ma postac tablicy list) z uzyciem*)
 253       (* nieznanej struktury danych z operacjami: empty,first,insert,delete*)
 254       (* wierzcholek jest usuwany dopiero gdy jego synowie juz zostali obsluzeni*)
 255       var  i,debut,fin : integer,
 256            aux, aux1    : node;
 257       begin
 258         debut:= G.root; fin:= G.nr;
 259         i:= debut;
 260         while i <= fin
 261         do
 262           aux := G.lista(i);
 263           if not aux.visite
 264           then
 265             call aux.visite_le;
 266             call insert(aux);
 267             call aux.wypisz(i);  (* i wyznacza kolor *)
 268             aux.father := none;
 269             while not empty
 270             do
 271                  aux := first; (* to jest pierwszy w str. pomocniczej*)
 272                  if  (aux.lista.courant=none) then
 273                      call delete;
 274                     (* usuwam go ze struktury tylko wtedy, gdy juz *)
 275                     (* odwiedzilam wszystkich jego synow *)
 276                  else
 277                   (* courant powinien pokazywac syna, ktorego mam teraz odwiedzic*)
 278                   aux1 := aux.lista.courant.e;
 279                   while  aux1<>none
 280                   do
 281                        if arret then
 282                          call comment(
 283                          "This execution has been stopped! Use MENU now.");
 284                          return;
 285                        fi;
 286
 287                       if not aux1.visite then
 288                              call aux1.visite_le;
 289                              call insert(aux1) ;
 290                              aux1.father := aux;
 291                              call G.strzalka(aux1.father,aux1,i,c_black);
 292                              call aux1.wypisz(i);
 293                              aux1 := aux.lista.next;
 294                              exit
 295                        fi;
 296                        aux1 := aux.lista.next
 297                   od;
 298
 299                   if arret then
 300                     call comment("This execution has been stopped! Use MENU now.");
 301                     return;
 302                   fi;
 303                fi (* if lista.courant=none *);
 304
 305              od (* not empty *);
 306           fi (* if visite*);
 307           (* dla kazdego i inna  skladowa *)
 308           call waittt;
 309           i:= i+1;
 310           if (i>fin and debut<>1) then debut,i:=1; fin:= G.root-1; fi
 311         od
 312       end traverse_bis;
 313
 314
 315       unit printSTRplace : procedure(s:string);
 316       var j,i,l,r,z,xx,yy,pos : integer,
 317           less, more,boo : boolean;
 318       begin
 319           call GUI_writetext(MinX+10,StrMinY+10,
 320           unpack("CONTENTS OF THE AUXILIARY STRUCTURE - "),c_white,c_lightgrey);
 321           call  GUI_writetext(MaxX-323,StrMinY+10,unpack(s),c_white,c_lightgrey);
 322           call GUI_Rect(MaxX-172,StrMinY+8,MaxX-20,StrMinY+25,c_white,c_black);
 323           call GUI_Rect(MaxX-170,StrMinY+9,MaxX-42,StrMinY+23,c_black,c_black);
 324           call GUI_writetext(MaxX-170,StrMinY+8,unpack("SPEED:"),c_white,c_lightgrey);
 325           call GUI_writetext(MaxX-46,StrMinY+8,unpack(" > "),c_white,c_lightgrey);
 326           call comment("Use the LEFT button to change and RIGHT to accep the speed.");
 327
 328           pos:= MinX+ 500;
 329           speedL := 1;
 330           do
 331                   z:=0;
 332                   while not (z=1 or z=3) do
 333                       call GUI_MousePressed(xx,yy,z) ;
 334                   od;
 335                   (*call sleep(1);*)
 336                   less:= (yy<STrMinY+23 and yy>StrMinY+10 and xx<(MinX+574));
 337                   more:= (yy<STrMinY+23 and yy>StrMinY+10 and xx>(MinX+574));
 338                   (* szukam gdzie zostal nacisniety klawisz myszki *)
 339                   if  ((z=1 and less) and(speedL>1) )  then
 340                       speedL:= speedL-1;
 341                       call GUI_writetext(pos-8,StrMinY+8,unpack(" "),c_black,c_black);
 342                       pos := pos-8
 343                   else
 344                      if ((z=1 and more) and(speedL<10)) then
 345                          speedL:= speedL+1;
 346                          call GUI_writetext(pos,StrMinY+8,unpack(" "),
 347                                                                                                c_darkturq,c_darkturq);
 348                          pos := pos+8
 349                      else
 350                          if z=3 then call comment("");exit fi;
 351                      fi
 352                   fi ;
 353                od;
 354
 355       end printSTRplace;
 356
 357
 358    end structure;
 359 (*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)
 360
 361    unit queue : structure class;
 362    var premier, dernier : box;
 363    var dernierX : integer;
 364
 365       unit virtual first :  function : elem;
 366       begin
 367           if not empty
 368           then
 369               result := premier.e;
 370           fi;
 371       end first;
 372
 373       unit virtual insert :  procedure( e: elem);
 374       var aux : box;
 375       begin
 376           if empty then dernierX:=x0 else dernierX:= dernierX+delta fi;
 377           aux := new box;
 378           aux.e := e;
 379           if premier=none
 380           then
 381               premier := aux;
 382               dernier := aux;
 383           else
 384               dernier.next := aux;
 385               dernier := aux
 386           fi;
 387           (* dorysuj *)
 388           call GUI_ellipse(dernierX,y0,5,5,0,360,c_yellow,c_yellow);
 389           call GUI_writeInt(dernierX,y0+3,e qua node.nr,c_black,c_lightGrey);
 390           (*call speed(speedL);    *)
 391
 392        end insert;
 393
 394        unit virtual delete :  procedure;
 395        var aux : box;
 396        var pomX : integer;
 397        begin
 398             if not empty
 399             then
 400                 call GUI_ellipse(x0,y0,5,5,0,360,c_LightGrey,c_LightGrey);
 401                 call GUI_writeInt(x0,y0+3,15,c_LightGrey,c_LightGrey);
 402                            (*wymazanie pierwszego*)
 403                 call sleep(1);
 404                 aux := premier;
 405                 pomX := x0;
 406                 while  aux.next<>none
 407                 do
 408                     call GUI_ellipse(pomX+delta,y0,5,5,0,360,c_LightGrey,c_LightGrey);
 409                     call GUI_writeInt(pomX+delta,y0+3,15,c_LightGrey,c_LightGrey); (*wymazanie*)
 410                     call GUI_ellipse(pomX,y0,5,5,0,360,c_yellow,c_yellow);
 411                     call GUI_writeInt(pomX,y0+3,aux.next.e qua node.nr,c_black,c_lightgrey);
 412                     (* zmiana numerkow= przesuniecie w kolejce*)
 413                     aux := aux.next;
 414                     pomX := pomX + delta;
 415                     call sleep(2)
 416                 od;
 417                 premier := premier.next;
 418                 if premier= none then dernier:= none fi;
 419
 420                 call GUI_ellipse(dernierX,y0,5,5,0,360,c_LightGrey,c_LightGrey);
 421                 call GUI_writeInt(dernierX,y0+3,15,c_LightGrey,c_Lightgrey);
 422                 if dernierX> x0 then dernierX := dernierX - delta fi;
 423             fi;
 424         end delete;
 425
 426         unit virtual empty :  function : boolean;
 427         begin
 428              result := (premier=none)
 429         end empty;
 430
 431     end queue;
 432   (*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)
 433
 434     unit stack : Structure class;
 435     var premier : box;
 436     var topX : integer;
 437
 438       unit virtual first :  function : elem;
 439       begin
 440           if not empty
 441           then
 442               result := premier.e;
 443           fi;
 444       end first;
 445
 446       unit virtual insert : procedure( e: elem);
 447       var aux : box;
 448       begin
 449           if empty then topX := x0 else topX := topX+delta fi;
 450           aux := new box;
 451           aux.e := e;
 452           aux.next := premier;
 453           premier := aux;
 454           (*dorysuj*)
 455           call GUI_ellipse(topX,y0,5,5,0,360,c_yellow,c_yellow);
 456           call GUI_writeInt(topX,y0+3,e qua node.nr,c_black,c_lightgrey);
 457          (* call speed(speedL);   *)
 458        end insert;
 459
 460        unit virtual delete :  procedure;
 461        var j : integer;
 462        begin
 463             if not empty
 464             then
 465                 premier := premier.next;
 466                 call GUI_ellipse(topX,y0,5,5,0,360,c_LightGrey,c_LightGrey);
 467                 call GUI_writeInt(topX,y0+3,15,c_LightGrey,c_LightGrey);
 468                 if topX> x0 then topX := topX - delta fi;
 469             fi;
 470        end delete;
 471
 472        unit virtual empty : function : boolean;
 473        begin
 474              result := (premier=none)
 475        end empty;
 476
 477
 478     end stack;
 479
 480 (*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)
 481     unit PILE_FILE : Structure class;
 482     var premier, dernier,aux,aux1 : box;
 483     var topX,dernierX : integer;
 484
 485     (* struktura, w ktorej delete i insert maja wlasnosci stosu*)
 486     (* ale first dziala tak jak w kolejce *)
 487
 488       unit virtual first :  function : elem;
 489       begin  call comment("first");
 490           if not empty
 491           then
 492               result := premier.e;
 493           fi;
 494       end first;
 495
 496       unit virtual insert :  procedure( e: elem);
 497       var aux : box;
 498       begin  call comment("insert");
 499           if empty then topX,dernierX:=x0 else dernierX:= dernierX+delta fi;
 500           aux := new box;
 501           aux.e := e;
 502           if premier=none
 503           then
 504               premier, dernier := aux;
 505           else
 506               dernier.next := aux;
 507               dernier := aux
 508           fi;
 509           (* dorysuj *)
 510           call GUI_Ellipse(dernierX,y0,5,5,0,360,c_yellow,c_yellow);
 511           call GUI_writeInt(dernierX,y0,e qua node.nr,c_lightgrey,c_black);
 512         (*  call speed(speedL);    *)
 513        end insert;
 514
 515        unit virtual delete :  procedure;
 516        var aux, aux1: box;
 517        begin
 518             if not empty
 519             then   call comment("delete");
 520                 aux := premier;
 521                 if premier.next=none then dernier,premier:=none
 522                 else
 523                   aux1:= none;  aux := premier;
 524                   while aux.next<>none do aux1:=aux; aux :=  aux.next od;
 525                   dernier := aux1; dernier.next:= none
 526                 fi;
 527                 call GUI_ellipse(dernierX,y0,5,5,0,360,c_darkgrey,c_darkgrey);
 528                 call GUI_writeInt(dernierX,y0,15,c_darkgrey,c_darkgrey);
 529                 if dernierX> x0 then dernierX := dernierX - delta fi;
 530             fi;
 531        end delete;
 532
 533        unit virtual empty : function : boolean;
 534        begin
 535              result := (premier=none)
 536        end empty;
 537
 538     end PILE_FILE;
 539
 540
 541     UNIT PI_FI : PILE_FILE procedure(G:GRAPH);
 542       begin
 543           call printSTRplace(" QUEUE ");
 544           call comment("PILE_FILE  SEARCH");
 545           call traverse_bis(G);
 546       end PI_FI;
 547
 548
 549  (*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)
 550
 551     unit STRANGE : Structure class;
 552     var premier : box, extra: box;
 553     var topX : integer;
 554
 555       unit virtual first :  function : elem;
 556       begin
 557           if not emptyN
 558           then
 559               result := premier.e;
 560           else
 561               result := extra.e
 562           fi;
 563       end first;
 564
 565       unit virtual insert : procedure( e : elem);
 566       var aux : box;
 567       begin
 568           if empty then topX := x0 else topX := topX+delta fi;
 569           if emptyN  then extra := new box; extra.e := e fi;
 570           aux := new box;
 571           aux.e := e;
 572           aux.next := premier;
 573           premier := aux;
 574           call GUI_ellipse(topX,y0,5,5,0,360,c_yellow,c_yellow);
 575           call track(topX,y0,e qua node.nr,c_lightgrey,c_black);
 576         (*  call speed(speedL);  *)
 577        end insert;
 578
 579        unit virtual delete :  procedure;
 580        begin
 581             if not emptyN
 582             then
 583                 premier := premier.next;
 584                 call GUI_ellipse(topX,y0,5,5,0,360,c_darkgrey,c_darkgrey);
 585                 call track(topX,y0,15,c_darkgrey,c_darkgrey);
 586                 if topX> x0 then topX := topX - delta fi;
 587             fi;
 588        end delete;
 589
 590        unit  emptyN : function : boolean;
 591        begin
 592              result := (premier=none)
 593        end emptyN;
 594
 595        unit virtual empty : function : boolean;
 596        begin
 597              result := false
 598        end empty;
 599
 600     end STRANGE;
 601
 602  (*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)
 603  (* ALGORITHMS                                                          *)
 604  (*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)
 605
 606
 607       UNIT DFS : STACK procedure(G: GRAPH);
 608       begin
 609           call printSTRplace(" STACK ");
 610           call comment("DEPTH FIRST SEARCH");
 611           call traverse(G);
 612       end DFS;
 613
 614       UNIT DFS_bis : STACK procedure(G: GRAPH);
 615       begin
 616           call printSTRplace(" STACK ");
 617           call comment("DEPTH FIRST SEARCH");
 618           call traverse_bis(G);
 619       end DFS_bis;
 620
 621
 622       UNIT BFS : QUEUE procedure(G:GRAPH);
 623       begin
 624           call printSTRplace(" QUEUE ");
 625           call comment("BREADTH FIRST SEARCH");
 626           call traverse(G);
 627       end BFS;
 628
 629       UNIT BFS_bis : QUEUE procedure(G:GRAPH);
 630       begin
 631           call printSTRplace(" QUEUE ");
 632           call comment("BREADTH FIRST SEARCH");
 633           call traverse_bis(G);
 634       end BFS_bis;
 635
 636
 637       UNIT WHAT : STRANGE procedure (G: GRAPH);
 638       begin
 639           call printSTRplace(" STACK?? ");
 640           call comment("STRANGE SEARCH");
 641           call traverse(G);
 642       end WHAT;
 643
 644       unit look_all:  class(G: GRAPH);
 645       var  i,debut,fin : integer,
 646            aux   : node;
 647       begin
 648         debut:= G.root; fin:= G.nr;
 649         i:= debut;
 650         while i <= fin
 651         do
 652             aux := G.lista(i);
 653             inner;
 654             call waittt;
 655             i:= i+1;
 656             if (i>fin and debut<>1) then debut,i:=1; fin:= G.root-1; fi
 657         od;
 658       end look_all;
 659
 660       unit traverse_rec : look_all procedure;
 661            unit  DFS : procedure (aux: node,i:integer);
 662            var aux1:node;
 663            begin
 664                if not aux.visite
 665                then
 666                    call aux.visite_le;
 667                    if aux.father<>none then
 668                       call G.strzalka(aux.father,aux,(i+9)mod 16,c_black)
 669                    fi;
 670                    call aux.wypisz((i+9)mod 16);(* i wyznacza kolor *)
 671
 672                     aux1 := aux.lista.first;
 673                    while aux1<>none
 674                    do
 675                           aux1.father:= aux;
 676                           call DFS(aux1,i);
 677                           aux1:= aux.lista.next
 678                    od;
 679
 680                fi;
 681            end DFS;
 682       begin
 683          call DFS(aux,i);
 684       end traverse_rec;
 685
 686
 687
 688       unit cycle_fond :  procedure(G:GRAPH);
 689       var STOS    : arrayof integer,
 690           ii,iii  : integer,
 691           pile    : stack;
 692           (* stos przechowuje tylko numery wierzcholkow ze stosu*)
 693           (* pile przechowuje wierzcholki  zeby pokazac zawartosc stosu *)
 694
 695           unit CF : look_all procedure;
 696           var aux1 : node,
 697                 x, j    : integer;
 698           begin
 699                if (not aux.visite and not aux.use)
 700                then
 701                   ii := ii+1;
 702                   stos(ii) := aux.nr;
 703                   call aux.visite_le;
 704                   call pile.insert(aux);
 705                   while not pile.empty
 706                   do
 707                       if arret then
 708                         call warning("This execution has been stopped! Use MENU now.");
 709                         return;
 710                       fi;
 711
 712                      aux := pile.first;
 713                      if aux.father<>none then
 714                         call G.strzalka(aux.father,aux,11,c_black);
 715                      fi;
 716                      for j := 1 to 160 do call aux.affichage(11) od;
 717                      call aux.affichage(11);
 718
 719                      (* staram sie dopisac cos do stosu *)
 720                      if aux.lista.courant<>none then
 721                          aux1 := aux.lista.courant.e;
 722                          while aux1<>none
 723                          do
 724                             if not aux1.visite and not aux1.use then
 725                                aux1.father:= aux;
 726                                ii := ii+1;
 727                                stos(ii) := aux1.nr;
 728                                call aux1.visite_le;
 729                                call pile.insert(aux1);
 730                                exit
 731                             else
 732                                if ( not aux1.use and ii>1) then(* cykl ?  *)
 733                                   if aux1.nr<>STOS(ii-1) then
 734                                      iii := ii;
 735                                      call GUI_writeText(piszX+delta,piszY,
 736                                                                                            unpack("("),c_blue,c_lightgrey);
 737                                      delta := delta + 8;
 738                                      while iii>0
 739                                      do
 740                                           x := STOS(iii);
 741                                           call G.lista(x).wypisz(c_blue);
 742                                           if x=aux1.nr  then exit fi;
 743                                           iii := iii-1;
 744                                      od;
 745                                      call GUI_writeText(piszX+delta,piszY,
 746                                                                                            unpack(")"),c_blue,c_lightgrey);
 747                                      delta := delta+8;
 748
 749                                      call waittt;
 750                                   fi
 751                                fi(* not aux.use *);
 752                                (* trzeba przejsc do nastepnego wierzch *)
 753                                aux1 := aux.lista.next
 754                            fi
 755
 756                          od (*  while aux1<>none *);
 757                       fi (* if courant<>none *);
 758
 759                       if aux.lista.courant=none then
 760                           aux.kolor := c_lightgrey; (* element zuzyty*)
 761                           if ii>0 then ii:= ii-1 fi;(* usuwam ze stosu*)
 762                           call pile.delete
 763                       fi;
 764                    od(* while not empty pile *)
 765                fi;
 766          end CF;
 767
 768       begin
 769            array STOS dim(1:G.nr);
 770            pile := new stack;
 771            call G.restore;    (* odnowic structure grafu *)
 772            call pile.printSTRplace(" STACK ");
 773            ii:=0; (* ilosc elementow w stosie-tablicy*)
 774            call CF(G);
 775       end cycle_fond;
 776
 777
 778       unit xxxxx: procedure (G:GRAPH);
 779       var stos : stack;
 780
 781       unit trie_topologique : look_all procedure;
 782            unit  DFS : procedure (aux: node,i:integer);
 783            var aux1 : node;
 784            begin
 785                if not aux.visite
 786                then
 787                    call aux.visite_le;
 788                    if aux.father<>none then
 789                       call G.strzalka(aux.father,aux,i mod 7 ,c_black)
 790                    fi;
 791                    call aux.wypisz(i mod 7);(* i wyznacza kolor *)
 792
 793                    aux1 := aux.lista.first;
 794                    while aux1<>none
 795                    do
 796                           aux1.father:= aux;
 797                           call DFS(aux1,i);
 798                           aux1:= aux.lista.next
 799                    od;
 800                    call stos.insert(aux);
 801                fi;
 802            end DFS;
 803       begin
 804            call DFS(aux,i);
 805       end trie_topologique;
 806       begin
 807          call G.restore;
 808          stos := new stack;
 809          call stos.printSTRplace(" STACK");
 810          call trie_topologique(G);
 811          call GUI_Rect(piszX,piszY,maxX-5,piszY+13,c_lightGrey,c_lightGrey);
 812
 813          delta:= 0;
 814          while not stos.empty
 815          do
 816             call stos.first qua node.wypisz(5);
 817             call stos.delete;
 818          od;
 819       end xxxxx;
 820
 821 (*++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)
 822       UNIT EULER :  procedure(G:GRAPH);
 823       var aux,aux1,aux2 : node,
 824           booooo   : boolean,
 825           pile     : stack;
 826       begin
 827             pile := new stack;
 828             call G.restore;
 829             call pile.printSTRplace(" STACK ");
 830             aux := G.lista(G.root);
 831             call pile.insert(aux);
 832             while not pile.empty
 833             do
 834                   aux := pile.first; (* to jest pierwszy w str. pomocniczej*)
 835
 836                   booooo := false;
 837                   call aux.lista.debut;
 838                   aux1 := aux.lista.first;
 839                   (* courant jest teraz na poczatku listy*)
 840                   while  (not booooo  and  aux1<>none)
 841                   do
 842                       if not aux.lista.courant.used then
 843                       (* jezeli krawedz do courant nie byla jeszcze uzyta*)
 844                              call aux.lista.courant.use;
 845                              call pile.insert(aux1);
 846                              call G.strzalka(aux,aux1,12,c_black);
 847                              (* w liscie incydencji aux1 tez trzeba zmienic*)
 848                              call aux1.lista.debut;
 849                              aux2 := aux1.lista.first;
 850                              while  aux2<>none
 851                              do
 852                                  if (*aux.egal(aux2)*) aux.nr=aux2.nr then
 853                                       call aux1.lista.courant.use;
 854                                       exit
 855                                  else
 856                                      aux2 := aux1.lista.next
 857                                  fi;
 858                              od;
 859                              booooo := true;
 860                        else
 861                            aux1 := aux.lista.next
 862                        fi;
 863                   od;
 864                   if not booooo then
 865                      call pile.delete;
 866                      call aux.wypisz(12);
 867                   fi;
 868                   if arret then
 869                     call comment("This execution has been stopped! Use MENU now.");
 870                     return;
 871                   fi;
 872              od (* not empty *);
 873       end EULER;
 874
 875       UNIT HAMILTON :  procedure(G:GRAPH);
 876       begin
 877
 878       end HAMILTON;
 879
 880 (*++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)
 881
 882       UNIT GRAPH : class;
 883       var lista   : arrayof node,
 884           directed  : boolean,
 885           root,nr : integer,
 886           obraz   : arrayof integer ;
 887
 888            unit createNODE : procedure;
 889            var    lista1 : arrayof node,
 890                   fin, boo  : boolean,
 891                   i,l,r,z,x,y : integer,
 892                             w : node;
 893            begin
 894                   z := 0;
 895
 896                   while not (z=3 ) do
 897                       call GUI_mousePressed(x,y,z);
 898                   od;
 899                   if z=3 then
 900                            nr := nr+1;
 901                            w := new node(x,y,nr);
 902                            call w.affichage(14);
 903                            if nr <= upper(lista) then
 904                                 lista(nr) := w
 905                            else
 906                                 array lista1 dim (1: upper(lista)+10);
 907                                 for i := 1 to upper(lista)
 908                                 do lista1(i) := lista(i) od;
 909                                 lista := lista1;
 910                                 lista(nr) := w
 911                            fi
 912                   fi
 913            end createNODE;
 914
 915            unit change_root : procedure;
 916            var x, y,i,l,r,z : integer;
 917            begin
 918                 call warning("You can change the starting point which is now: ");
 919                 call GUI_writeInt(maxX-200,wrnY,root,
 920                                                      c_lightGrey,c_black);
 921                 call GUI_writetext(maxX-100,wrnY,
 922                                     unpack(" change "),c_lightGrey,c_turq);
 923                 call GUI_writetext(maxX-100,wrnY+16,
 924                                     unpack(" accept "),c_lightGrey,c_turq);
 925                 while true do
 926                    z := 0;
 927                    call GUI_MousePressed(x,y,z) ;
 928                    call sleep(2);
 929                    if (z=1) then
 930                      if (y>wrnY and y<wrnY+10) then
 931                         root := (root mod nr)+1;
 932                         call GUI_writetext(maxX-205,wrnY,
 933                            unpack("    "),c_lightGrey,c_lightGrey);
 934                         call GUI_writeInt(maxX-200,wrnY,
 935                                                    root,c_lightGrey,c_black);
 936                      fi;
 937                      if (y>wrnY+15 and y<wrnY+30) then exit fi;
 938                    fi;
 939                 od;
 940                 call GUI_writetext(maxX-100,wrnY,
 941                                        unpack("        "),c_darkGrey,c_darkGrey);
 942                 call GUI_writetext(maxX-100,wrnY+16,
 943                                         unpack("        "),c_darkGrey,c_darkGrey);
 944
 945                 call comment("");
 946                 call warning("")
 947            end change_root;
 948
 949            unit createARC : WEZ_DWA PROCEDURE;
 950            BEGIN
 951                (* do listy "w" dopisuje "w1"*)
 952                 call w.lista.insert(w1);
 953                 if not directed then call w1.lista.insert(w) fi;
 954            end createARC ;
 955
 956
 957            unit DeleteARC : wez_dwa procedure;
 958            begin
 959               (*zaznacz luk pokazujac dwa wierzcholki nim polaczone*)
 960               (* wez z listy wierzcholkow poczatek luku "w"*)
 961               (* i z jego listy incydencji usun drugi koniec luku "w1" *)
 962               call w.lista.delete(w1);
 963               if not directed then call w1.lista.delete(w) fi;
 964            end DeleteARC;
 965
 966
 967            UNIT WEZ_DWA : class(cc:char);
 968            var w, w1, aux        : node,
 969                i,l,r,z,xx,yy     : integer,
 970                boo, found, rysuj : boolean;
 971            begin
 972                if nr>0 then
 973                (*  czekam na nacisniecie prawego klawisza myszy w wierzcholku*)
 974                    call warning("I am waiting for the right-button of the mouse.");
 975                    z := 0;
 976
 977                    while not z=3 do
 978                         call GUI_MousePressed(xx,yy,z);
 979                    od;
 980
 981                    w := szukaj(xx,yy,true);
 982                    if w<> none then
 983
 984                      (* prawy klawisz  w jakims wierz.= koniec krawedzi *)
 985                       call warning("To draw/remove use LEFT-B; Press RIGHT-B  to mark the end of an arc.");
 986                       z := 0;
 987                       while not z=3
 988                       do   (*jesli chcesz sam rysowac/wymazac to naciskaj lewy klawisz myszy*)
 989                            if z=1 then
 990                               rysuj := true;
 991                               case cc
 992                               when 'd' : call GUI_ellipse(xx,yy,3,3,0,360,c_lightGrey,c_lightGrey);
 993                               when 'i' :
 994                                          call GUI_point(xx,yy,c_red);
 995                               esac;
 996                            fi;
 997                            call GUI_MousePressed(xx,yy,z);
 998                       od;
 999                       call warning("");
1000                       (* szukam odpowiadajacego wierzcholka w1 *)
1001                       w1 := SZUKAJ(xx,yy,true);
1002                       if w1<> none then
1003
1004                                (* MOZNA dopisac/dorysowac lub usunac/wymazac*)
1005                                inner;
1006
1007                                if not rysuj then
1008                                  case cc
1009                                  when 'd' : call strzalka(w,w1,c_lightgrey,c_lightGrey);
1010                                  when 'i' : call strzalka(w,w1,c_Yellow,c_black);
1011                                  esac;
1012                                fi;
1013                        else
1014         call warning("I can not find the end of this arc, repeat the last action! ")
1015                           fi;
1016                     else call warning("Not found, repeat please!")fi (* w<>none *);
1017                fi (* sa juz jakies wierzcholki *);
1018            end WEZ_dwa;
1019
1020            UNIT SZUKAJ : function(xx,yy : integer,b : boolean) : node;
1021            var aux : node,i,j : integer;
1022            begin
1023                 for i := 1 to nr
1024                 do
1025                       aux := lista(i);
1026                       if b then
1027                       for j:=1 to 50 do call aux.affichage(5) od;
1028                       call aux.affichage(14);
1029                       fi;
1030                       (* szukam odpowiadajacego wierzcholka w*)
1031                       if (abs(aux.x- xx)<7  and abs(aux.y-yy)<7)
1032                       then
1033                                  result := aux; exit
1034                       fi;
1035                 od;
1036            end SZUKAJ;
1037
1038
1039            unit SAVE : procedure;
1040            var U,GL : arrayof integer, W : arrayof arrayof integer,
1041                 nn,i,j : integer,
1042                 sciezka : arrayof char,
1043                 aux, aux1 : node;
1044            begin
1045
1046                 (*call warning("Give the name of your file or press CR to accept this");*)
1047                 sciezka :=   unpack("/usr/local/vlp/examp/graf.dta");
1048                 call warning("");
1049
1050                 open(G_file,direct,sciezka);
1051                 call rewrite(G_file);
1052                 call seek(G_file,0,2);
1053                 nn := 2* intSize;
1054                 array U dim (1:2);
1055                 U(1) := nr; if directed then U(2):=1 else U(2):=0 fi;
1056                 putrec (G_file,U,nn);
1057                 array GL dim (1:nr);
1058                 array W dim (1:nr);
1059                 for i := 1 to nr do array W(i) dim (1:nr) od;
1060                 (* dla kazdego wierzcholka z listy zidentyfikuj jego sasiadow*)
1061                 for i := 1 to nr
1062                 do
1063                     aux := lista(i);
1064                     call aux.lista.debut;
1065                     aux1 := aux.lista.first;
1066                     j := 0; (* j= liczbie wierzcholkow incydentnych dla aux *)
1067                     while aux1<> none
1068                     do
1069                       j := j+1;
1070                       W(i,j) := aux1.x*1000*100 + aux1.y*100 ;
1071                       aux1 := aux.lista.next
1072                     od;
1073                     GL(i) := aux.x*1000*100 + aux.y*100 + j;
1074                   od;
1075                   nn := nr * intSize;
1076                   putrec (G_file,GL,nn);
1077                   for i := 1 to nr
1078                   do
1079                          nn := (GL(i) mod 100) * intSize ;
1080                          if GL(i) >0 then putrec(G_file,W(i),nn)fi;
1081                   od;
1082                 kill(G_file);
1083
1084
1085            end SAVE;
1086
1087            unit TAKE : procedure;
1088            (* odczytaj graf z pliku *)
1089            var  U,W,SASIEDZI : arrayof integer,
1090                 x,y,n,nn,ile,j,i : integer,
1091                 sciezka : arrayof char,
1092                 aux, aux1 : node;
1093
1094                 unit decode : procedure(a: integer; output x,y,ile: integer);
1095                 begin
1096                     ile := a mod 100;
1097                     y := (a div 100) mod 1000;
1098                     x := (a div 100000)
1099                 end decode;
1100            begin
1101
1102            (* call warning("Give the name of your file or press CR to accept");*)
1103                   (* call GUI_Rect(20,338,20,140,c_black,c_lightGrey);*)
1104             (*sciezka := GUI_ReadText(20,338,c_yellow,c_black);*)
1105              (* call GUI_Rect(20,338,20,140,c_LightGrey,c_lightGrey);*)
1106
1107                 call warning("");
1108                 sciezka :=   unpack("/usr/local/vlp/examp/graf.dta");
1109                 open(G_file,direct,sciezka);
1110                 call reset(G_file);
1111                 call seek(G_file,position(G_file),0);
1112                 array U dim(1:2);
1113                 nn := 2* intSize;
1114                 getrec (G_file,U,nn);
1115                 nr := U(1);
1116                 directed := (U(2)=1);
1117                 array W dim (1:nr);
1118                 call seek(G_file,position(G_file),0);
1119
1120                 nn := nr * intSize;
1121                 getrec (G_file,W,nn);
1122                 if upper(lista) < nr then
1123                         array lista dim(1: nr)
1124                 fi;
1125                 array SASIEDZI dim (1:nr);
1126                 for j:= 1 to nr
1127                 do
1128                     (* utworzyc odczytany j-ty wierzcholek *)
1129                     (* i wpisac go na liste *)
1130                     call decode(W(j),x,y,ile);
1131                     aux := new node(x,y,j);
1132                     lista(j) := aux;
1133                     SASIEDZI(j) := ile;
1134                  od;
1135                  (* jezeli  lista sasiadow j-tego wierz.jest>0 *)
1136                  (* odczytac jego sasiadow i wpisac do odp. listy*)
1137                  for j := 1 to nr
1138                  do
1139                       if SASIEDZI(j)<>0 then
1140                             nn := SASIEDZI(j) * intSize;
1141                             call seek(G_file,position(G_file),0);
1142
1143                             getrec(G_file,W,nn);
1144                             for i := 1 to SASIEDZI(j)
1145                             do
1146                                 call decode(W(i),x,y,ile);
1147                                 aux1 := SZUKAJ(x,y,false);
1148                                 call lista(j).lista.insert (aux1);
1149                             od;
1150                         fi;
1151                     od;
1152                 kill(G_FILE);
1153
1154                 if directed then call warning("THIS IS A DIRECTED GRAPH ")
1155                 else
1156                    call warning("THIS IS AN UNDIRECTED GRAPH ")
1157                 fi;
1158            end take;
1159
1160
1161            unit restore : procedure;
1162           (* odnawia stan wierzcholkow  *)
1163            var i : integer;
1164            begin
1165                 delta := 0;
1166                 for i := 1 to nr
1167                 do
1168                     if lista(i).lista<>none
1169                     then call lista(i).lista.restore fi;
1170                     lista(i).kolor := c_yellow;
1171                     lista(i).father := none
1172                 od;
1173            end restore;
1174
1175            UNIT strzalka : procedure(A,B : node, kol1,kol2:integer);
1176            (* grot strzalki jest skierowany w strone B *)
1177            var r : real, cx,cy,dx,dy,ex,ey,delt,del : integer;
1178            BEGIN
1179              del := 15; delt:=7; (* decyduja o wielkosci grota *)
1180
1181              call GUI_line(A.x,A.y,B.x,B.y,kol1);
1182              if directed then
1183                 (* kol2=kolor grota *)
1184                 r := sqrt((b.y-a.y)*(b.y-a.y)+(b.x-a.x)*(b.x-a.x));
1185                 cx := b.x- entier((b.x-a.x)*del/r );
1186                 cy := b.y- entier((b.y-a.y)*del/r );
1187                 dx := b.x- entier((b.x-a.x)*(del+delt)/r + (b.y-a.y)*delt/r);
1188                 dy := b.y- entier((b.y-a.y)*(del+delt)/r - (b.x-a.x)*delt/r);
1189                 ex := b.x- entier((b.x-a.x)*(del+delt)/r - (b.y-a.y)*delt/r);
1190                 ey := b.y- entier((b.y-a.y)*(del+delt)/r + (b.x-a.x)*delt/r);
1191                 call GUI_line(dx,dy,cx,cy,kol2);
1192                 call GUI_line(ex,ey,cx,cy,kol2);
1193              fi;
1194            END strzalka;
1195
1196
1197            unit print : procedure;
1198            var aux, aux1 : node, i : integer;
1199            begin
1200                    for i :=1 to nr
1201                    do
1202                         aux := lista(i);
1203                         call aux.affichage(c_yellow);
1204                         if  aux.lista<>none
1205                         then
1206                             call aux.lista.debut;
1207                             aux1 := aux.lista.first;
1208                             while  aux1 <> none
1209                             do
1210                                 call strzalka(aux,aux1,c_yellow,c_black);
1211                                 aux1 := aux.lista.next;
1212                             od
1213                         fi;
1214                    od;
1215                    call warning("")
1216            end print;
1217
1218            unit directORnot :procedure;
1219            var T: arrayof choix, i,j:integer;
1220            begin
1221                array T dim(1:2);
1222                for i:= 1 to 2 do
1223                    T(i) := new choix
1224                od;
1225                T(1).name:="direct";
1226                T(2).name:="indirect";
1227                j:= choice(100,100,T);
1228                directed:=(j=1)
1229            end directORnot;
1230        begin
1231            array lista dim(1:10);
1232            nr := 0; root:= 1;
1233            (* ustal czy graf zorientowany czy nie*)
1234        end graph;
1235
1236 (*++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)
1237 (*    NODE - wierzcholek grafu                                          *)
1238 (*  x,y pozycja na ekranie, nr  numer wierzcholka                       *)
1239 (*  lista - lista wierzcholkow incydentnych                             *)
1240 (*----------------------------------------------------------------------*)
1241        unit node  : elem class(x,y,nr: integer);
1242        (* (x,y) pozycja wierzcholka na ekranie, nr =jego numer *)
1243        (* dla kazdego nowego wierzcholka w jest w.lista.empty *)
1244        var lista  : liste,
1245            father : node,
1246            kolor  : integer;
1247
1248           unit affichage : procedure(c: integer);
1249           begin
1250             if c= c_lightgrey then
1251                  call GUI_ellipse(x,y,5,5,0,360,c_black,c_darkGrey)
1252             else
1253                  call GUI_ellipse(x,y,5,5,0,360,c,c)
1254             fi;
1255             call GUI_writeInt(x+5,y+5,nr,c_lightGrey,c_black);
1256           end affichage;
1257
1258           unit wypisz : procedure(i: integer);
1259          (*  wypisz kolejnosc odwiedzania wierzcholkow *)
1260          (* parametr i wyznacza nowy kolor wierzcholka*)
1261           var j : integer;
1262           begin
1263              for j := 1 to 160 do call affichage(j mod 16 ) od;
1264              if (i=8 or i=7)then i:=1 fi;
1265              call affichage(i);
1266              call GUI_writeInt(piszX+delta,piszY,nr,i,c_lightGrey);
1267              if nr>9 then
1268                 delta := delta+2*9
1269              else
1270                 delta := delta+9
1271              fi;
1272              call GUI_writetext(piszX+delta,piszY,unpack(","),i,c_lightGrey);
1273              delta:= delta+8;
1274           end wypisz;
1275
1276           unit virtual visite : function : boolean;
1277           (* Czy wierzcholek byl juz odwiedzony  *)
1278           begin
1279                 if kolor=c_black then result := true else result:= false fi;
1280           end visite;
1281
1282           unit virtual use : function : boolean;
1283           (* Czy wierzcholek jest juz zuzyty  *)
1284           begin
1285                 if kolor=c_lightGrey then result := true else result:= false fi;
1286           end use;
1287
1288           unit virtual visite_le : procedure;
1289           (* Wierzcholek odwiedzony dostaje kolor czarny*)
1290           begin
1291                kolor:= c_black
1292           end visite_le;
1293
1294           unit virtual egal : function( e: node) : boolean;
1295           begin
1296               if (x= e.x and y= e.y and nr = e.nr) then
1297                   result := true
1298               else
1299                   result := false
1300               fi;
1301           end egal;
1302        begin
1303            lista := new liste; kolor := c_yellow;
1304        end node;
1305  (*--------------------------------------------------------------------*)
1306
1307
1308        unit clear : procedure(col : integer);
1309        var i,y, sr : integer;
1310        begin
1311             y := MinY+40;   (* omijam menu *)
1312             sr := (minX+maxX) div 2;
1313             for i := 0 to (maxX - minX) div 2
1314             do
1315                 call GUI_line(sr, maxY,sr+i, Y,col);
1316                 call GUI_line(sr, maxY,sr-i, Y,col);
1317
1318             od;
1319             for i := 0 to (maxY - Y)
1320             do
1321                 call GUI_Line( sr, maxY,maxX, Y+i,col);
1322                 call GUI_Line( sr, maxY,minX, Y+i,col);
1323
1324             od;
1325             call GUI_Rect(MinX,Y,MaxX,MaxY,c_black,c_LightGrey);
1326                   call GUI_Rect(MinX,StrMinY,MaxX,StrMaxY,c_black,C_lightGrey);
1327        end clear;
1328
1329
1330     unit clear_all : procedure(col : integer);
1331     begin
1332           call GUI_Rect(MinX,MaxY,MaxX,MaxY,c_black,c_lightGrey);
1333           call GUI_Rect(MinX,StrMinY,MaxX,StrMaxY,c_black,C_lightGrey);
1334     end clear_all;
1335
1336     unit waittt : procedure;
1337     var x,y,i,l,r,z : integer, boo : boolean;
1338     begin
1339         call GUI_writetext(maxX-100,maxY-25,
1340                            unpack("continue"),c_lightGrey,c_red);
1341
1342         while z=0 do call GUI_mousePressed(x,y,z) od;
1343         call GUI_writetext(maxX-100,maxY-25, unpack("        "),c_lightGrey,c_lightgrey);
1344
1345     end waittt;
1346
1347     unit arret : function : boolean;
1348     var x,y,z : integer;
1349     begin
1350         call Gui_writetext(maxX-100,maxY-25,
1351                          unpack("STOP? "),c_lightGrey,c_red);
1352         call GUI_MousePressed(x,y,z) ;
1353         if ( z=3) then
1354            result := true;
1355            call GUI_writetext(maxX-100,maxY-25,
1356                                      unpack("       "),c_lightGrey,c_lightGrey);
1357         else result := false
1358         fi;
1359     end arret;
1360
1361     unit YES : function : boolean;
1362     var x,y : integer, l : char;
1363     begin
1364         l:=GUI_ReadChar(x,y,c_green,c_black);
1365         if (l= 'y' or l='Y') then
1366                 result := true
1367         else
1368                result := false ;
1369                call warning("")
1370         fi;
1371     end YES;
1372
1373     unit speed: procedure(n : integer);
1374     var j : integer;
1375     begin
1376                 n:= entier(10/n);
1377           for j:=1 to n do j:=j od;
1378     end speed;
1379
1380     unit sleep: procedure(n : integer);
1381     var j : integer;
1382     begin
1383           for j:=1 to n do j:=j od;
1384     end sleep;
1385
1386     unit comment : procedure (s : string);
1387     begin
1388         call GUI_Rect(comX,comY+12,MaxX-5,comY,c_lightGrey,c_lightGrey);
1389         call GUI_writetext(comX,comY,unpack(s),c_white,c_lightGrey);
1390     end comment;
1391
1392     unit warning : procedure (s : string);
1393     begin
1394         call GUI_Rect(MinX,StrMinY,MaxX,StrMaxY,c_black,c_lightGrey);
1395         call GUI_writetext(wrnX,wrnY,
1396                                   unpack(s),c_white,c_lightgrey);
1397     end warning;
1398
1399     unit choix : class;
1400     var uwaga : string, name : string,
1401         x,y : integer;
1402     end choix;
1403
1404     unit choice : function(xx,yy : integer, T: arrayof choix) : integer;
1405     var i,j,l,r,z,x,y,n : integer, boo : boolean,
1406         IMAGE : arrayof integer;
1407     begin
1408            n := upper(T);
1409            IMAGE := GUI_getImg(xx,yy,100,15*(n+1));
1410            call GUI_Rect(xx,yy,xx+100,yy+15*(n+1),c_white,c_white);
1411            for i:= 1 to n do
1412                call GUI_writetext(xx+2,yy+i*15,unpack(T(i).name),c_black,c_lightGrey);
1413                T(i).x:= xx+2;
1414                T(i).y:= yy+i*15;
1415            od;
1416
1417            do
1418                 call sleep(2);
1419                 z := 0;
1420                 call GUI_MousePressed(x,y,z) ;
1421
1422                 for j:= 1 to n do
1423                      if  ((x>xx and x< (xx+100)) and
1424                         (y>T(j).y and y<(T(j).y+15)))
1425                      then
1426                                 call GUI_writetext(xx+2,yy+j*15,
1427                                        unpack(T(j).name),c_white,c_black);
1428                         result:=j;      (* j-ta opcja wybrana*)
1429                      else
1430                         call GUI_writetext(xx+2,yy+j*15,
1431                                              unpack(T(j).name),c_black,c_lightgrey)
1432                      fi;
1433
1434                 od;
1435                 if ( z=1) then
1436                            exit ;
1437                 fi;
1438            od;
1439            call GUI_putImg(xx,yy,IMAGE)
1440      end choice;
1441
1442
1443 (*++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)
1444 (*                      M E N U                                       *)
1445 (*--------------------------------------------------------------------*)
1446
1447
1448         unit ramki_menu : procedure;
1449         begin
1450              call GUI_Rect(MinX,MinY,MaxX,MaxY,c_black,c_lightgrey);
1451              call GUI_Rect(MinX,StrMinY,MaxX,StrMaxY,c_black,C_lightGrey);
1452         end ramki_menu;
1453
1454         unit option : class(nb : integer);
1455         var Nom : arrayof string;
1456         unit virtual action : procedure(j : integer);
1457         begin
1458         end action;
1459         begin
1460            array Nom dim (1:nb);
1461            inner;
1462         end option;
1463
1464         unit ikona : class(c:integer,p,q: punkt,ss:string);
1465         var sub_menu : menu;
1466             unit write_i : procedure;
1467             begin
1468                call GUI_Rect(p.x,p.y,q.x,q.y,c_white,c_lightGrey);
1469                call GUI_writetext(p.x,p.y,unpack(ss),c_white,c);
1470             end write_i;
1471         end ikona;
1472
1473
1474         unit menu : coroutine(Nom:string,
1475                               minX,maxX,MinY,MaxY:integer,OPTIONS:option);
1476         var ICONES: arrayof IKONA,
1477             j,i,nb,dl,sz,l,r,w,z,xx,yy : integer,
1478             boo : boolean, p,q : punkt;
1479             (* dl and sz  - wymiary ikon w tym menu *)
1480
1481             unit instalation : procedure;
1482             var i : integer;
1483             begin
1484                 call GUI_Rect(MinX+1,7,MaxX-4,45,c_blue,c_lightGrey);
1485                 for i := 0 to nb
1486                 do
1487                     call ICONES(i).write_i
1488                 od;
1489             end instalation;
1490
1491 handlers
1492    others         call warning(" ERROR press Y to continue or N to stop?");
1493
1494                   boo := YES;
1495                   if not boo then call GROFF; call ENDRUN fi;
1496                   call warning("");
1497                   wind;
1498
1499 end handlers;
1500
1501         begin
1502            nb := OPTIONS.nb;
1503            dl := (MaxX-Minx) div nb; sz := 18;
1504
1505            array ICONES dim(0:nb);
1506            p:= new punkt(MinX+2,MinY+2);
1507            q := new punkt(MaxX-2,MinY +sz);
1508            ICONES(0) := new ikona(1,p,q,NOM);
1509            for i := 1 to nb
1510            do
1511               p := new punkt(MinX+2 +(i-1)*dl,minY+sz+2) ;
1512               q := new punkt(p.x+dl-2,p.y+sz);
1513               ICONES(i) := new ikona(c_lightGrey,p,q,OPTIONS.NOM(i));
1514            od;
1515            call ramki_menu;
1516            return;
1517
1518            do  (* obsluga menu *)
1519
1520                call instalation;    (* rysowanie ikon z tego menu *)
1521                do
1522                   z:=0;
1523                   while not z=1 do
1524                       call GUI_MousePressed(xx,yy,z) ;
1525                   od;
1526                   call sleep(2); (*nie umiem powstrzymac myszy*)
1527                   boo := false;
1528                   (*szukam gdzie zostal nacisniety klawisz myszki*)
1529                   for j :=1 to nb
1530                   do
1531                       if( ICONES(j).p.x<xx and xx<ICONES(j).q.x
1532                          and ICONES(j).p.y<yy  and yy<ICONES(j).q.y)
1533                       then
1534                          boo := true; exit;
1535                        fi;
1536                   od;
1537                   if boo then
1538                        boo := false;
1539                        call OPTIONS.Action(j);
1540                        if j=1 then detach; exit fi;
1541                        if ICONES(j).sub_menu<>none then
1542                              attach(ICONES(j).sub_menu);
1543                              exit;
1544                        fi;
1545
1546                   fi;
1547                od;
1548            od;
1549         end menu;
1550
1551 (*------------------------------------------------------------------------*)
1552 (*                  MOJE MENU                                             *)
1553 (*  menu  jest korutina                                                   *)
1554 (*  ma swoje opcje, z ktorych kazda moze miec swoje pod-menu              *)
1555 (*  kazda opcja odpowiada jakiejs akcji, po wykonaniu ktorej              *)
1556 (*  zostaje uaktywnione pod-menu, o ile istnieje                          *)
1557 (*------------------------------------------------------------------------*)
1558
1559
1560
1561
1562      unit OPTIONS_MAIN : option class;
1563      unit virtual Action : procedure(j : integer);
1564      var ss : string;
1565      begin
1566
1567          case j
1568             when 1 : ss :="";
1569             when 2 : ss := "Create a new graph or take from a file or memory";
1570
1571             when 3 : call warning(
1572                  "To STOP the execution of an algorithme press BUTTON RIGHT!");
1573                   call waittt; ss :="";
1574             when 4 : ss :="usr/local/examp/graf.txt";
1575                      open(help_file,text,unpack(ss));
1576                      call reset(help_file);
1577           esac;
1578           call warning(ss);
1579       end;
1580       begin
1581            Nom(1) := "exit";
1582            Nom(2) := "graph";
1583            Nom(3) := "algorithms";
1584            Nom(4) := "help";
1585       end OPTIONS_MAIN;
1586
1587      unit OPTIONS_GRAPH : option class;
1588      unit virtual Action : procedure(j : integer);
1589      var ss : string;
1590      begin
1591
1592          case j
1593             when 1 : call warning(""); call comment("");
1594             when 2 : call clear_all(c_lightGrey);
1595             when 3 : call warning("Import a graph from the file or from the memory ");
1596             when 4 : call warning("Modify the existing graph ");
1597             when 5 :
1598                      if GRAF<>none then
1599                             call warning("Saving the recently defined graph.");
1600                             call GRAF.save
1601                      else
1602                             call warning("GRAPH IS EMPTY");
1603                             call waittt;
1604                      fi;
1605
1606             when 6 : call warning("Create a new graph");
1607                      GRAF := new graph;
1608                      call GRAF.directORnot;
1609                      call clear(c_red);
1610
1611           esac;
1612       end;
1613       begin
1614            Nom(1) := "return";
1615            Nom(2) := "clear";
1616            Nom(3) := "import";
1617            Nom(4) := "modify";
1618            Nom(5) := "save";
1619            Nom(6) := "create";
1620       end OPTIONS_GRAPH;
1621
1622       unit OPTIONS_ALGO : option class;
1623       unit virtual Action : procedure(j : integer);
1624       var i : integer, ch : char;
1625       begin
1626            (* miejsce komentarzy *)
1627           case j
1628             when 1 :  call comment("");  call warning("");
1629             when 2 :  call comment(
1630             "To STOP the execution of an algorithme press RIGHT BUTTON");
1631                      call waittt; call comment("");
1632                      if Graf<>none then
1633                         if GRAF.obraz<> none then
1634                            call GUI_PutImg(MinX+2, MinY+40,Graf.obraz)
1635                         else call GRAF.print fi;
1636                         (* wybor wierzcholka od ktorego zacznamy chodzenie*)
1637                         call GRAF.change_root;
1638                      fi;
1639
1640             when 3 :  call WARNING( "");
1641             when 4 :  call comment( "Depth First Search recursive  ");
1642                       if graf<> NONE THEN
1643                         call GRAF.restore;
1644                         call traverse_rec(GRAF);
1645                       fi;
1646             when 5 :  call comment( "TOPOLOGICAL Sort ");
1647                       call warning("This algorithm require a graph without cycl!");
1648                       call waittt;
1649                       call warning("");
1650                       if graf<> NONE THEN
1651                         call xxxxx(GRAF);
1652                       fi;
1653           esac;
1654
1655       end Action;
1656       begin
1657            NOM(1) :=  "return";
1658            NOM(2) :=  "search";
1659            NOM(3) :=  "cycls";
1660            NOM(4) :=  "recur";
1661            NOM(5) :=  "top_sort";
1662       end OPTIONS_ALGO;
1663
1664
1665       unit OPTIONS_cycl : option class;
1666       unit virtual Action : procedure(j : integer);
1667       var i : integer;
1668       begin
1669           case j
1670             when 1 :  call comment("");  call warning("");
1671
1672             when 2 :
1673                       if graf<> NONE THEN
1674                           call cycle_fond(GRAF);
1675                       fi;
1676                       call warning("ALL the fundamental cycls of the graph");
1677             when 3 :
1678                       call warning("");
1679                       if graf<> NONE THEN
1680                            call EULER(GRAF);
1681                       fi;
1682             when 4 :
1683                      call warning("Find a Hamilton's cycl");
1684                      if graf<> NONE THEN
1685                            call HAMILTON(GRAF);
1686                      fi;
1687
1688             when 5 :
1689                    call warning("");
1690                    call GUI_Rect(MinX,MinY+40,MaxX,MaxY,c_lightGrey,c_LightGrey);
1691                    if GRAF<>none  then call GRAF.print fi;
1692           esac;
1693
1694       end Action;
1695       begin
1696            NOM(1) :=  "return";
1697            NOM(2) := "fundamental";
1698            NOM(3) := "Euler";
1699            NOM(4) := "Hamilton";
1700            NOM(5) := "restore "
1701       end OPTIONS_cycl;
1702
1703
1704
1705       unit OPTIONS_help : option class;
1706       var page_nb : integer;
1707       unit virtual Action : procedure(j : integer);
1708       var i ,x,y: integer, ch : char;
1709       begin
1710           case j
1711             when 1 : (* przy powrocie odnawiam ramki dla menu*)
1712                       call ramki_menu;
1713             when 2 :  call GUI_Rect(MinX,MinY+40,MaxX,MaxY,c_black,c_black);
1714                       call warning("");
1715                       page_nb := page_nb + 1;
1716
1717                       for i := 1 to 19
1718                 (* drukuje tylko 19 linijek bo ekran jest maly*)
1719                       do      x:=MinX+5; y:=MinY+40+13*i;
1720                          call  GUI_move(x, y);
1721                          while not eof(help_file)
1722                          do
1723                             read(help_file,ch);
1724                             if ord(ch)=10 then exit else
1725                                    call GUI_writeChar(x,y,ch,c_white,c_black);
1726                                                      x:= x+ 10;
1727                                               fi
1728                          od
1729                       od;
1730                       if eof(help_file) then call warning("END OF FILE") fi;
1731
1732             when 3 :  page_nb := page_nb - 1;
1733                       (* zresetowac i przewinac o nb stron; strona=19linijek*)
1734                       call reset(help_file);
1735                       call GUI_Rect(MinX,MinY+40,MaxX,MaxY,c_black,c_black);
1736                       for i := 1 to 19* page_nb
1737                       do
1738                          while not eof(help_file)
1739                          do
1740                             read(help_file,ch);
1741                             if ord(ch)=10 then exit fi;
1742                          od
1743                       od;
1744
1745                       for i := 1 to 19
1746                 (* drukuje tylko 19 linijek bo ekran jest maly*)
1747                       do
1748                          call  GUI_move(MinX+5, MinY+40+13*i);
1749                          while not eof(help_file)
1750                          do
1751                             read(help_file,ch);
1752                             if ord(ch)=10 then exit else call HASCII(ord(ch)) fi;
1753                          od
1754                       od;
1755
1756             when 4 :
1757                      call GUI_Rect(MinX,MinY+40,MaxX,MaxY,c_lightGrey,c_lightGrey);
1758                      call reset(help_file);
1759                      call warning("");
1760                      page_nb:= 0;
1761           esac;
1762
1763       end Action;
1764       begin
1765            page_nb := 0;
1766            NOM(1) :=  "return";
1767            NOM(2) := "next";
1768            NOM(3) := "prev";
1769            NOM(4) := "reset";
1770       end OPTIONS_help;
1771
1772       unit OPTIONS_import : option class;
1773       unit virtual Action : procedure(j : integer);
1774       begin
1775           case j
1776             when 1 :  call comment(""); call warning("");
1777             when 2 :  call warning("From file c:\loglan95\graf.dta ");
1778                       graf := new graph;
1779                       call GRAF.take; call GRAF.print;
1780
1781             when 3 :  call warning(" Taking current graf from memory ");
1782                       if Graf<>none then
1783                           if GRAF.obraz<>none then
1784                                                                 call GUI_putImg(MinX+2, MinY+40,Graf.obraz) fi
1785                       else  call warning("Graph is empty")fi;
1786          esac;
1787       end Action;
1788       begin
1789            NOM(1) := "return";
1790            NOM(2) := "file";
1791            NOM(3) := "memory";
1792       end OPTIONS_import;
1793
1794       unit OPTIONS_modify : option class;
1795       unit virtual Action : procedure(j : integer);
1796       begin
1797           case j
1798             when 1 : call comment("");  call warning("");
1799             when 2 : call warning("Add a new node using button RIGHT of the mouse");
1800                      if Graf<>none then
1801                         call GRAF.createNODE
1802                      else call warning(" GRAPH IS EMPTY!")
1803                      fi;
1804
1805             when 3 : call warning("Add a new arc ");
1806                      if GRAF<>none then call GRAF.createARC('i')
1807                      else
1808                         call warning("Graph is empty")
1809                      fi;
1810
1811             when 4 : if GRAF<>none then call GRAF.DeleteARC('d')
1812                      else
1813                         call warning("Graph is empty")
1814                      fi;
1815
1816             when 5 : if graf<>none then
1817                         call GRAF.print
1818                      else
1819                         call warning("Graph is empty")
1820                      fi;
1821
1822             when 6 : call warning("The current immage of the graph is saved.");
1823                      if graf<> none then
1824                         call move(MinX+2,MinY+40);
1825                         Graf.obraz := getmap(MaxX-2,MaxY-2)
1826                      else call warning("Graph was not yet created")fi;
1827
1828             when 7 : call warning(
1829                         "This is the immage of the graph previously saved");
1830                       if Graf<>none then
1831                           call move(MinX+2, MinY+40);
1832                           if GRAF.obraz<>none then call putmap(Graf.obraz)fi
1833                       else  call warning("The image of Graph is empty")fi;
1834
1835          esac;
1836       end Action;
1837
1838       begin
1839             Nom(1) := "return";
1840             Nom(2) := "add node";
1841             Nom(3) := "add arc";
1842             Nom(4) := "del arc";
1843             Nom(5) := "print";
1844             Nom(6) := "getmap";
1845             Nom(7) := "putmap";
1846       end OPTIONS_modify;
1847
1848       unit OPTIONS_go : option class;
1849       unit virtual Action : procedure(j : integer);
1850       var ss : string;
1851       begin
1852            (* miejsce komentarzy *)
1853           case j
1854             when 1 :  call comment( ""); call warning("");
1855             when 2 :  call comment( "Breadth First Search  ");
1856                       if GRAF<> none then
1857                         call GRAF.restore;
1858                         call BFS_bis( GRAF);
1859                       FI;
1860             when 3 :  call comment( "Depth First Search  ");
1861                       if graf<> NONE THEN
1862                         call GRAF.restore;
1863                         call DFS(GRAF);
1864                       fi;
1865             when 4 :  call comment( "STRANGE Search  ");
1866                       if graf<> NONE THEN
1867                         call GRAF.restore;
1868                         call WHAT(GRAF);
1869                       fi;
1870             when 5 :  call comment( "Breadth First Search_BIS  ");
1871                       if GRAF<> none then
1872                         call GRAF.restore;
1873                         call BFS_bis( GRAF);
1874                       FI;
1875             when 6 :  call comment( "PILE_FILE SEARCH ");
1876                       if GRAF<> none then
1877                         call GRAF.restore;
1878                         call PI_FI( GRAF);
1879                       FI;
1880
1881             when 7 :  if Graf<>none then
1882                                 call GRAF.print
1883                       else  call warning("Graph is empty")fi;
1884
1885             when 8 : call clear(c_blue);
1886
1887          esac;
1888
1889       end Action;
1890       begin
1891             Nom(1) := "return";
1892             Nom(2) := "BFS";
1893             Nom(3) := "DFS";
1894             Nom(4) := "WHAT?";
1895             Nom(5) := "BFS_2";
1896             Nom(6) := "DFS_2";
1897             Nom(7) := "print";
1898             Nom(8) := "clear"
1899       end OPTIONS_go;
1900
1901 VAR     i, delta        : integer,
1902         boo             : boolean,
1903         O_main, O_help, O_cycl,
1904         O_graph, O_algo, O_import, O_modify, O_go : option,
1905         menu_main, menu_aux : menu,
1906         GRAF             : GRAPH,
1907         w                : node,
1908         G_file,help_file : file;
1909 handlers
1910    others         call warning(" ERROR press Y to continue or N to stop?");
1911
1912                   boo := YES;
1913                   if not boo then call GROFF; call ENDRUN fi;
1914                   call warning("");
1915                   wind;
1916
1917 end handlers;
1918
1919 begin
1920            (******           program  glowny         ******)
1921
1922
1923
1924
1925            call  GUI_Rect(MinX,MinY,MaxX,MaxY,c_lightGrey,c_lightGrey);
1926            for i := 1 to 14 do
1927            call GUI_Writetext(150+i*5,100+i*4,
1928                   unpack("B R E A D T H   F I R S T   S E A R C H"),i,c_black);
1929            call GUI_Writetext(200-i*5,200+i*4,
1930                   unpack("D E P T H   F I R S T   S E A R C H"),i,c_black);
1931            od;
1932            call waittt;
1933
1934            O_MAIN := new OPTIONS_MAIN(4);
1935            menu_main := new menu("MAIN_MENU",minX,maxX,minY,maxY,O_MAIN);
1936
1937            O_graph := new OPTIONS_graph(6);
1938            menu_main.ICONES(2).sub_menu, menu_aux :=
1939               new menu("CREATE or TAKE A GRAPH",minX,maxX,minY,maxY,O_graph);
1940
1941            O_import := new OPTIONS_import(3);
1942            menu_aux.ICONES(3).sub_menu :=
1943               new menu("TAKE GRAPH from a file or from memory",minX,maxX,minY,maxY,O_import);
1944
1945            O_modify := new OPTIONS_modify(7);
1946            menu_aux.ICONES(4).sub_menu :=
1947                 new menu("MODIFY THE GRAPH",minX,maxX,minY,maxY,O_modify);
1948
1949            menu_aux.ICONES(6).sub_menu :=
1950                 new menu("MODIFY THE GRAPH",minX,maxX,minY,maxY,O_modify);
1951
1952
1953            O_algo := new OPTIONS_algo(5);
1954            menu_main.ICONES(3).sub_menu,menu_aux :=
1955               new menu("ALGORITHMES on GRAPHS",minX,maxX,minY,maxY,O_algo);
1956
1957
1958            O_go := new OPTIONS_go(8);
1959            menu_aux.ICONES(2).sub_menu :=
1960              new menu("BREDTH FIRST SEARCH or DEPTH FIRST SEARCH",minX,maxX,minY,maxY,O_go);
1961
1962            O_cycl := new OPTIONS_cycl(5);
1963            menu_aux.ICONES(3).sub_menu :=
1964                new menu("RECHERCHE the CYCLS",minX,maxX,minY,maxY,O_cycl);
1965
1966
1967            O_help := new OPTIONS_help(4);
1968            menu_main.ICONES(4).sub_menu :=
1969                         new menu("HELP",minX,maxX,minY,maxY,O_help);
1970
1971
1972            attach(menu_main);
1973
1974
1975            while true  do
1976                 call warning("DO YOU REALY LIKE TO EXIT (Y/N)?");
1977                 boo := YES;
1978                 if boo then exit fi;
1979                 call warning("");
1980                 attach(menu_main);
1981            od;
1982            call GROFF;
1983        end;
1984     end
1985  end graf;
1986
1987
1988
1989
1990
1991
1992
1993  (*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)
1994  (*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)
1995 \0\0