examples/pataud/new3.log

   1 Program SystemedeFenetrage;\r
   2 begin\r
   3 pref iiuwgraph block\r
   4 (* version lightweight processus *)\r
   5 Const Noir        =0,Bleu          =1,Vert        =2,Cyan          =3,\r
   6       Rouge       =4,Magenta       =5,Marron      =6,GrisCLair     =7,\r
   7       GrisFonce   =8,BleuClair     =9,VertClair  =10,CyanClair    =11,\r
   8       RougeClair =12,MagentaClair =13,Jaune      =14,Blanc        =15;\r
   9 \r
  10 \r
  11    (*********************************************************************)\r
  12    (*        notion de lightweight process                              *)\r
  13    (*********************************************************************)\r
  14 var actualp: proces;\r
  15 var active: set;\r
  16 var suspended :set;\r
  17 \r
  18   unit semafor : class;\r
  19     hidden close SEM, SUSPENDED;\r
  20     var SEM : boolean;\r
  21     var SUSPENDED : set;\r
  22 \r
  23     unit tsp : function : boolean;\r
  24       begin\r
  25        result := SEM;\r
  26        sem := true;\r
  27     end tsp;\r
  28 \r
  29     unit up : procedure;\r
  30       begin\r
  31        SEM := false;\r
  32     end up;\r
  33 \r
  34     unit lockp : procedure;\r
  35       begin\r
  36        if SEM\r
  37        then\r
  38         call active.delete(actualp);\r
  39         call suspended.insert(actualp);\r
  40         actualp.suspndd := true;\r
  41         actualp := active.amember;\r
  42         attach(actualp);\r
  43        else\r
  44         SEM := true\r
  45        fi\r
  46     end lockp;\r
  47 \r
  48     unit unlockp : procedure;\r
  49       var aux : proces;\r
  50 \r
  51       begin\r
  52        if suspended.empty\r
  53        then\r
  54         SEM := false\r
  55        else\r
  56         aux := suspended.min;\r
  57         call suspended.delete(aux);\r
  58         aux.suspndd := false;\r
  59         call active.insert(aux)\r
  60        fi\r
  61     end unlockp;\r
  62 \r
  63     begin (* initialization of a semaphore*)\r
  64      suspended := new set\r
  65    end semafor;\r
  66 \r
  67 \r
  68    unit set : class;\r
  69     (* in this version it will be a queue *)\r
  70 \r
  71      unit link : class(x : proces);\r
  72        var next : link\r
  73      end link;\r
  74 \r
  75      var head, tail : link;\r
  76 \r
  77      unit insert : procedure(x : proces);\r
  78        var ogniwo : link;\r
  79      begin\r
  80        ogniwo := new link(x);\r
  81        if tail = none\r
  82        then\r
  83         head := ogniwo\r
  84        else\r
  85         tail.next := ogniwo\r
  86        fi;\r
  87        tail := ogniwo\r
  88      end insert;\r
  89 \r
  90      unit empty : function : boolean;\r
  91        begin\r
  92         result := (head = none)\r
  93      end empty;\r
  94 \r
  95      unit min : function : proces;\r
  96        begin\r
  97         result := head.x;\r
  98      end min;\r
  99 \r
 100      unit delete : procedure (x : proces);\r
 101        var o,ogniwo : link;\r
 102      begin\r
 103       o,ogniwo := head;\r
 104       while ogniwo.x =/= x\r
 105       do\r
 106        o := ogniwo;\r
 107        ogniwo := ogniwo.next;\r
 108        if ogniwo = none\r
 109        then\r
 110         writeln(" deleted process does not exist");\r
 111         return\r
 112        fi;\r
 113       od;\r
 114       if ogniwo = head\r
 115       then\r
 116        head := head.next\r
 117       fi;\r
 118       o.next := ogniwo.next;\r
 119       if ogniwo = tail\r
 120       then\r
 121        tail := o;\r
 122        tail.next := none\r
 123       fi;\r
 124       kill(ogniwo)\r
 125    end delete;\r
 126 \r
 127    unit amember : function : proces;\r
 128      var o : link;\r
 129    begin\r
 130      result := head.x;\r
 131      if head.next =/= none\r
 132      then\r
 133       o := head;\r
 134       tail.next := o;\r
 135       tail := o;\r
 136       head := head.next;\r
 137       o.next := none\r
 138      fi\r
 139    end amember;\r
 140 \r
 141  end set;\r
 142 \r
 143 \r
 144 \r
 145  unit proces : coroutine;\r
 146    (* this class implements notion of process*)\r
 147    var nrofsons : integer;\r
 148    var waiting, terminated, suspndd : boolean;\r
 149    var father, nameofson : proces;\r
 150 \r
 151    unit resumep : procedure(x : proces);\r
 152     begin\r
 153       if x.suspndd\r
 154       then\r
 155        call suspended.delete(x);\r
 156        call active.insert(x);\r
 157        x.suspndd := false;\r
 158       else\r
 159        if x.terminated\r
 160        then\r
 161         (* error *)\r
 162         writeln(" you are resuming a terminated process?!");\r
 163         return\r
 164        fi\r
 165       fi\r
 166    end resumep;\r
 167 \r
 168 \r
 169    unit stopp : procedure;\r
 170     begin\r
 171       call active.delete(actualp);\r
 172       call suspended.insert(actualp);\r
 173       suspndd := true;\r
 174       actualp := active.amember;\r
 175       attach(actualp)\r
 176   end stopp;\r
 177 \r
 178   unit waitp : function(y : proces) : proces;\r
 179     begin\r
 180       if y = none\r
 181       then\r
 182        (*error*)\r
 183        writeln(" waiting for a process which does not exist");\r
 184        return\r
 185       fi;\r
 186       if y.terminated\r
 187       then\r
 188        return\r
 189       fi;\r
 190       if y.father =/= this proces\r
 191       then\r
 192        (* error *)\r
 193        writeln(" y is not your son!");\r
 194        return\r
 195       fi;\r
 196       (* O.K. *)\r
 197       nameofson := y;\r
 198       waiting := true;\r
 199       call stopp;\r
 200 \r
 201       (* here we shall return upon termination of son*)\r
 202       result := nameofson;\r
 203       waiting := false;\r
 204   end waitp;\r
 205 \r
 206 \r
 207   unit stoppar :procedure (z:semafor);\r
 208     begin\r
 209       call z.unlockp;\r
 210       call stopp\r
 211   end stoppar;\r
 212 \r
 213   unit waitn : function : proces;\r
 214     begin\r
 215       if nrofsons = 0\r
 216       then (*error*)\r
 217         writeln(" you wait for a son, but it does not exist ");\r
 218         return;\r
 219       else\r
 220         waiting:=true;\r
 221         nameofson:=none;\r
 222         call stopp;\r
 223         (* you return here *)\r
 224         result:=nameofson;\r
 225         waiting:= false;\r
 226       fi;\r
 227   end waitn;\r
 228 \r
 229   unit xqmulti : procedure;\r
 230     begin\r
 231       actualp:=active.amember;\r
 232       attach(actualp)\r
 233   end xqmulti;\r
 234 \r
 235   begin  (*prologue of process*)\r
 236      father:= actualp;\r
 237      if father =/= none\r
 238      then\r
 239        father.nrofsons:=father.nrofsons +1;\r
 240      fi;\r
 241      call suspended.insert (this proces);\r
 242      suspndd:=true;\r
 243 \r
 244      inner; (* here comes the body of your process *)\r
 245 \r
 246      (* process epilogue *)\r
 247      terminated :=true;\r
 248      call active.delete(actualp);\r
 249      if father =/= none\r
 250      then\r
 251        father.nrofsons:=father.nrofsons - 1;\r
 252        if father.waiting\r
 253        then\r
 254          if father.nameofson = none\r
 255          then\r
 256            father.nameofson := this proces\r
 257          fi;\r
 258          if father.nameofson = this proces\r
 259          then\r
 260            call resumep(father)\r
 261          fi\r
 262        fi;\r
 263        actualp:=active.amember;\r
 264        attach(actualp);\r
 265      else\r
 266        attach(main);\r
 267      fi;\r
 268    end proces;\r
 269    unit resumep : procedure(x : proces);\r
 270     begin\r
 271       if x.suspndd\r
 272       then\r
 273        call suspended.delete(x);\r
 274        call active.insert(x);\r
 275        x.suspndd := false;\r
 276       else\r
 277        if x.terminated\r
 278        then\r
 279         (* error *)\r
 280         writeln(" you are resuming a terminated process?!");\r
 281         return\r
 282        fi\r
 283       fi\r
 284    end resumep;\r
 285 \r
 286      unit Arbitrage : procedure;\r
 287        begin\r
 288          actualp:=active.amember;\r
 289          attach(actualp);\r
 290      end Arbitrage;\r
 291 \r
 292 \r
 293 \r
 294 \r
 295 \r
 296    (*****************************************************************************)\r
 297    (*             premiere famille de classes : les classes graphiques          *)\r
 298    (*****************************************************************************)\r
 299    Unit Ptr : Class;\r
 300    End Ptr;\r
 301 \r
 302    Unit Windows : Ptr Class(father :windows,x1,y1,x2,y2 : integer);\r
 303    Close hauteur,largeur;\r
 304    Var lborder,cfond,cborder : integer,\r
 305        lbande,cfbande,cbbande : integer,\r
 306       hauteur,largeur       : integer,\r
 307       xpos,ypos,xmax,ymax   : integer,\r
 308       xdeb,ydeb             : integer,\r
 309       num_id                : integer,\r
 310       ListM                 : Lclic,\r
 311       ListK                 : LKey,\r
 312       nombande              : arrayof char,\r
 313       barcde                : menu,\r
 314       save_map              : arrayof integer;\r
 315 \r
 316       Unit option : procedure (l1,l2,l3,l4,l5,l6 : integer,l7 : arrayof char);\r
 317       Begin\r
 318        cfond:=l1; lborder:=l2; cborder:=l3; lbande:=l4;\r
 319        cfbande:=l5; cbbande:=l6;\r
 320        nombande:=copy(l7);\r
 321        writeln("coucou2 l1=",l1);\r
 322       End option;\r
 323 \r
 324       Unit Affiche : procedure;\r
 325       Var i,j,k :integer;\r
 326       Begin\r
 327        call father.rectanglef(x1,y1,x2,y2,cfond);\r
 328        for i:=0 to lborder\r
 329         do\r
 330          call father.rectangle(x1+i,y1+i,x2-i,y2-i,cborder);\r
 331         od;\r
 332        i:=y1+lborder+1;\r
 333        call father.rectanglef(x1+lborder+1,i,x2-lborder-1,i+imax(14,lbande),cfbande);\r
 334        j:=(x2-x1-2*lborder-8*(upper(nombande)-lower(nombande)))/2;\r
 335        for i:=lower(nombande) to upper(nombande)\r
 336         do\r
 337          k:=x1+lborder+j+i*8;\r
 338          call father.outxyascii(k,y1+lborder+2,ord(nombande(i)),cbbande,cfbande);\r
 339         od;\r
 340         call affichesuite;\r
 341         if(barcde<>none)\r
 342         then call barcde.affichemenu;\r
 343         fi\r
 344       End Affiche;\r
 345 \r
 346       Unit virtual affichesuite :procedure;\r
 347       End affichesuite;\r
 348 \r
 349       Unit virtual rectangle : procedure(xx1,yy1,xx2,yy2,c :integer);\r
 350       End rectangle;\r
 351 \r
 352       Unit virtual rectanglef : procedure(xx1,yy1,xx2,yy2,c : integer);\r
 353       End rectanglef;\r
 354 \r
 355       Unit virtual outxyascii : procedure(x,y,car,cf,cb : integer);\r
 356       End outxyascii;\r
 357 \r
 358       Unit virtual outxytext : procedure(x,y:integer,chaine:string,c1,c2:integer);\r
 359       End outxytext;\r
 360 \r
 361    Begin\r
 362     hauteur:=y2-y1-2*lborder;\r
 363     largeur:=x2-x1-2*lborder;\r
 364    End Windows;\r
 365 \r
 366    Unit Bitmap : Windows Class;\r
 367    End Bitmap;\r
 368 \r
 369    Unit Son : Windows Class;\r
 370    End Son;\r
 371 \r
 372    Unit Maine : Windows Class;\r
 373    End Maine;\r
 374 \r
 375    Unit Dialogue : Son Class;\r
 376    End Dialogue;\r
 377 \r
 378    Unit Catalogue : Dialogue Class;\r
 379    End Catalogue;\r
 380 \r
 381    Unit Question : Dialogue Class;\r
 382    End Question;\r
 383 \r
 384    Unit Widgets : Ptr Class(father : windows);\r
 385    End Widgets;\r
 386 \r
 387    (**********************************************************************)\r
 388    Unit Menu : Widgets Class(x,y,col_e,col_f: integer);\r
 389    Var liste : ensemble;\r
 390 \r
 391     Unit item : element class(nom : string,key : integer,suite :Menu);\r
 392     End item;\r
 393 \r
 394     Unit insert : procedure(nom : string,key : integer,s : menu);\r
 395     var e : item;\r
 396     Begin\r
 397       e:=new item(nom,key,s);\r
 398       if(liste=none)\r
 399       then liste:=new ensemble;\r
 400       fi;\r
 401       call liste.insert(e);\r
 402     End insert;\r
 403 \r
 404     Unit virtual affichemenu : procedure;\r
 405     End affichemenu;\r
 406 \r
 407    End Menu;\r
 408 \r
 409    Unit Menu_V : Menu Class;\r
 410 \r
 411     Unit  virtual affichemenu : procedure;\r
 412     Var cour  : item,\r
 413         tlen  : arrayof char,\r
 414         len   : integer,\r
 415         xx,yy : integer;\r
 416     Begin\r
 417      call liste.initialise;\r
 418      xx:=x; yy:=y;\r
 419      if(liste.getelm(cour))\r
 420      then while(cour<>none)\r
 421            do\r
 422             call father.outxytext(xx,yy,cour.nom,col_e,col_f);\r
 423             tlen:=unpack(cour.nom);\r
 424             len:=upper(tlen)-lower(tlen)+1;\r
 425             kill(tlen);\r
 426             if(father.ListM=none)\r
 427             then father.ListM:=new LClic;\r
 428             fi;\r
 429             call father.ListM.insert(new elm_c(0 ,xx,yy,xx+len*8,yy+14));\r
 430                                            (* id *)\r
 431             yy:=yy+20;\r
 432             if not liste.getelm(cour)\r
 433             then exit\r
 434             fi\r
 435            od\r
 436      fi\r
 437     End affichemenu;\r
 438 \r
 439    End Menu_V;\r
 440 \r
 441    Unit Menu_H : Menu Class;\r
 442    End Menu_H;\r
 443 \r
 444    Unit Bottons : Widgets Class;\r
 445    End Bottons;\r
 446 \r
 447    Unit Racc : Bottons Class;\r
 448    End Racc;\r
 449 \r
 450    Unit Opt_list : Bottons Class;\r
 451    End Opt_list;\r
 452 \r
 453    Unit Oneline : Opt_list Class;\r
 454    End Oneline;\r
 455 \r
 456    Unit Multiline : Opt_list Class;\r
 457    End Multiline;\r
 458 \r
 459    Unit Botton : Bottons Class;\r
 460    End Botton;\r
 461 \r
 462    Unit Lift : Widgets Class;\r
 463    End Lift;\r
 464 \r
 465    Unit Lift_V : Lift Class;\r
 466    End Lift_V;\r
 467 \r
 468    Unit Lift_H : Lift Class;\r
 469    End Lift_H;\r
 470 \r
 471    (*****************************************************************************)\r
 472    (*          deuxieme famille de classes : les structures de donnees          *)\r
 473    (*****************************************************************************)\r
 474    Unit element : class;  (* general *)\r
 475    End element;\r
 476 \r
 477    Unit elm_c : element class(id,x1,y1,x2,y2 : integer); (* listclic *)\r
 478    End elm_c;\r
 479 \r
 480    Unit elm_a : element class(p : Applications);  (* liste application *)\r
 481    End elm_a;\r
 482 \r
 483 \r
 484    Unit Ensemble : CLass;\r
 485    Var root,last : node,\r
 486        courant   : node;\r
 487 \r
 488     Unit node : class(elm : element);\r
 489     Var next : node;\r
 490     End node;\r
 491 \r
 492     Unit virtual insert : procedure(e : element);\r
 493     Begin\r
 494      if not member(e)\r
 495      then if empty\r
 496           then root:=new node(e);\r
 497                last:=root;\r
 498           else last.next:=new node(e);\r
 499                last:=last.next;\r
 500           fi\r
 501      fi\r
 502     End insert;\r
 503 \r
 504     Unit virtual delete : procedure(e : element);\r
 505     Var flag : node;\r
 506     Begin\r
 507      if member(e)\r
 508      then flag:=courant.next;\r
 509           if flag=last\r
 510           then last:=courant;\r
 511                courant.next:=none;\r
 512                kill(flag);\r
 513           else if courant.next<>none\r
 514                then courant.next:=courant.next.next;\r
 515                     kill(flag);\r
 516                fi\r
 517           fi\r
 518      fi\r
 519     End delete;\r
 520 \r
 521     Unit virtual member : function (e : element) : boolean;\r
 522     Var  savecou : node,\r
 523          bl : boolean;\r
 524     Begin\r
 525      courant:=root;\r
 526      savecou:=courant;\r
 527      bl:=false;\r
 528      while(courant<>none)\r
 529       do\r
 530        if not egalite(courant.elm,e)\r
 531        then savecou:=courant;\r
 532             courant:=courant.next;\r
 533        else bl:=true;\r
 534             exit;\r
 535        fi\r
 536       od;\r
 537       courant:=savecou;\r
 538       result:=bl;\r
 539     End member;\r
 540 \r
 541     Unit virtual egalite : function (e1,e2 :element) :boolean;\r
 542     End egalite;\r
 543 \r
 544     Unit empty : function : boolean;\r
 545     Begin\r
 546      result:=(root=none);\r
 547     End empty;\r
 548 \r
 549     Unit initialise : procedure;\r
 550     Begin\r
 551      courant:=root;\r
 552     End initialise;\r
 553 \r
 554     Unit getelm : function(output e : element) :boolean;\r
 555     Begin\r
 556      if(courant<>none)\r
 557      then e:=courant.elm;\r
 558           result:=true;\r
 559           courant:=courant.next;\r
 560      else result:=false;\r
 561      fi\r
 562     End getelm;\r
 563 \r
 564    End Ensemble;\r
 565 \r
 566    Unit Queue : Ensemble Class;\r
 567    End Queue;\r
 568 \r
 569    Unit Ofpriority : Queue Class;\r
 570    End Ofpriority;\r
 571 \r
 572    Unit ListD : Ensemble Class;\r
 573    End ListD;\r
 574 \r
 575    Unit LClic : ListD Class;\r
 576 \r
 577     Unit virtual egalite : function (e1,e2 :element) :boolean;\r
 578     Begin\r
 579      if (e1 qua elm_c.x1=e2 qua elm_c.x1 and e1 qua elm_c.x2=e2 qua elm_c.x2\r
 580          and e1 qua elm_c.y1=e2 qua elm_c.y1 and e1 qua elm_c.y2=e2 qua elm_c.y2)\r
 581      then result:=TRUE;\r
 582      else result:=FALSE;\r
 583      fi\r
 584     End egalite;\r
 585 \r
 586     Unit appartient : function (x,y : integer) : boolean;\r
 587     Var e : elm_c,\r
 588         b : boolean;\r
 589     Begin\r
 590      call initialise;\r
 591      b:=false;\r
 592      while(getelm(e))\r
 593       do\r
 594        if (x>=e.x1 and x<=e.x2 and y>=e.y1 and y<=e.y2)\r
 595        then  b:=TRUE;\r
 596              exit;\r
 597        fi\r
 598       od;\r
 599      result:=b;\r
 600     End appartient;\r
 601 \r
 602    End LClic;\r
 603 \r
 604    Unit LBot : ListD Class;\r
 605    End LBot;\r
 606 \r
 607    Unit LAppli : ListD Class;\r
 608    End LAppli;\r
 609 \r
 610    Unit LKey : ListD Class;\r
 611    End LKey;\r
 612 \r
 613    Unit LWin : ListD Class;\r
 614    End LWin;\r
 615 \r
 616    Unit Stack : Ensemble Class;\r
 617    End Stack;\r
 618 \r
 619 \r
 620    (*****************************************************************************)\r
 621    (*                           Famille de process                              *)\r
 622    (*****************************************************************************)\r
 623    Unit Applications : proces class(x1,y1,x2,y2 : integer,father : Gest_Wind);\r
 624    Var w      : windows, (* maine *)\r
 625        Filles : windows, (* son *)\r
 626        i      : integer;\r
 627 \r
 628     Unit virtual gestionnaire : procedure(id : integer);\r
 629     Begin\r
 630     End gestionnaire;\r
 631 \r
 632    Begin\r
 633       writeln("coucou");\r
 634       w:=new windows(father.getw,x1,y1,x2,y2);\r
 635      return;\r
 636       writeln("toto");\r
 637       call w.option(Noir,3,VertClair,15,VertCLair,Noir,unpack("nom"));\r
 638       call w.affiche;\r
 639 \r
 640       do\r
 641          call Arbitrage;\r
 642       od;\r
 643    End Applications;\r
 644 \r
 645   (************************************************************************)\r
 646   (************************************************************************)\r
 647    Unit Gest_event : proces class(gest : gest_wind);\r
 648 \r
 649     Unit ready : procedure;\r
 650     Begin\r
 651        writeln("Gest_events READY");\r
 652     End ready;\r
 653 \r
 654     Unit souris: Mouse coroutine;\r
 655     begin\r
 656        call init(1,1);\r
 657        return;\r
 658 \r
 659 (* ici on peut mettre la fermeture de la souris *)\r
 660     End souris;\r
 661 \r
 662     Var myszka: souris;\r
 663 \r
 664     Unit event : function(output v,h,p,l,r,c : integer) : boolean;\r
 665     Begin\r
 666      result:=myszka.getpress(v,h,p,l,r,c);\r
 667     End;\r
 668 \r
 669    Var i :integer,\r
 670        v,h,p,l,r,c : integer;\r
 671    Begin\r
 672       myszka := new souris;\r
 673       (* accept ready; *)\r
 674 (*      call init(1,1);  *)\r
 675       call myszka.showcursor;\r
 676       return;\r
 677       do\r
 678        if event(v,h,p,l,r,c)\r
 679        then\r
 680          call gest.event(v,h,p,l,r,c);\r
 681        fi;\r
 682        call Arbitrage;\r
 683       od;\r
 684    End Gest_event;\r
 685 \r
 686   (***********************************************************************)\r
 687   (***********************************************************************)\r
 688    Unit Gest_wind :  proces class(x1,y1,x2,y2 : integer,gest:gest_event);\r
 689    Var i,k :integer,\r
 690        v,p,h,l,r,c : integer,\r
 691        ListK       : LKey,\r
 692        ListM       : LClic,\r
 693        ListA       : LAppli,\r
 694        w           : windows,\r
 695        j           : graph;\r
 696 \r
 697 \r
 698     Unit getinfo : procedure (g : gest_event);\r
 699     Begin\r
 700      gest:=g;\r
 701      disable getinfo;\r
 702      writeln("getinfo");\r
 703     End getinfo;\r
 704 \r
 705     Unit event : procedure (input lv,lh,lp,ll,lr,lc : integer);\r
 706     Begin\r
 707      v:=lv; h:=lh; p:=lp; l:=ll; r:=lr; c:=lc;\r
 708     End event;\r
 709 \r
 710     Unit traitement : procedure;\r
 711     Begin\r
 712      if((h=164 and l=27) or   c=3)\r
 713      then call fin;\r
 714      fi;\r
 715 \r
 716      (* recherche dans un arbre des fenetres filles si l'evenement *)\r
 717      (* appartient a qqn                                           *)\r
 718 \r
 719 \r
 720 \r
 721     End traitement;\r
 722 \r
 723     Unit fin : procedure;\r
 724     begin\r
 725 (*     call groff;   *)\r
 726      attach (j.gr);         (* pour terminer iiuwgraph *)\r
 727      writeln("on ferme");\r
 728      call endrun;\r
 729     End fin;\r
 730 \r
 731   (***********************************************************************)\r
 732     Unit graph : windows class;\r
 733      \r
 734      unit graphi: iiuwgraph coroutine;\r
 735      begin\r
 736         call gron(0);  \r
 737         return;\r
 738 \r
 739      end graphi;\r
 740 \r
 741      var gr: graphi;\r
 742 \r
 743      Unit virtual rectangle : procedure (x1,y1,x2,y2,c : integer);\r
 744      Begin\r
 745       call gr.patern(x1,y1,x2,y2,c,0);\r
 746      End rectangle;\r
 747 \r
 748      Unit virtual rectanglef : procedure (x1,y1,x2,y2,c : integer);\r
 749      Begin\r
 750       writeln("coucou3 x1=",x1,"x2=",x2,"y1=",y1,"y2=",y2,"c=",c);\r
 751       if gr=none then writeln("NONE!") fi;\r
 752        call gr.patern(x1,y1,x2,y2,c,1);\r
 753 \r
 754      End rectanglef;\r
 755 \r
 756      Unit virtual ligne : procedure (x1,y1,x2,y2,c : integer);\r
 757      Begin\r
 758       call gr.color(c);\r
 759       call gr.move(x1,y1);\r
 760       call gr.draw(x2,y2);\r
 761      End ligne;\r
 762 \r
 763      Unit virtual outxyascii : procedure (x,y,car,cf,cb :integer);\r
 764      Begin\r
 765       call gr.move(x,y);\r
 766       call gr.color(cf);\r
 767       call gr.border(cb);\r
 768       call gr.hascii(car);\r
 769      End outxyascii;\r
 770 \r
 771      Unit virtual outxytext : procedure (x,y :integer, chaine :string,c1,c2 :integer);\r
 772      Begin\r
 773       call gr.outstring(x,y,chaine,c1,c2);\r
 774      End outxytext;\r
 775 \r
 776      Unit virtual affichesuite : procedure;\r
 777      Var x,y : integer;\r
 778      Begin\r
 779       x:=x1+100-lborder; y:=y1+lbande+lborder+1;\r
 780       call rectanglef(x,y,x+lborder,y2-lborder-1,cborder);\r
 781       x:=x+lborder; y:=y2-100-lborder;\r
 782       call rectanglef(x,y,x2-lborder,y+lborder,cborder);\r
 783       xdeb:=x1+100+10;\r
 784       ydeb:=y1+lborder+lbande+10;\r
 785      End affichesuite;\r
 786     begin\r
 787          gr := none;\r
 788  (*      gr := new graphi;   *)\r
 789     End graph;\r
 790 \r
 791     Unit initialisation1 : procedure;\r
 792     Var itermed1 : menu_v,\r
 793         i,j : integer;\r
 794     Begin\r
 795       i:=w.lborder+10+20; j:=y1+w.lborder+10+w.lbande+20*4;\r
 796       itermed1:=new menu_V(w.father,i,j,Blanc,GrisFonce);\r
 797       call itermed1.insert("Nouveau",319,none);\r
 798       call itermed1.insert("Ouvrir",320,none);\r
 799       call itermed1.insert("D\82placer",321,none);\r
 800       call itermed1.insert("Copier",322,none);\r
 801       call itermed1.insert("Supprimer",323,none);\r
 802       call itermed1.insert("Propri\82t\82",324,none);\r
 803       i:=w.lborder+10; j:=y1+w.lborder+10+w.lbande;\r
 804       w.barcde:=new menu_V(w.father,i,j,Blanc,GrisFonce);\r
 805       call w.barcde.insert("Fichier",315,itermed1);\r
 806       call w.barcde.insert("Options",316,none);\r
 807       call w.barcde.insert("Fenetre",317,none);\r
 808       call w.barcde.insert("Aide",318,none);\r
 809     End initialisation1;\r
 810 \r
 811     Unit initialisation2 : procedure;\r
 812     Begin\r
 813      ListA:=new LAppli;\r
 814     End initialisation2;\r
 815 \r
 816     Unit xdeb :  function : integer;\r
 817     Begin\r
 818      result:=w.xdeb;\r
 819     End xdeb;\r
 820 \r
 821     Unit ydeb : function : integer;\r
 822     Begin\r
 823      result:=w.ydeb;\r
 824     End ydeb;\r
 825 \r
 826     Unit getw : function : windows;\r
 827     Begin\r
 828      result:=w;\r
 829     End getw;\r
 830 \r
 831 \r
 832    Begin\r
 833       call gron(0 );  (* 3 = 1024x768x256 *)\r
 834       j:=new graph(none,x1,y1,x2,y2);\r
 835       w:=new windows(j,x1,y1,x2,y2);\r
 836 \r
 837       call w.option(Grisfonce,3,BleuClair,15,BleuCLair,Blanc,unpack("Gest_Wind"));\r
 838       call initialisation1;\r
 839       call w.affiche;\r
 840 \r
 841       call J.option(Grisfonce,3,BleuClair,15,BleuCLair,Blanc,unpack("Gest_Wind"));\r
 842       call j.affichesuite;\r
 843    (* accept getinfo;  *)\r
 844 (*      enable xdeb,ydeb,getw;  *)\r
 845 (*      call gest.ready;        *)\r
 846       call initialisation2;\r
 847       return;\r
 848 \r
 849       do\r
 850    (*  accept event;  *)\r
 851        call traitement;\r
 852        call Arbitrage;\r
 853       od;\r
 854   (*    call groff;  *)\r
 855       attach(j.gr);\r
 856    End Gest_wind;\r
 857 \r
 858 \r
 859 (*****************************************************************************)\r
 860 (*                   P r o g r a m  m e   P r i n c i p a l                  *)\r
 861 (*****************************************************************************)\r
 862 Var i  : integer,\r
 863     G1 : Gest_wind,\r
 864     Z1 : applications,\r
 865     G2 : Gest_event,\r
 866     x,y :integer;\r
 867 \r
 868 Begin\r
 869    active:= new set;\r
 870    suspended :=new set;\r
 871    G1:=new Gest_wind(0,0,640,480,none);\r
 872    G2:=new Gest_event(G1);\r
 873    call resumep(G1);\r
 874    call resumep(G2);  \r
 875    call G1.getinfo(G2);\r
 876 \r
 877    x:=G1.w.xdeb;\r
 878    writeln("x=",x);\r
 879    y:=G1.w.ydeb;\r
 880    writeln("y=",y);\r
 881    Z1:=new applications(x+10,y+10,x+330,y+210,G1);\r
 882 \r
 883 \r
 884    call G1.ListA.insert(new elm_a(Z1));\r
 885    call resumep(Z1);\r
 886    call Arbitrage;\r
 887    writeln("Dobro doszli");\r
 888 end\r
 889 End.\r
 890 \r
 891 \r
 892 \r
 893 \r
 894 \r
 895 \r
 896 \r
 897 \r