Added upstream from http://ftp.icm.edu.pl/pub/loglan/
[loglan.git] / examples / examples.old / bidim.log
1 program projet1;\r
2 \r
3 begin\r
4 pref iiuwgraph block\r
5 \r
6 unit bst2 : class;\r
7   var racine : noeud;\r
8 \r
9   unit noeud : class(x,y : integer);\r
10     var gauche,droite : noeud;\r
11   end noeud;\r
12 \r
13   unit liste : class(x,y: integer);\r
14     var suiv,pred : liste;\r
15   end liste;\r
16 \r
17   unit insert : procedure(x,y : integer);\r
18   var d,td : boolean;\r
19   var t,tt : noeud;\r
20   begin\r
21     d:=false;\r
22     tt,t:=racine;\r
23     while (t<>none)\r
24     do\r
25       if d then td:=x<t.x;\r
26         else td:=y<t.y; fi;\r
27       tt:=t;\r
28       if td then t:=t.gauche; else t:=t.droite; fi;\r
29       d:=not d;\r
30     od;\r
31     if racine<>none then\r
32       t:=new noeud(x,y);\r
33       if td then tt.gauche:=t; else tt.droite:=t; fi;\r
34     else racine:=new noeud(x,y);\r
35     fi;\r
36   end insert;\r
37 \r
38   unit mb : function (x,y : integer) : boolean;\r
39   var d,td : boolean;\r
40   var t    : noeud;\r
41   begin\r
42     d:=false;\r
43     t:=racine;\r
44     while (t<>none)\r
45     do\r
46       if ((t.x=x) and (t.y=y)) then exit; fi;\r
47       if d then td:=x<t.x;\r
48         else td:=y<t.y; fi;\r
49       if td then t:=t.gauche; else t:=t.droite; fi;\r
50       d:=not d;\r
51     od;    if (t<>none) then result:=true; else result:=false; fi;\r
52   end mb;\r
53 \r
54   unit twodrange : procedure (t : noeud; x1,y1,x2,y2 : integer;\r
55                               d : boolean; inout l:liste);\r
56   var t1,t2,tx1,tx2,ty1,ty2 : boolean;\r
57   begin\r
58     if t<>none then\r
59       tx1:=x1<t.x;  tx2:=t.x<x2;\r
60       ty1:=y1<t.y;  ty2:=t.y<y2;\r
61       if d then\r
62         t1:=tx1; t2:=tx2;\r
63       else\r
64         t1:=ty1; t2:=ty2;\r
65       fi;\r
66       if t1 then call twodrange(t.gauche,x1,y1,x2,y2,(not d),l);fi;\r
67       if (x1<t.x) and (t.x<x2) and (y1<t.y) and (t.y<y2) then\r
68          if l<>none then\r
69            l.suiv:=new liste(t.x,t.y);\r
70            l.suiv.pred:=l;\r
71            l:=l.suiv;\r
72          else\r
73            l:=new liste(t.x,t.y);\r
74          fi;\r
75       else ;\r
76       fi;\r
77       if t2 then call twodrange (t.droite,x1,y1,x2,y2,(not d),l);fi;\r
78     fi;\r
79   end twodrange;\r
80 \r
81   unit delete : procedure (x,y : integer);\r
82   var d,td : boolean;\r
83   var t,tt,pb : noeud;\r
84   var test : boolean;\r
85 \r
86   unit sousmaxi : procedure(t : noeud;surx,click : boolean;\r
87                             inout dsort : boolean; inout n : noeud);\r
88   begin\r
89     if t<>none then\r
90       if surx then\r
91         if t.x>=n.x then n:=t;\r
92                          dsort:=click;\r
93         fi;\r
94       else\r
95         if t.y>=n.y then n:=t;\r
96                          dsort:=click;\r
97         fi;\r
98       fi;\r
99       call sousmaxi(t.gauche,surx,not(click),dsort,n);\r
100       call sousmaxi(t.droite,surx,not(click),dsort,n);\r
101     fi;\r
102   end sousmaxi;\r
103 \r
104   unit sousmini : procedure(t : noeud;surx,click : boolean;\r
105                             inout dsort : boolean;inout n : noeud);\r
106   begin\r
107     if t<>none then\r
108       if surx then\r
109         if t.x<=n.x then n:=t;\r
110                          dsort:=click;\r
111         fi;\r
112       else\r
113         if t.y<=n.y then n:=t;\r
114                          dsort:=click;\r
115         fi;\r
116       fi;\r
117       call sousmini(t.gauche,surx,not(click),dsort,n);\r
118       call sousmini(t.droite,surx,not(click),dsort,n);\r
119     fi;\r
120   end sousmini;\r
121 \r
122   unit delpartiel : procedure(t : noeud;surx : boolean);\r
123   var n  : noeud;\r
124   var dn : boolean;\r
125   begin\r
126     if (t.gauche=none) and (t.droite=none) then\r
127       kill(t);\r
128     else\r
129       if t.gauche<>none then\r
130         n:=t.gauche;\r
131         call sousmaxi(t.gauche,surx,not(surx),dn,n);\r
132         t.x:=n.x; t.y:=n.y;\r
133         call delpartiel(n,dn);\r
134       else\r
135         n:=t.droite;\r
136         call sousmini(t.droite,surx,not(surx),dn,n);\r
137         t.x:=n.x; t.y:=n.y;\r
138         call delpartiel(n,dn);\r
139       fi;\r
140     fi;\r
141   end delpartiel;\r
142 \r
143 \r
144   begin\r
145     d:=false;\r
146     t:=racine;\r
147     while (t<>none)\r
148     do\r
149       if ((t.x=x) and (t.y=y)) then exit; fi;\r
150       if d then td:=x<t.x;\r
151         else td:=y<t.y; fi;\r
152       if td then t:=t.gauche; else t:=t.droite; fi;\r
153       d:=not d;\r
154     od;\r
155     if t=none then\r
156       exit;\r
157     fi;\r
158     call delpartiel(t,d);\r
159   end delete;\r
160 \r
161   unit killall : procedure(inout t : noeud);\r
162   begin\r
163     if t<>none then\r
164       call killall(t.gauche);\r
165       call killall(t.droite);\r
166       kill(t);\r
167     fi;\r
168   end killall;\r
169 \r
170 \r
171   unit cadre : procedure( t : noeud;\r
172                           inout minx,maxx,miny,maxy : integer);\r
173   begin\r
174     if t<>none then\r
175       if t<>racine then\r
176         if t.x<minx then minx:=t.x; fi;\r
177         if t.x>maxx then maxx:=t.x; fi;\r
178         if t.y>maxy then maxy:=t.y; fi;\r
179         if t.y<miny then miny:=t.y; fi;\r
180       else\r
181         minx,maxx:=t.x;\r
182         miny,maxy:=t.y;\r
183       fi;\r
184       call cadre(t.gauche,minx,maxx,miny,maxy);\r
185       call cadre(t.droite,minx,maxx,miny,maxy);\r
186     fi;\r
187   end cadre;\r
188 \r
189   \r
190 \r
191 end bst2;\r
192 \r
193 (****************************************************************************)\r
194 (*********           PROGRAMME PRINCIPAL                          ***********)\r
195 begin\r
196 pref bst2 block\r
197 \r
198 \r
199 var arbre      : bst2;\r
200 var x,y,x1,y1,x2,y2,z,n,p   : integer;\r
201 var choix      : char;\r
202 var test       : boolean;\r
203 var ax,b,cx,d  : real;\r
204 var lespoints,ll  : liste;\r
205 \r
206 const maxx=639;\r
207 const maxy=349;\r
208 const bordure=10;\r
209 \r
210 \r
211 unit  SetCursor : procedure(column, row : integer);\r
212     var c,d,e,f  : char,\r
213         i,j : integer;\r
214   begin\r
215     i := row div 10;\r
216     j := row mod 10;\r
217     c := chr(48+i);\r
218     d := chr(48+j);\r
219     i := column div 10;\r
220     j := column mod 10;\r
221     e := chr(48+i);\r
222     f := chr(48+j);\r
223     write( chr(27), "[", c, d, ";", e, f, "H")\r
224   end SetCursor;\r
225 \r
226 unit writexy : procedure(x,y : integer; chaine : string);\r
227 begin\r
228   call setcursor(x,y);\r
229   writeln(chaine);\r
230 end;\r
231 \r
232 \r
233 unit outtextxy : procedure (val,x,y : integer);\r
234   var c       : integer;\r
235   var compt   : integer;\r
236   var aux     : integer;\r
237   var test    : boolean;\r
238   var negatif : boolean;\r
239 begin\r
240   \r
241   c:=1000;\r
242   compt:=4;\r
243   if (val<0) then\r
244     negatif:=true;\r
245     val:=-val;\r
246   else\r
247     negatif:=false;\r
248   fi;\r
249 \r
250   do\r
251     aux:=entier(val/c);\r
252     if aux=0 then\r
253       compt:=compt-1;\r
254       c:=c/10;\r
255     else\r
256       exit;\r
257     fi;\r
258     if aux<>0 or c<=1 then exit; fi;\r
259   od;\r
260   if negatif then compt:=compt+1; fi;\r
261   call move(x+(4-compt)*8,y);\r
262   if negatif then call hascii(45); fi;\r
263   do\r
264     aux:=entier(val/c);\r
265     call hascii(48+aux);\r
266     val:=val-aux*c;\r
267     c:=c/10;\r
268     if c<1 then exit; fi;\r
269   od;\r
270 end outtextxy;\r
271 \r
272 unit imprimegraphe : procedure (t : noeud);\r
273   unit chaine : class(x,y: integer);\r
274     var last,next : chaine;\r
275   end chaine;\r
276 var  r      : noeud;\r
277 var  et,c   : integer;\r
278 var d,td,dd : boolean;\r
279 var suite   : boolean;\r
280 var tt      : noeud;\r
281 var p       : chaine;\r
282 const cleft  =-75;\r
283 const cright =-77;\r
284 const cup    =-72;\r
285 \r
286   unit boite : procedure(cx,cy:integer);\r
287   begin\r
288     call move(cx-34,cy-10);\r
289     call draw(cx+42,cy-10);\r
290     call draw(cx+42,cy+10);\r
291     call draw(cx-34,cy+10);\r
292     call draw(cx-34,cy-10);\r
293     call move(cx+4,cy);\r
294     call draw(cx+4,cy+10);\r
295   end boite;\r
296 \r
297   unit imprimepartiel : procedure (t : noeud; cx,cy,px,py,c: integer;\r
298                                  inout suite : boolean;d : boolean);\r
299   var a : integer;\r
300   begin\r
301     if t<>none then\r
302       if (c=3 and (t.gauche<>none or t.droite<>none))\r
303           then suite:=true;\r
304       fi;\r
305       call boite(cx,cy);\r
306       if c<>0 then call move(px+4,py+10);call draw(cx+4,cy-10);fi;\r
307       call outtextxy(t.x,cx-32,cy);\r
308       if d then call move(cx,cy-8);call hascii(72);\r
309       else call move(cx,cy-8);call hascii(86); fi;\r
310       call outtextxy(t.y,cx+8,cy);\r
311       if c<3 then\r
312         a:=entier(40*8/exp(ln(2)*(c+1)));\r
313         call imprimepartiel(t.gauche,cx-a,cy+80,cx,cy,c+1,suite,not d);\r
314         call imprimepartiel(t.droite,cx+a,cy+80,cx,cy,c+1,suite,not d);\r
315         if suite then call move(200,300);\r
316                       call outstring("Appuyer sur une fleche pour la suite");\r
317         fi;\r
318       fi;\r
319 \r
320     fi;\r
321   end imprimepartiel;\r
322 \r
323   Begin\r
324   if t<>none then\r
325     r:=t;\r
326     p:=new chaine(t.x,t.y);\r
327     kill(p.last);\r
328     call gron(nocard);\r
329     dd:=false;\r
330     do\r
331       et:=0;\r
332       suite:=false;\r
333       call imprimepartiel(r,314,10,-1,-1,et,suite,dd);\r
334       call move(60,320);\r
335       call outstring\r
336            ("<- ou 4:Branche gauche; -> ou 6:Branche droite;");\r
337       call outstring("³ ou 8:Pere; <Ù:Menu;");\r
338       call move(435,318);\r
339       call hascii(94);\r
340       c:=readkey;\r
341       call  cls;\r
342       case c\r
343         when  52 : c:=cleft;\r
344         when  54 : c:=cright;\r
345         when  56 : c:=cup;\r
346       esac;\r
347       case c\r
348         when cleft  : if r.gauche<>none then\r
349                         r:=r.gauche;\r
350                         p.next:=new chaine(r.x,r.y);\r
351                         p.next.last:=p;\r
352                         p:=p.next;\r
353                         dd:=not dd;\r
354                       fi;\r
355         when cright : if r.droite<>none then\r
356                         r:=r.droite;\r
357                         p.next:=new chaine(r.x,r.y);\r
358                         p.next.last:=p;\r
359                         p:=p.next;\r
360                         dd:=not dd;\r
361                       fi;\r
362         when cup    : if p.last<>none then\r
363                          dd:=not dd;\r
364                          x:=p.last.x;\r
365                          y:=p.last.y;\r
366                          p:=p.last;\r
367                          d:=false;\r
368                          tt:=t;\r
369                          while (tt<>none)\r
370                          do\r
371                            if ((tt.x=x) and (tt.y=y)) then exit; fi;\r
372                            if d then td:=x<tt.x;\r
373                              else td:=y<tt.y; fi;\r
374                            if td then tt:=tt.gauche; else tt:=tt.droite; fi;\r
375                            d:=not d;\r
376                          od;\r
377                          r:=tt;\r
378                        fi;\r
379         when 13     : exit;\r
380       esac;\r
381     od;\r
382     call groff;\r
383   else\r
384     writeln(" Arbre Vide ");\r
385     z:=readkey;\r
386   fi;\r
387 end imprimegraphe;\r
388 \r
389 unit dessine : procedure (t : noeud; inout lx,hx,ly,hy:integer;d:boolean);\r
390 begin\r
391   if t<>none then\r
392     if not(d) then\r
393       call line(lx,t.y,hx,t.y);\r
394       call croix(t);\r
395       call dessine(t.gauche,lx,hx,ly,t.y,not(d));\r
396       call dessine(t.droite,lx,hx,t.y,hy,not(d));\r
397     else\r
398       call line(t.x,ly,t.x,hy);\r
399       call croix(t);\r
400       call dessine(t.gauche,lx,t.x,ly,hy,not(d));\r
401       call dessine(t.droite,t.x,hx,ly,hy,not(d));\r
402     fi;\r
403   fi;\r
404 end dessine;\r
405 \r
406 unit croix: procedure (t:noeud);\r
407 begin\r
408   call move((t.x*ax+b)-2,(t.y*cx+d)-2);\r
409   call draw((t.x*ax+b)+2,(t.y*cx+d)+2);\r
410   call move((t.x*ax+b)-2,(t.y*cx+d)+2);\r
411   call draw((t.x*ax+b)+2,(t.y*cx+d)-2);\r
412 end croix;\r
413 \r
414 unit line : procedure (x1,y1,x2,y2 : integer);\r
415 begin\r
416   call move(entier(x1*ax+b),entier(y1*cx+d));\r
417   call draw(entier(x2*ax+b),entier(y2*cx+d));\r
418 end line;\r
419 \r
420 \r
421 unit readkey : function : integer;\r
422   var c : integer;\r
423 begin\r
424   do\r
425     c:=inkey;\r
426     if c<>0 then exit; fi;\r
427   od;\r
428   result:=c;\r
429 end readkey;\r
430 \r
431 unit clrscr : procedure;\r
432 begin\r
433   write( chr(27), "[2J")\r
434 end clrscr;\r
435 \r
436 unit normal:procedure;\r
437 begin\r
438   write(chr(27),"[0m");\r
439 end normal;\r
440 \r
441 unit inverse:procedure;\r
442 begin\r
443   write(chr(27),"[7m");\r
444 end inverse;\r
445 \r
446 unit writeliste : procedure(l :liste);\r
447 var i,c : integer;\r
448 begin\r
449   i:=0;\r
450   while lespoints<>none\r
451   do\r
452     writeln(lespoints.x,",",lespoints.y);\r
453     if lespoints.pred<>none then lespoints:=lespoints.pred;\r
454       else exit;\r
455     fi;\r
456     i:=i+1;\r
457     if (i mod 22)=0 then\r
458       call writexy(30,24,"Appuyez sur une touche");\r
459       c:=readkey;\r
460     fi;\r
461   od;\r
462 end writeliste;\r
463 \r
464 unit lecture : procedure (inout x : integer);\r
465 begin\r
466   do\r
467      readln(x);\r
468      if x<=9999 and x>=-999 then exit; fi;\r
469      writeln("  Mauvaise coordonn\82e");\r
470   od;\r
471 end lecture;\r
472 \r
473 unit afficheMenu:procedure(n : integer,inv : boolean);\r
474 begin\r
475   if inv then call inverse;fi;\r
476   case n\r
477     when 1 : call writexy(20,5,"Inserer un element        ");\r
478     when 2 : call writexy(20,6,"Inserer plusieurs elements");\r
479     when 3 : call writexy(20,7,"Recherche d' un element   ");\r
480     when 4 : call writexy(20,8,"Range searching           ");\r
481     when 5 : call writexy(20,9,"Affiche tous les elements ");\r
482     when 6 : call writexy(20,10,"Delete                    ");\r
483     when 7 : call writexy(20,11,"Efface arbre              ");\r
484     when 8 : call writexy(20,12,"Affiche arbre             ");\r
485     when 9 : call writexy(20,13,"Dessine Plan              ");\r
486     when 10: call writexy(20,14,"Bye Bye                   ");\r
487   esac;\r
488   if inv then call normal;fi;\r
489 end afficheMenu;\r
490 \r
491 begin\r
492   arbre:= new bst2;\r
493   call arbre.insert(2,9);\r
494   call arbre.insert(11,1);\r
495   call arbre.insert(6,8);\r
496   call arbre.insert(3,3);\r
497   call arbre.insert(5,15);\r
498   call arbre.insert(8,11);\r
499   call arbre.insert(0,6);\r
500   call arbre.insert(7,4);\r
501   call arbre.insert(9,7);\r
502   call arbre.insert(14,5);\r
503   call arbre.insert(10,13);\r
504   call arbre.insert(16,14);\r
505   call arbre.insert(15,2);\r
506   call arbre.insert(13,16);\r
507   call arbre.insert(1,12);\r
508   call arbre.insert(12,10);\r
509 \r
510 \r
511   do\r
512     call clrscr;\r
513     call writexy(19,1,"ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»");\r
514     for n:=2 to 14 do call writexy(19,n,"º                           º");\r
515                    od;\r
516     call writexy(19,15,"ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍͼ");\r
517     call writexy(31,2,"MENU");\r
518     for n:=2 to 10 do call afficheMenu(n,false);\r
519                    od;\r
520     n:=1;\r
521     call afficheMenu(n,true);\r
522     do\r
523       z:=readkey;\r
524       if z=-80 or z=50 then p:=n;\r
525                     if n=10 then n:=1 else n:=n+1; fi;\r
526                     call afficheMenu(n,true);\r
527                     call afficheMenu(p,false);\r
528       fi;\r
529       if z=-72 or z=56 then p:=n;\r
530                     if n=1 then n:=10 else n:=n-1; fi;\r
531                     call afficheMenu(n,true);\r
532                     call afficheMenu(p,false);\r
533       fi;\r
534       if z=13 then exit;\r
535       fi;\r
536     od;\r
537     case n\r
538       when 1 : call clrscr;\r
539                call writexy(10,2,"Inserer un element");\r
540                write("x : ");  call lecture(x);\r
541                write("y : ");  call lecture(y);\r
542                call arbre.insert(x,y);\r
543       when 2 : call clrscr;\r
544                call writexy(10,2,"Inserer plusieurs elements");\r
545                do\r
546                  writeln("x : ");  call lecture(x);\r
547                  writeln("y : ");  call lecture(y);\r
548                  call arbre.insert(x,y);\r
549                  write("Encore ? (ENTER/n)");\r
550                  writeln;\r
551                  z:=readkey;\r
552                  if z<>13 then exit;fi;\r
553                od;\r
554       when 3 : call clrscr;\r
555                call writexy(10,2,"Recherche d'un element");\r
556                write("x : ");  call lecture(x);\r
557                write("y : ");  call lecture(y);\r
558                if (arbre.mb(x,y)) then\r
559                  writeln("Cet element fait partie de l'arbre.");\r
560                else\r
561                  writeln("Cet element ne fait pas partie de l'arbre.");\r
562                fi;\r
563                z:=readkey;\r
564       when 4 : call clrscr;\r
565                call writexy(10,2,"Range searching");\r
566                writeln("x1,y1");\r
567                writeln("  ÚÄÄÄÄÄÄÄÄÄÄ¿ ");\r
568                writeln("  ³          ³ ");\r
569                writeln("  ³          ³ ");\r
570                writeln("  ³          ³ ");\r
571                writeln("  ³          ³ ");\r
572                writeln("  ³          ³ ");\r
573                writeln("  ÀÄÄÄÄÄÄÄÄÄÄÙ ");\r
574                writeln("           x2,y2");\r
575                write("x1 : ");  call lecture(x1);\r
576                write("y1 : ");  call lecture(y1);\r
577                write("x2 : ");  call lecture(x2);\r
578                write("y2 : ");  call lecture(y2);\r
579                if (x2<x1) then p:=x1;x1:=x2;x2:=p;fi;\r
580                if (y2<y1) then p:=y1;y1:=y2;y2:=p;fi;\r
581                kill(lespoints);\r
582                call arbre.twodrange(arbre.racine,x1,y1,x2,y2,false,\r
583                                     lespoints);\r
584                call clrscr;\r
585                if lespoints<>none then\r
586                  call writeliste(lespoints);\r
587                else\r
588                  writeln(" Aucun points dans ce rectangle.");\r
589                fi;\r
590                z:=readkey;\r
591       when 5 : call clrscr;\r
592                call writexy(10,2,"Affiche tous les elements");\r
593                call arbre.cadre(arbre.racine,x1,x2,y1,y2);\r
594                x1:=x1-1; x2:=x2+1; y1:=y1-1; y2:=y2+1;\r
595                kill(lespoints);\r
596                call arbre.twodrange(arbre.racine,x1,y1,x2,y2,false,\r
597                                     lespoints);\r
598                call writeliste(lespoints);\r
599                z:=readkey;\r
600       when 6 : call clrscr;\r
601                call writexy(10,2,"Suppression d'un element");\r
602                write("x : ");  call lecture(x);\r
603                write("y : ");  call lecture(y);\r
604                if arbre.mb(x,y) then\r
605                  call arbre.delete(x,y);\r
606                else\r
607                  writeln("Element non trouve...");\r
608                  z:=readkey;\r
609                fi;\r
610       when 7 : call clrscr;\r
611                call writexy(10,2,"Destruction de l'arbre");\r
612                writeln("Etes vous sur de vouloir detruire l'arbre ? (o/n)");\r
613                readln(choix);\r
614                if choix='o' or choix='O' then\r
615                  call arbre.killall(arbre.racine);\r
616                  arbre:=new bst2;\r
617                fi;\r
618       when 8 : call clrscr;\r
619                call imprimegraphe(arbre.racine);\r
620       when 9 : call gron(nocard);\r
621                call cls;\r
622                call arbre.cadre(arbre.racine,x1,x2,y1,y2);\r
623                x1:=x1-1; x2:=x2+1; y1:=y1-1; y2:=y2+1;\r
624                ax:=maxx/(x2-x1); b:=-x1*ax;\r
625                cx:=maxy/(y2-y1); d:=-y1*cx;\r
626                call dessine(arbre.racine,x1,x2,y1,y2,false);\r
627                z:=readkey;\r
628                call groff;\r
629       when 10 : call clrscr;\r
630                 exit;exit;\r
631 \r
632     esac;\r
633   od;\r
634 end;\r
635 end; (* end bst2      *)\r
636 end; (* end iiuwgraph *)\r
637 \r