3 #include "classes/gui.inc"
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? *)
26 wrnX = MinX+ 10, (* miejsce na ostrzezenia*)
33 unit punkt : class(x,y:integer);
43 (*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)
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 (*-------------------------------------------------------------------------*)
56 var premier, dernier, courant : link;
58 unit link : class(e: elem, prec:link, suiv: link);
68 unit debut : procedure;
69 (* post condition: (courant= x) => debut (courant= premier)) *)
74 unit restore : procedure;
78 do courant.used:= false; courant:= courant.suiv od;
82 unit next : function : elem;
86 courant := courant.suiv;
93 unit prev : function : elem;
97 if courant.prec<> none then
98 courant := courant.prec;
104 unit first : function : elem;
107 if premier <> none then
112 unit insert: procedure(e:elem);
113 (* post condition: (courant=x) => insert(e)(courant=x and e is_in_this_list) *)
116 l := new link(e,dernier,none);
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;
133 if aux.e.egal(e) then
149 premier := premier.suiv;
155 unit empty : function: Boolean;
157 result := (premier = none)
161 premier := none; dernier := none; courant := premier;
165 (*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)
166 (* ELEM jest typem elementow uzywanych we wszystkich strukturach tego progr.*)
169 unit virtual visite : function : boolean;
171 unit virtual egal : function (e:elem) : boolean;
173 unit virtual affichage : procedure;
177 (*++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)
178 (* OGOLNY MODEL STRUKTURY ABSTRAKCYJNEJ *)
180 unit structure : class;
184 var speedL : integer;
185 (*pozycja poczatkowa i przesuniecie dla ilustracji zawartosci struktury*)
187 unit virtual first : function : elem;
189 unit virtual delete : procedure;
191 unit virtual insert : procedure (e:elem);
193 unit virtual empty : function : boolean;
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,
207 debut:= G.root; fin:= G.nr;
221 if aux.father<>none then
222 call G.strzalka(aux.father,aux,i mod 7,c_black)
224 call aux.wypisz(i mod 7);(* i wyznacza kolor *)
226 if not aux.lista.empty then
227 aux1 := aux.lista.first;
230 if not aux1.visite then
235 aux1 := aux.lista.next
239 call comment("This execution has been stopped! Use MENU now.");
244 (* dla kazdego i inna skladowa *)
247 if (i>fin and debut<>1) then debut,i:=1; fin:= G.root-1; fi
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,
258 debut:= G.root; fin:= G.nr;
267 call aux.wypisz(i); (* i wyznacza kolor *)
271 aux := first; (* to jest pierwszy w str. pomocniczej*)
272 if (aux.lista.courant=none) then
274 (* usuwam go ze struktury tylko wtedy, gdy juz *)
275 (* odwiedzilam wszystkich jego synow *)
277 (* courant powinien pokazywac syna, ktorego mam teraz odwiedzic*)
278 aux1 := aux.lista.courant.e;
283 "This execution has been stopped! Use MENU now.");
287 if not aux1.visite then
291 call G.strzalka(aux1.father,aux1,i,c_black);
293 aux1 := aux.lista.next;
296 aux1 := aux.lista.next
300 call comment("This execution has been stopped! Use MENU now.");
303 fi (* if lista.courant=none *);
307 (* dla kazdego i inna skladowa *)
310 if (i>fin and debut<>1) then debut,i:=1; fin:= G.root-1; fi
315 unit printSTRplace : procedure(s:string);
316 var j,i,l,r,z,xx,yy,pos : integer,
317 less, more,boo : boolean;
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.");
332 while not (z=1 or z=3) do
333 call GUI_MousePressed(xx,yy,z) ;
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
341 call GUI_writetext(pos-8,StrMinY+8,unpack(" "),c_black,c_black);
344 if ((z=1 and more) and(speedL<10)) then
346 call GUI_writetext(pos,StrMinY+8,unpack(" "),
347 c_darkturq,c_darkturq);
350 if z=3 then call comment("");exit fi;
359 (*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)
361 unit queue : structure class;
362 var premier, dernier : box;
363 var dernierX : integer;
365 unit virtual first : function : elem;
373 unit virtual insert : procedure( e: elem);
376 if empty then dernierX:=x0 else dernierX:= dernierX+delta fi;
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); *)
394 unit virtual delete : procedure;
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*)
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*)
414 pomX := pomX + delta;
417 premier := premier.next;
418 if premier= none then dernier:= none fi;
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;
426 unit virtual empty : function : boolean;
428 result := (premier=none)
432 (*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)
434 unit stack : Structure class;
438 unit virtual first : function : elem;
446 unit virtual insert : procedure( e: elem);
449 if empty then topX := x0 else topX := topX+delta fi;
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); *)
460 unit virtual delete : procedure;
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;
472 unit virtual empty : function : boolean;
474 result := (premier=none)
480 (*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)
481 unit PILE_FILE : Structure class;
482 var premier, dernier,aux,aux1 : box;
483 var topX,dernierX : integer;
485 (* struktura, w ktorej delete i insert maja wlasnosci stosu*)
486 (* ale first dziala tak jak w kolejce *)
488 unit virtual first : function : elem;
489 begin call comment("first");
496 unit virtual insert : procedure( e: elem);
498 begin call comment("insert");
499 if empty then topX,dernierX:=x0 else dernierX:= dernierX+delta fi;
504 premier, dernier := aux;
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); *)
515 unit virtual delete : procedure;
519 then call comment("delete");
521 if premier.next=none then dernier,premier:=none
523 aux1:= none; aux := premier;
524 while aux.next<>none do aux1:=aux; aux := aux.next od;
525 dernier := aux1; dernier.next:= none
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;
533 unit virtual empty : function : boolean;
535 result := (premier=none)
541 UNIT PI_FI : PILE_FILE procedure(G:GRAPH);
543 call printSTRplace(" QUEUE ");
544 call comment("PILE_FILE SEARCH");
545 call traverse_bis(G);
549 (*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)
551 unit STRANGE : Structure class;
552 var premier : box, extra: box;
555 unit virtual first : function : elem;
565 unit virtual insert : procedure( e : elem);
568 if empty then topX := x0 else topX := topX+delta fi;
569 if emptyN then extra := new box; extra.e := e fi;
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); *)
579 unit virtual delete : procedure;
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;
590 unit emptyN : function : boolean;
592 result := (premier=none)
595 unit virtual empty : function : boolean;
602 (*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)
604 (*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)
607 UNIT DFS : STACK procedure(G: GRAPH);
609 call printSTRplace(" STACK ");
610 call comment("DEPTH FIRST SEARCH");
614 UNIT DFS_bis : STACK procedure(G: GRAPH);
616 call printSTRplace(" STACK ");
617 call comment("DEPTH FIRST SEARCH");
618 call traverse_bis(G);
622 UNIT BFS : QUEUE procedure(G:GRAPH);
624 call printSTRplace(" QUEUE ");
625 call comment("BREADTH FIRST SEARCH");
629 UNIT BFS_bis : QUEUE procedure(G:GRAPH);
631 call printSTRplace(" QUEUE ");
632 call comment("BREADTH FIRST SEARCH");
633 call traverse_bis(G);
637 UNIT WHAT : STRANGE procedure (G: GRAPH);
639 call printSTRplace(" STACK?? ");
640 call comment("STRANGE SEARCH");
644 unit look_all: class(G: GRAPH);
645 var i,debut,fin : integer,
648 debut:= G.root; fin:= G.nr;
656 if (i>fin and debut<>1) then debut,i:=1; fin:= G.root-1; fi
660 unit traverse_rec : look_all procedure;
661 unit DFS : procedure (aux: node,i:integer);
667 if aux.father<>none then
668 call G.strzalka(aux.father,aux,(i+9)mod 16,c_black)
670 call aux.wypisz((i+9)mod 16);(* i wyznacza kolor *)
672 aux1 := aux.lista.first;
677 aux1:= aux.lista.next
688 unit cycle_fond : procedure(G:GRAPH);
689 var STOS : arrayof integer,
692 (* stos przechowuje tylko numery wierzcholkow ze stosu*)
693 (* pile przechowuje wierzcholki zeby pokazac zawartosc stosu *)
695 unit CF : look_all procedure;
699 if (not aux.visite and not aux.use)
704 call pile.insert(aux);
708 call warning("This execution has been stopped! Use MENU now.");
713 if aux.father<>none then
714 call G.strzalka(aux.father,aux,11,c_black);
716 for j := 1 to 160 do call aux.affichage(11) od;
717 call aux.affichage(11);
719 (* staram sie dopisac cos do stosu *)
720 if aux.lista.courant<>none then
721 aux1 := aux.lista.courant.e;
724 if not aux1.visite and not aux1.use then
729 call pile.insert(aux1);
732 if ( not aux1.use and ii>1) then(* cykl ? *)
733 if aux1.nr<>STOS(ii-1) then
735 call GUI_writeText(piszX+delta,piszY,
736 unpack("("),c_blue,c_lightgrey);
741 call G.lista(x).wypisz(c_blue);
742 if x=aux1.nr then exit fi;
745 call GUI_writeText(piszX+delta,piszY,
746 unpack(")"),c_blue,c_lightgrey);
752 (* trzeba przejsc do nastepnego wierzch *)
753 aux1 := aux.lista.next
756 od (* while aux1<>none *);
757 fi (* if courant<>none *);
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*)
764 od(* while not empty pile *)
769 array STOS dim(1:G.nr);
771 call G.restore; (* odnowic structure grafu *)
772 call pile.printSTRplace(" STACK ");
773 ii:=0; (* ilosc elementow w stosie-tablicy*)
778 unit xxxxx: procedure (G:GRAPH);
781 unit trie_topologique : look_all procedure;
782 unit DFS : procedure (aux: node,i:integer);
788 if aux.father<>none then
789 call G.strzalka(aux.father,aux,i mod 7 ,c_black)
791 call aux.wypisz(i mod 7);(* i wyznacza kolor *)
793 aux1 := aux.lista.first;
798 aux1:= aux.lista.next
800 call stos.insert(aux);
805 end trie_topologique;
809 call stos.printSTRplace(" STACK");
810 call trie_topologique(G);
811 call GUI_Rect(piszX,piszY,maxX-5,piszY+13,c_lightGrey,c_lightGrey);
816 call stos.first qua node.wypisz(5);
821 (*++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)
822 UNIT EULER : procedure(G:GRAPH);
823 var aux,aux1,aux2 : node,
829 call pile.printSTRplace(" STACK ");
830 aux := G.lista(G.root);
831 call pile.insert(aux);
834 aux := pile.first; (* to jest pierwszy w str. pomocniczej*)
837 call aux.lista.debut;
838 aux1 := aux.lista.first;
839 (* courant jest teraz na poczatku listy*)
840 while (not booooo and aux1<>none)
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;
852 if (*aux.egal(aux2)*) aux.nr=aux2.nr then
853 call aux1.lista.courant.use;
856 aux2 := aux1.lista.next
861 aux1 := aux.lista.next
869 call comment("This execution has been stopped! Use MENU now.");
875 UNIT HAMILTON : procedure(G:GRAPH);
880 (*++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)
883 var lista : arrayof node,
886 obraz : arrayof integer ;
888 unit createNODE : procedure;
889 var lista1 : arrayof node,
891 i,l,r,z,x,y : integer,
897 call GUI_mousePressed(x,y,z);
901 w := new node(x,y,nr);
902 call w.affichage(14);
903 if nr <= upper(lista) then
906 array lista1 dim (1: upper(lista)+10);
907 for i := 1 to upper(lista)
908 do lista1(i) := lista(i) od;
915 unit change_root : procedure;
916 var x, y,i,l,r,z : integer;
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);
927 call GUI_MousePressed(x,y,z) ;
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);
937 if (y>wrnY+15 and y<wrnY+30) then exit fi;
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);
949 unit createARC : WEZ_DWA PROCEDURE;
951 (* do listy "w" dopisuje "w1"*)
952 call w.lista.insert(w1);
953 if not directed then call w1.lista.insert(w) fi;
957 unit DeleteARC : wez_dwa procedure;
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;
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;
973 (* czekam na nacisniecie prawego klawisza myszy w wierzcholku*)
974 call warning("I am waiting for the right-button of the mouse.");
978 call GUI_MousePressed(xx,yy,z);
981 w := szukaj(xx,yy,true);
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.");
988 do (*jesli chcesz sam rysowac/wymazac to naciskaj lewy klawisz myszy*)
992 when 'd' : call GUI_ellipse(xx,yy,3,3,0,360,c_lightGrey,c_lightGrey);
994 call GUI_point(xx,yy,c_red);
997 call GUI_MousePressed(xx,yy,z);
1000 (* szukam odpowiadajacego wierzcholka w1 *)
1001 w1 := SZUKAJ(xx,yy,true);
1004 (* MOZNA dopisac/dorysowac lub usunac/wymazac*)
1009 when 'd' : call strzalka(w,w1,c_lightgrey,c_lightGrey);
1010 when 'i' : call strzalka(w,w1,c_Yellow,c_black);
1014 call warning("I can not find the end of this arc, repeat the last action! ")
1016 else call warning("Not found, repeat please!")fi (* w<>none *);
1017 fi (* sa juz jakies wierzcholki *);
1020 UNIT SZUKAJ : function(xx,yy : integer,b : boolean) : node;
1021 var aux : node,i,j : integer;
1027 for j:=1 to 50 do call aux.affichage(5) od;
1028 call aux.affichage(14);
1030 (* szukam odpowiadajacego wierzcholka w*)
1031 if (abs(aux.x- xx)<7 and abs(aux.y-yy)<7)
1039 unit SAVE : procedure;
1040 var U,GL : arrayof integer, W : arrayof arrayof integer,
1042 sciezka : arrayof char,
1046 (*call warning("Give the name of your file or press CR to accept this");*)
1047 sciezka := unpack("/usr/local/vlp/examp/graf.dta");
1050 open(G_file,direct,sciezka);
1051 call rewrite(G_file);
1052 call seek(G_file,0,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);
1059 for i := 1 to nr do array W(i) dim (1:nr) od;
1060 (* dla kazdego wierzcholka z listy zidentyfikuj jego sasiadow*)
1064 call aux.lista.debut;
1065 aux1 := aux.lista.first;
1066 j := 0; (* j= liczbie wierzcholkow incydentnych dla aux *)
1070 W(i,j) := aux1.x*1000*100 + aux1.y*100 ;
1071 aux1 := aux.lista.next
1073 GL(i) := aux.x*1000*100 + aux.y*100 + j;
1076 putrec (G_file,GL,nn);
1079 nn := (GL(i) mod 100) * intSize ;
1080 if GL(i) >0 then putrec(G_file,W(i),nn)fi;
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,
1094 unit decode : procedure(a: integer; output x,y,ile: integer);
1097 y := (a div 100) mod 1000;
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);*)
1108 sciezka := unpack("/usr/local/vlp/examp/graf.dta");
1109 open(G_file,direct,sciezka);
1111 call seek(G_file,position(G_file),0);
1114 getrec (G_file,U,nn);
1116 directed := (U(2)=1);
1118 call seek(G_file,position(G_file),0);
1121 getrec (G_file,W,nn);
1122 if upper(lista) < nr then
1123 array lista dim(1: nr)
1125 array SASIEDZI dim (1:nr);
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);
1135 (* jezeli lista sasiadow j-tego wierz.jest>0 *)
1136 (* odczytac jego sasiadow i wpisac do odp. listy*)
1139 if SASIEDZI(j)<>0 then
1140 nn := SASIEDZI(j) * intSize;
1141 call seek(G_file,position(G_file),0);
1143 getrec(G_file,W,nn);
1144 for i := 1 to SASIEDZI(j)
1146 call decode(W(i),x,y,ile);
1147 aux1 := SZUKAJ(x,y,false);
1148 call lista(j).lista.insert (aux1);
1154 if directed then call warning("THIS IS A DIRECTED GRAPH ")
1156 call warning("THIS IS AN UNDIRECTED GRAPH ")
1161 unit restore : procedure;
1162 (* odnawia stan wierzcholkow *)
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
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;
1179 del := 15; delt:=7; (* decyduja o wielkosci grota *)
1181 call GUI_line(A.x,A.y,B.x,B.y,kol1);
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);
1197 unit print : procedure;
1198 var aux, aux1 : node, i : integer;
1203 call aux.affichage(c_yellow);
1206 call aux.lista.debut;
1207 aux1 := aux.lista.first;
1210 call strzalka(aux,aux1,c_yellow,c_black);
1211 aux1 := aux.lista.next;
1218 unit directORnot :procedure;
1219 var T: arrayof choix, i,j:integer;
1225 T(1).name:="direct";
1226 T(2).name:="indirect";
1227 j:= choice(100,100,T);
1231 array lista dim(1:10);
1233 (* ustal czy graf zorientowany czy nie*)
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 *)
1248 unit affichage : procedure(c: integer);
1250 if c= c_lightgrey then
1251 call GUI_ellipse(x,y,5,5,0,360,c_black,c_darkGrey)
1253 call GUI_ellipse(x,y,5,5,0,360,c,c)
1255 call GUI_writeInt(x+5,y+5,nr,c_lightGrey,c_black);
1258 unit wypisz : procedure(i: integer);
1259 (* wypisz kolejnosc odwiedzania wierzcholkow *)
1260 (* parametr i wyznacza nowy kolor wierzcholka*)
1263 for j := 1 to 160 do call affichage(j mod 16 ) od;
1264 if (i=8 or i=7)then i:=1 fi;
1266 call GUI_writeInt(piszX+delta,piszY,nr,i,c_lightGrey);
1272 call GUI_writetext(piszX+delta,piszY,unpack(","),i,c_lightGrey);
1276 unit virtual visite : function : boolean;
1277 (* Czy wierzcholek byl juz odwiedzony *)
1279 if kolor=c_black then result := true else result:= false fi;
1282 unit virtual use : function : boolean;
1283 (* Czy wierzcholek jest juz zuzyty *)
1285 if kolor=c_lightGrey then result := true else result:= false fi;
1288 unit virtual visite_le : procedure;
1289 (* Wierzcholek odwiedzony dostaje kolor czarny*)
1294 unit virtual egal : function( e: node) : boolean;
1296 if (x= e.x and y= e.y and nr = e.nr) then
1303 lista := new liste; kolor := c_yellow;
1305 (*--------------------------------------------------------------------*)
1308 unit clear : procedure(col : integer);
1309 var i,y, sr : integer;
1311 y := MinY+40; (* omijam menu *)
1312 sr := (minX+maxX) div 2;
1313 for i := 0 to (maxX - minX) div 2
1315 call GUI_line(sr, maxY,sr+i, Y,col);
1316 call GUI_line(sr, maxY,sr-i, Y,col);
1319 for i := 0 to (maxY - Y)
1321 call GUI_Line( sr, maxY,maxX, Y+i,col);
1322 call GUI_Line( sr, maxY,minX, Y+i,col);
1325 call GUI_Rect(MinX,Y,MaxX,MaxY,c_black,c_LightGrey);
1326 call GUI_Rect(MinX,StrMinY,MaxX,StrMaxY,c_black,C_lightGrey);
1330 unit clear_all : procedure(col : integer);
1332 call GUI_Rect(MinX,MaxY,MaxX,MaxY,c_black,c_lightGrey);
1333 call GUI_Rect(MinX,StrMinY,MaxX,StrMaxY,c_black,C_lightGrey);
1336 unit waittt : procedure;
1337 var x,y,i,l,r,z : integer, boo : boolean;
1339 call GUI_writetext(maxX-100,maxY-25,
1340 unpack("continue"),c_lightGrey,c_red);
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);
1347 unit arret : function : boolean;
1348 var x,y,z : integer;
1350 call Gui_writetext(maxX-100,maxY-25,
1351 unpack("STOP? "),c_lightGrey,c_red);
1352 call GUI_MousePressed(x,y,z) ;
1355 call GUI_writetext(maxX-100,maxY-25,
1356 unpack(" "),c_lightGrey,c_lightGrey);
1357 else result := false
1361 unit YES : function : boolean;
1362 var x,y : integer, l : char;
1364 l:=GUI_ReadChar(x,y,c_green,c_black);
1365 if (l= 'y' or l='Y') then
1373 unit speed: procedure(n : integer);
1377 for j:=1 to n do j:=j od;
1380 unit sleep: procedure(n : integer);
1383 for j:=1 to n do j:=j od;
1386 unit comment : procedure (s : string);
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);
1392 unit warning : procedure (s : string);
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);
1400 var uwaga : string, name : string,
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;
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);
1412 call GUI_writetext(xx+2,yy+i*15,unpack(T(i).name),c_black,c_lightGrey);
1420 call GUI_MousePressed(x,y,z) ;
1423 if ((x>xx and x< (xx+100)) and
1424 (y>T(j).y and y<(T(j).y+15)))
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*)
1430 call GUI_writetext(xx+2,yy+j*15,
1431 unpack(T(j).name),c_black,c_lightgrey)
1439 call GUI_putImg(xx,yy,IMAGE)
1443 (*++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)
1445 (*--------------------------------------------------------------------*)
1448 unit ramki_menu : procedure;
1450 call GUI_Rect(MinX,MinY,MaxX,MaxY,c_black,c_lightgrey);
1451 call GUI_Rect(MinX,StrMinY,MaxX,StrMaxY,c_black,C_lightGrey);
1454 unit option : class(nb : integer);
1455 var Nom : arrayof string;
1456 unit virtual action : procedure(j : integer);
1460 array Nom dim (1:nb);
1464 unit ikona : class(c:integer,p,q: punkt,ss:string);
1465 var sub_menu : menu;
1466 unit write_i : procedure;
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);
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 *)
1481 unit instalation : procedure;
1484 call GUI_Rect(MinX+1,7,MaxX-4,45,c_blue,c_lightGrey);
1487 call ICONES(i).write_i
1492 others call warning(" ERROR press Y to continue or N to stop?");
1495 if not boo then call GROFF; call ENDRUN fi;
1503 dl := (MaxX-Minx) div nb; sz := 18;
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);
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));
1518 do (* obsluga menu *)
1520 call instalation; (* rysowanie ikon z tego menu *)
1524 call GUI_MousePressed(xx,yy,z) ;
1526 call sleep(2); (*nie umiem powstrzymac myszy*)
1528 (*szukam gdzie zostal nacisniety klawisz myszki*)
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)
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);
1551 (*------------------------------------------------------------------------*)
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 (*------------------------------------------------------------------------*)
1562 unit OPTIONS_MAIN : option class;
1563 unit virtual Action : procedure(j : integer);
1569 when 2 : ss := "Create a new graph or take from a file or memory";
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);
1583 Nom(3) := "algorithms";
1587 unit OPTIONS_GRAPH : option class;
1588 unit virtual Action : procedure(j : integer);
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 ");
1599 call warning("Saving the recently defined graph.");
1602 call warning("GRAPH IS EMPTY");
1606 when 6 : call warning("Create a new graph");
1608 call GRAF.directORnot;
1622 unit OPTIONS_ALGO : option class;
1623 unit virtual Action : procedure(j : integer);
1624 var i : integer, ch : char;
1626 (* miejsce komentarzy *)
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("");
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;
1640 when 3 : call WARNING( "");
1641 when 4 : call comment( "Depth First Search recursive ");
1644 call traverse_rec(GRAF);
1646 when 5 : call comment( "TOPOLOGICAL Sort ");
1647 call warning("This algorithm require a graph without cycl!");
1661 NOM(5) := "top_sort";
1665 unit OPTIONS_cycl : option class;
1666 unit virtual Action : procedure(j : integer);
1670 when 1 : call comment(""); call warning("");
1674 call cycle_fond(GRAF);
1676 call warning("ALL the fundamental cycls of the graph");
1683 call warning("Find a Hamilton's cycl");
1685 call HAMILTON(GRAF);
1690 call GUI_Rect(MinX,MinY+40,MaxX,MaxY,c_lightGrey,c_LightGrey);
1691 if GRAF<>none then call GRAF.print fi;
1697 NOM(2) := "fundamental";
1699 NOM(4) := "Hamilton";
1700 NOM(5) := "restore "
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;
1711 when 1 : (* przy powrocie odnawiam ramki dla menu*)
1713 when 2 : call GUI_Rect(MinX,MinY+40,MaxX,MaxY,c_black,c_black);
1715 page_nb := page_nb + 1;
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)
1724 if ord(ch)=10 then exit else
1725 call GUI_writeChar(x,y,ch,c_white,c_black);
1730 if eof(help_file) then call warning("END OF FILE") fi;
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
1738 while not eof(help_file)
1741 if ord(ch)=10 then exit fi;
1746 (* drukuje tylko 19 linijek bo ekran jest maly*)
1748 call GUI_move(MinX+5, MinY+40+13*i);
1749 while not eof(help_file)
1752 if ord(ch)=10 then exit else call HASCII(ord(ch)) fi;
1757 call GUI_Rect(MinX,MinY+40,MaxX,MaxY,c_lightGrey,c_lightGrey);
1758 call reset(help_file);
1772 unit OPTIONS_import : option class;
1773 unit virtual Action : procedure(j : integer);
1776 when 1 : call comment(""); call warning("");
1777 when 2 : call warning("From file c:\loglan95\graf.dta ");
1779 call GRAF.take; call GRAF.print;
1781 when 3 : call warning(" Taking current graf from memory ");
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;
1794 unit OPTIONS_modify : option class;
1795 unit virtual Action : procedure(j : integer);
1798 when 1 : call comment(""); call warning("");
1799 when 2 : call warning("Add a new node using button RIGHT of the mouse");
1801 call GRAF.createNODE
1802 else call warning(" GRAPH IS EMPTY!")
1805 when 3 : call warning("Add a new arc ");
1806 if GRAF<>none then call GRAF.createARC('i')
1808 call warning("Graph is empty")
1811 when 4 : if GRAF<>none then call GRAF.DeleteARC('d')
1813 call warning("Graph is empty")
1816 when 5 : if graf<>none then
1819 call warning("Graph is empty")
1822 when 6 : call warning("The current immage of the graph is saved.");
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;
1828 when 7 : call warning(
1829 "This is the immage of the graph previously saved");
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;
1840 Nom(2) := "add node";
1841 Nom(3) := "add arc";
1842 Nom(4) := "del arc";
1848 unit OPTIONS_go : option class;
1849 unit virtual Action : procedure(j : integer);
1852 (* miejsce komentarzy *)
1854 when 1 : call comment( ""); call warning("");
1855 when 2 : call comment( "Breadth First Search ");
1858 call BFS_bis( GRAF);
1860 when 3 : call comment( "Depth First Search ");
1865 when 4 : call comment( "STRANGE Search ");
1870 when 5 : call comment( "Breadth First Search_BIS ");
1873 call BFS_bis( GRAF);
1875 when 6 : call comment( "PILE_FILE SEARCH ");
1881 when 7 : if Graf<>none then
1883 else call warning("Graph is empty")fi;
1885 when 8 : call clear(c_blue);
1901 VAR i, delta : integer,
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,
1908 G_file,help_file : file;
1910 others call warning(" ERROR press Y to continue or N to stop?");
1913 if not boo then call GROFF; call ENDRUN fi;
1920 (****** program glowny ******)
1925 call GUI_Rect(MinX,MinY,MaxX,MaxY,c_lightGrey,c_lightGrey);
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);
1934 O_MAIN := new OPTIONS_MAIN(4);
1935 menu_main := new menu("MAIN_MENU",minX,maxX,minY,maxY,O_MAIN);
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);
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);
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);
1949 menu_aux.ICONES(6).sub_menu :=
1950 new menu("MODIFY THE GRAPH",minX,maxX,minY,maxY,O_modify);
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);
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);
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);
1967 O_help := new OPTIONS_help(4);
1968 menu_main.ICONES(4).sub_menu :=
1969 new menu("HELP",minX,maxX,minY,maxY,O_help);
1976 call warning("DO YOU REALY LIKE TO EXIT (Y/N)?");
1978 if boo then exit fi;
1993 (*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)
1994 (*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)