Added upstream from http://ftp.icm.edu.pl/pub/loglan/
[loglan.git] / examples / data_str / bst3.log
1 program drzewo;\r
2   \r
3   \r
4   var num: integer;\r
5   var op: boolean;\r
6   var korzen: node;\r
7   \r
8     \r
9   unit  sc : procedure(row, column : integer);\r
10     var c,d,e,f  : char,\r
11         i,j : integer;\r
12   begin\r
13     i := row div 10;\r
14     j := row mod 10;\r
15     c := chr(48+i);\r
16     d := chr(48+j);\r
17     i := column div 10;\r
18     j := column mod 10;\r
19     e := chr(48+i);\r
20     f := chr(48+j);\r
21     write( chr(27), "[", c, d, ";", e, f, "H")\r
22   end sc;\r
23 \r
24   unit inchar : IIUWgraph function : integer;\r
25     (*podaj nr znaku przeslanego z klawiatury *)\r
26     var i : integer;\r
27   begin\r
28     do\r
29       i := inkey;\r
30       if i <> 0 then exit fi;\r
31     od;\r
32     result := i;\r
33   end inchar;\r
34 \r
35   unit node: class (e: integer);\r
36     var left, right: node\r
37   end node;\r
38   \r
39   unit search: class (inout gdzie: node, co: integer);\r
40     var pom: node, pom2: node;\r
41     var czyjest: boolean\r
42   begin\r
43     pom:=gdzie;\r
44     while pom=/=none \r
45     do\r
46       if pom.e=co\r
47       then exit\r
48       fi;\r
49       pom2:=pom;\r
50       if pom.e>co\r
51       then pom:=pom.left\r
52       else pom:=pom.right\r
53       fi\r
54     od;\r
55     if pom=/=none\r
56     then czyjest:=true\r
57     fi\r
58   end search;\r
59   \r
60   unit np : procedure;\r
61   begin\r
62     write( chr(27), "[2J")\r
63   end np;\r
64         \r
65   unit cll: procedure (k: integer);\r
66     unit EraseLine : procedure;\r
67       begin\r
68         write( chr(27), "[K")\r
69     end EraseLine;\r
70   begin\r
71     call sc(k,1);\r
72     call EraseLine\r
73   end cll;\r
74   \r
75   unit ramka: procedure (w1, w2, w3, k1, k2: integer);\r
76     var i: integer;\r
77   begin\r
78     call sc(w1,k1);\r
79     write ("Ú");\r
80     for i:=k1+1 to k2-1\r
81     do\r
82       write ("Ä")\r
83     od;\r
84     write ("¿");\r
85     for i:=w1+1 to w3-1\r
86     do\r
87       call sc(i,k1);\r
88       write ("³");\r
89       call sc(i,k2);\r
90       write ("³")\r
91     od;\r
92     if w2 > 0\r
93     then\r
94       call sc(w2,k1);\r
95       write ("Ã");\r
96       for i:=k1+1 to k2-1\r
97       do\r
98         write ("Ä")\r
99       od;\r
100       write ("´")\r
101     fi;\r
102     call sc (w3,k1);\r
103     write ("À");\r
104     for i:=k1+1 to k2-1\r
105     do write ("Ä") od;\r
106     write ("Ù")\r
107   end ramka;\r
108   \r
109   unit menu: procedure;\r
110   begin\r
111     call np;\r
112     call ramka (1,5,21,10,70);\r
113     call sc(3,33);\r
114     write ("M   E   N   U");\r
115     call sc(7,15);\r
116     write ("1.   Wstawienie elementu do drzewa");\r
117     call sc(9,15);\r
118     write ("2.   Usuniecie elementu z drzewa");\r
119     call sc(11,15);\r
120     write ("3.   Sprawdzenie, czy element jest w drzewie");\r
121     call sc(13,15);\r
122     write ("4.   Sprawdzenie, czy drzewo jest puste");\r
123     call sc(15,15);\r
124     write ("5.   Drukowanie drzewa w postaci grafu");\r
125     call sc(17,15);\r
126     write ("6.   Drukowanie drzewa w postaci listy elementow");\r
127     call sc(19,15);\r
128     write ("7.   Wyjscie")\r
129   end menu;\r
130   \r
131   unit wprowliczbe: procedure (output liczba: integer, jest: boolean);\r
132     var znak: char;\r
133     var minus,l: boolean;\r
134     var t, k: integer;\r
135     var m,z: char;\r
136     \r
137     unit cyfra: function (z: char): boolean;\r
138     begin\r
139       if ord(z) >= ord('0') and ord(z) <= ord('9')\r
140       then result:=true\r
141       fi\r
142     end cyfra;\r
143     \r
144     unit alarm: procedure;\r
145     begin\r
146       writeln;\r
147       write ("To nie jest liczba calkowita");\r
148       call beep\r
149     end alarm;\r
150   \r
151   begin\r
152     t:=0;\r
153     z:='0';\r
154     k:=inchar;\r
155     znak:=chr(k);\r
156     m:='-';\r
157     if znak=m\r
158     then\r
159       minus:=true;\r
160       write ("-")\r
161     else\r
162       if not cyfra(znak)         \r
163       then \r
164         call alarm;\r
165         return\r
166       else\r
167         write (znak); \r
168         t:=t+ord(znak)-ord(z);\r
169         l:=true\r
170       fi\r
171     fi;\r
172     do\r
173       k:=inchar;\r
174       if k=013     (*  enter  *)\r
175       then \r
176         jest:=l;\r
177         if minus\r
178         then\r
179           liczba:=-t\r
180         else\r
181           liczba:=t;\r
182         fi;\r
183         exit\r
184       else\r
185         if not cyfra (chr(k))\r
186         then \r
187           call alarm;\r
188           return\r
189         else\r
190           write (chr(k));\r
191           l:=true;\r
192           t:=10*t+k-ord('0');\r
193         fi\r
194       fi\r
195     od\r
196   end wprowliczbe;\r
197   \r
198   unit podkresl: procedure (k1, k2, opcja: integer, czym: char);\r
199     var i, j, co: integer;\r
200   begin\r
201     co:=5+2*opcja;\r
202     for i:=co-1 step 2 to co+1 \r
203     do\r
204       call sc(i,k1+1);\r
205       for j:=k1+1 to k2-1\r
206       do\r
207         write (czym)\r
208       od\r
209     od\r
210   end podkresl;\r
211   \r
212   unit robzsearch: procedure (r: integer);\r
213     var elem: integer;\r
214     var licz: boolean;\r
215     \r
216     unit insert: search procedure;\r
217       var nowy: node;\r
218     begin\r
219       if not czyjest\r
220       then\r
221         nowy:=new node(co);\r
222         if gdzie=none\r
223         then\r
224           gdzie:=nowy\r
225         else\r
226           if pom2.e>co\r
227           then pom2.left:=nowy\r
228           else pom2.right:=nowy\r
229           fi\r
230         fi\r
231       fi\r
232     end insert;\r
233     \r
234     unit delete: search procedure;\r
235       var p1, p2: node;\r
236       \r
237       unit przestaw: procedure (naco: node);\r
238       begin\r
239         if pom=gdzie\r
240         then     (*  usuwamy korzen  *)\r
241           gdzie:=naco\r
242         else\r
243           if pom2.left=pom\r
244           then pom2.left:=naco\r
245           else pom2.right:=naco\r
246           fi\r
247         fi\r
248       end przestaw;\r
249       \r
250     begin\r
251       if czyjest \r
252       then\r
253         if pom.left=none\r
254         then \r
255           call przestaw (pom.right)\r
256         else\r
257           if pom.right=none\r
258           then\r
259             call przestaw (pom.left)\r
260           else     (*  usuwany wezel ma dwoch synow  *)\r
261             if pom.right.left=none\r
262             then\r
263               call przestaw(pom.right);\r
264               pom.right.left:=pom.left\r
265             else\r
266               p1:=pom.right;\r
267               p2:=p1.left;\r
268               while p2.left=/=none\r
269               do\r
270                 p1:=p1.left;\r
271                 p2:=p2.left\r
272               od;\r
273               p1.left:=p2.right;\r
274               p2.left:=pom.left;\r
275               p2.right:=pom.right;\r
276               call przestaw (p2)\r
277             fi\r
278           fi\r
279         fi\r
280       fi\r
281     end delete;\r
282     \r
283     unit member: search procedure;\r
284       var kon: integer;\r
285     begin\r
286       call cll(24);\r
287       if czyjest\r
288       then\r
289         write ("Ten element jest w drzewie     ")\r
290       else\r
291         write ("Tego elementu nie ma w drzewie     ") \r
292       fi;\r
293       kon:=inchar\r
294     end member;\r
295     \r
296   begin     (*  robzsearch  *)\r
297     call cll(24);\r
298     write ("Podaj element     ");\r
299     call wprowliczbe (elem,licz);\r
300     if not licz\r
301     then\r
302       return\r
303     else\r
304       case r\r
305         when 1 : call insert (korzen,elem);\r
306         when 2 : call delete (korzen,elem);\r
307         when 3 : call member (korzen,elem)\r
308       esac\r
309     fi\r
310   end robzsearch;\r
311   \r
312   unit empty: procedure (k: node);\r
313     var kon: integer;\r
314   begin\r
315     call cll(24);\r
316     if k=none\r
317     then\r
318       write ("Drzewo jest puste     ")\r
319     else\r
320       write ("Drzewo nie jest puste     ")\r
321     fi;\r
322     kon:=inchar\r
323   end empty;\r
324   \r
325   unit drukuj: procedure;\r
326     var s: char;\r
327     var g, ko: integer;\r
328     var h: boolean;\r
329     var x: search;\r
330     \r
331     unit druk: procedure (kor: node);\r
332       var kondruk: boolean;\r
333       \r
334       unit dlugi: function (k: node): boolean;\r
335       begin\r
336         if k=/=none\r
337         then\r
338           result:=k.e>99 or k.e<-9 or dlugi(k.left) or dlugi(k.right)\r
339         fi\r
340       end dlugi;\r
341       \r
342       unit krotkidruk: procedure (wiersz, pocz, kon: integer; drzewo: node);\r
343         var y, i, z: integer;\r
344       begin\r
345         z:= (kon+pocz-1) div 2;\r
346         call ramka (wiersz, 0, wiersz+2, z-1, z+2);\r
347         if wiersz=/=1\r
348         then\r
349           call sc(wiersz,z);\r
350           write ("Á")\r
351         fi;\r
352         call sc(wiersz+1,z);\r
353         write (drzewo.e:2);\r
354         if drzewo.left=/=none\r
355         then \r
356           if wiersz=21\r
357           then kondruk:=true\r
358           else      (*  drukowanie lewego poddrzewa  *)\r
359             y:= (z+pocz-1) div 2;\r
360             call sc (wiersz+4,y);\r
361             write ("Ú");\r
362             for i:=y+1 to z-1\r
363             do\r
364               write ("Ä")\r
365             od;\r
366             write ("Ù");\r
367             call sc(wiersz+3,z);\r
368             write ("³");\r
369             call sc(wiersz+2,z);\r
370             write ("Â");\r
371             call krotkidruk (wiersz+5,pocz,z,drzewo.left)\r
372           fi\r
373         fi;\r
374         if drzewo.right=/=none\r
375         then\r
376           if wiersz=21\r
377           then kondruk:=true\r
378           else     (*  drukowanie prawego poddrzewa  *)\r
379             y:= (kon+z) div 2;\r
380             call sc(wiersz+2,z+1);\r
381             write ("Â");\r
382             call sc(wiersz+3,z+1);\r
383             write ("³");\r
384             call sc(wiersz+4,z+1);\r
385             write ("À");\r
386             for i:=z+2 to y-1\r
387             do\r
388               write ("Ä")\r
389             od;\r
390             write ("¿");\r
391             call krotkidruk (wiersz+5,z+1,kon,drzewo.right)\r
392           fi\r
393         fi\r
394       end krotkidruk;\r
395       \r
396       unit dlugidruk: procedure (wiersz, pocz, kon: integer, drzewo: node);\r
397         var y, i, z: integer;\r
398       begin\r
399         z:= (kon+pocz-1) div 2;\r
400         call ramka (wiersz, 0, wiersz+2, z-4,  z+4);\r
401         if wiersz=/=1\r
402         then\r
403           call sc(wiersz,z);\r
404           write ("Á")\r
405         fi;\r
406         call sc(wiersz+1,z-3);\r
407         write (drzewo.e:7);\r
408         if drzewo.left=/=none\r
409         then\r
410           if wiersz=19\r
411           then \r
412             kondruk:=true\r
413           else     (*  drukowanie lewego poddrzewa  *)\r
414             y:= (z+pocz-1) div 2;\r
415             call sc(wiersz+5,y);\r
416             write ("³");\r
417             call sc(wiersz+4,y);\r
418             write ("Ú");\r
419             for i:=y+1 to z-3\r
420             do\r
421               write ("Ä")\r
422             od;\r
423             write ("Ù");\r
424             call sc(wiersz+3,z-2);\r
425             write ("³");\r
426             call sc(wiersz+2,z-2);\r
427             write ("Â");\r
428             call dlugidruk (wiersz+6, pocz, z, drzewo.left)\r
429           fi\r
430         fi;\r
431         if drzewo.right=/=none\r
432         then\r
433           if wiersz=19\r
434           then\r
435             kondruk:=true\r
436           else     (*  drukowanie prawego poddrzewa  *)\r
437             y:= (kon+z) div 2;\r
438             call sc (wiersz+2,z+2);\r
439             write  ("Â");\r            call sc(wiersz+3,z+2);\r
440             write ("³");\r
441             call sc(wiersz+4,z+2);\r
442             write ("À");\r
443             for i:=z+3 to y-1\r
444             do\r
445               write ("Ä")\r
446             od;\r
447             write ("¿");\r
448             call sc(wiersz+5,y);\r
449             write ("³");\r
450             call dlugidruk (wiersz+6, z+1, kon, drzewo.right)\r
451           fi\r
452         fi\r
453       end dlugidruk;\r
454       \r
455     begin     (*  druk  *)\r
456       call np;\r
457       if dlugi (kor)\r
458       then\r
459         call dlugidruk(1,1,80,kor)\r
460       else\r
461         call krotkidruk(1,1,80,kor)\r
462       fi;\r
463       if kondruk\r
464       then\r
465         call sc(25,1);\r
466         write ("Dalsza czesc drzewa nie miesci sie na ekranie     ");\r
467       fi\r
468     end druk;\r
469     \r
470   begin     (*  drukuj  *)\r
471     call cll(24);\r
472     if korzen=none\r
473     then\r
474       write ("Drzewo jest puste")\r
475     else\r
476       write ("Czy chcesz obejrzec drzewo od korzenia ?");\r
477       ko:=inchar;\r
478       s:=chr(ko);\r
479       if s=/='n'\r
480       then\r
481         call druk (korzen)\r
482       else\r
483         call cll(24);\r
484         write ("Podaj korzen poddrzewa, ktore chcesz obejrzec     ");\r
485         call wprowliczbe (g,h);\r
486         if not h \r
487         then\r
488           return\r
489         else\r
490           x:=new search (korzen,g);\r
491           if not x.czyjest\r
492           then\r
493             call cll(24);\r
494             write ("Tego elementu nie ma w drzewie     ");\r
495             kill (x)\r
496           else\r
497             call druk (x.pom);\r
498             kill (x)\r
499           fi\r
500         fi\r
501       fi\r
502     fi;\r
503     ko:=inchar\r
504   end drukuj;\r
505   \r
506   unit fix: procedure (k: node);\r
507     var n, kon: integer;\r
508     var f: boolean;\r
509     \r
510     unit prefix: procedure (d: node);\r
511     begin\r
512       if d=/=none\r
513       then\r
514         write (d.e);\r
515         write ("  ,  ");\r
516         call prefix (d.left);\r
517         call prefix (d.right)\r
518       fi\r
519     end prefix;\r
520     \r
521     unit infix: procedure (d: node);\r
522     begin\r
523       if d=/=none\r
524       then\r
525         call infix (d.left);\r
526         write (d.e);\r
527         write ("  ,  ");\r
528         call infix (d.right)\r
529       fi\r
530     end infix;\r
531     \r
532     unit postfix: procedure (d: node);\r
533     begin\r
534       if d=/=none\r
535       then\r
536         call postfix (d.left);\r
537         call postfix (d.right);\r
538         write (d.e);\r
539         write ("  ,  ")\r
540       fi\r
541     end postfix;\r
542     \r
543   begin     (*  fix  *)\r
544     if k=none\r
545     then\r
546       writeln;\r
547       write ("Drzewo jest puste")\r
548     else\r
549       call np;\r
550       call ramka (1,5,13,30,49);\r
551       call sc(3,35);\r
552       write ("M  E  N  U");\r
553       call sc(7,33);\r
554       write ("1.  prefix");\r
555       call sc(9,33);\r
556       write ("2.  infix");\r
557       call sc(11,33);\r
558       write ("3.  postfix");\r
559       call sc(24,1);\r
560       write ("Podaj numer opcji     ");\r
561       call wprowliczbe (n,f);\r
562       if f andif (n >= 1 and n <= 3)\r
563       then\r
564         call podkresl (30,49,n,'.');\r
565         call cll(24);\r
566         call sc(17,1);\r
567         case n\r
568           when 1 : call prefix (korzen);\r
569           when 2 : call infix (korzen);\r
570           when 3 : call postfix (korzen)\r
571         esac\r
572       fi;\r
573     fi;\r
574     write("     ");\r
575     kon:=inchar\r
576   end fix;\r
577   \r
578   unit czekaj: procedure;\r
579     var t, k: integer;\r
580   begin\r
581     t:=time;\r
582     k:=time;\r
583     while k-t<2\r
584     do\r
585       k:=time\r
586     od\r
587   end czekaj;\r
588   \r
589   unit beep: procedure;\r
590   begin\r
591     write ("\a\a\a\a")\r
592   end beep;\r
593   \r
594   unit zakonczenie: procedure;\r
595     var i, j, t, k: integer;\r
596   begin\r
597     for i:=9 to 15 \r
598     do\r
599       call cll(i)\r
600     od;\r
601     for i:=10 step 4 to 14 \r
602     do\r
603       call sc(i,10);\r
604       for j:=10 to 70\r
605       do\r
606         write ('*')\r
607       od\r
608     od;\r
609     for i:=10 step 60 to 70 \r
610     do\r
611       for j:=11 to 13\r
612       do\r
613         call sc(j,i);\r
614         write ('*')\r
615       od\r
616     od;\r
617     call sc(12,33);\r
618     write ("DO ZOBACZENIA          ");\r
619     call czekaj;\r
620     call endrun\r
621   end zakonczenie;\r
622   \r
623   \r
624 begin     (*  program glowny  *)\r
625   call menu;\r
626   do\r
627     call cll(25);\r
628     call cll(24);\r
629     write ("Podaj numer opcji      ");\r
630     call wprowliczbe (num,op);\r
631     if not op\r
632     then  \r
633       repeat\r
634     fi;\r
635     if num < 1 or num > 7\r
636     then  \r
637       call beep;\r
638       repeat\r
639     fi;\r
640     call podkresl (10,70,num,'.');\r
641     case num\r
642       when 1 : call robzsearch (1);     (*  insert  *)\r
643       when 2 : call robzsearch (2);     (*  delete  *)\r
644       when 3 : call robzsearch (3);     (*  member  *)\r
645       when 4 : call empty (korzen);\r
646       when 5 : call drukuj;\r
647       when 6 : call fix (korzen)\r
648     esac;\r
649     if num=5 or num=6\r
650     then\r
651       call menu\r
652     else\r
653       call podkresl (10,70,num,' ')\r
654     fi;\r
655     if num=7\r
656     then\r
657       call zakonczenie\r
658     fi\r
659   od\r
660 end drzewo\r
661 \r
662           \r
663 \1a