examples/pataud/new2.log

   1 Program SystemedeFenetrage;\r
   2 \r
   3 Const Noir        =0,Bleu          =1,Vert        =2,Cyan          =3,\r
   4       Rouge       =4,Magenta       =5,Marron      =6,GrisCLair     =7,\r
   5       GrisFonce   =8,BleuClair     =9,VertClair  =10,CyanClair    =11,\r
   6       RougeClair =12,MagentaClair =13,Jaune      =14,Blanc        =15;\r
   7 \r
   8 \r
   9 \r
  10    (*****************************************************************************)\r
  11    (*             premiere famille de classes : les classes graphiques          *)\r
  12    (*****************************************************************************)\r
  13    Unit Ptr : Class;\r
  14    End Ptr;\r
  15 \r
  16    Unit Windows : Ptr Class(father :windows,x1,y1,x2,y2 : integer);\r
  17    Close hauteur,largeur;\r
  18    Var lborder,cfond,cborder : integer,\r
  19        lbande,cfbande,cbbande : integer,\r
  20       hauteur,largeur       : integer,\r
  21       xpos,ypos,xmax,ymax   : integer,\r
  22       xdeb,ydeb             : integer,\r
  23       num_id                : integer,\r
  24       ListM                 : Lclic,\r
  25       ListK                 : LKey,\r
  26       nombande              : arrayof char,\r
  27       barcde                : menu,\r
  28       save_map              : arrayof integer;\r
  29 \r
  30       Unit option : procedure (l1,l2,l3,l4,l5,l6 : integer,l7 : arrayof char);\r
  31       Begin\r
  32        cfond:=l1; lborder:=l2; cborder:=l3; lbande:=l4;\r
  33        cfbande:=l5; cbbande:=l6;\r
  34        nombande:=copy(l7);\r
  35       End option;\r
  36 \r
  37       Unit Affiche : procedure;\r
  38       Var i,j,k :integer;\r
  39       Begin\r
  40        call father.rectanglef(x1,y1,x2,y2,cfond);\r
  41        for i:=0 to lborder\r
  42         do\r
  43          call father.rectangle(x1+i,y1+i,x2-i,y2-i,cborder);\r
  44         od;\r
  45        i:=y1+lborder+1;\r
  46        call father.rectanglef(x1+lborder+1,i,x2-lborder-1,i+imax(14,lbande),cfbande);\r
  47        j:=(x2-x1-2*lborder-8*(upper(nombande)-lower(nombande)))/2;\r
  48        for i:=lower(nombande) to upper(nombande)\r
  49         do\r
  50          k:=x1+lborder+j+i*8;\r
  51          call father.outxyascii(k,y1+lborder+2,ord(nombande(i)),cbbande,cfbande);\r
  52         od;\r
  53         call affichesuite;\r
  54         if(barcde<>none)\r
  55         then call barcde.affichemenu;\r
  56         fi\r
  57       End Affiche;\r
  58 \r
  59       Unit virtual affichesuite :procedure;\r
  60       End affichesuite;\r
  61 \r
  62       Unit virtual rectangle : procedure(xx1,yy1,xx2,yy2,c :integer);\r
  63       End rectangle;\r
  64 \r
  65       Unit virtual rectanglef : procedure(xx1,yy1,xx2,yy2,c : integer);\r
  66       End rectanglef;\r
  67 \r
  68       Unit virtual outxyascii : procedure(x,y,car,cf,cb : integer);\r
  69       End outxyascii;\r
  70 \r
  71       Unit virtual outxytext : procedure(x,y:integer,chaine:string,c1,c2:integer);\r
  72       End outxytext;\r
  73 \r
  74    Begin\r
  75     hauteur:=y2-y1-2*lborder;\r
  76     largeur:=x2-x1-2*lborder;\r
  77    End Windows;\r
  78 \r
  79    Unit Bitmap : Windows Class;\r
  80    End Bitmap;\r
  81 \r
  82    Unit Son : Windows Class;\r
  83    End Son;\r
  84 \r
  85    Unit Maine : Windows Class;\r
  86    End Maine;\r
  87 \r
  88    Unit Dialogue : Son Class;\r
  89    End Dialogue;\r
  90 \r
  91    Unit Catalogue : Dialogue Class;\r
  92    End Catalogue;\r
  93 \r
  94    Unit Question : Dialogue Class;\r
  95    End Question;\r
  96 \r
  97    Unit Widgets : Ptr Class(father : windows);\r
  98    End Widgets;\r
  99 \r
 100    (**********************************************************************)\r
 101    Unit Menu : Widgets Class(x,y,col_e,col_f: integer);\r
 102    Var liste : ensemble;\r
 103 \r
 104     Unit item : element class(nom : string,key : integer,suite :Menu);\r
 105     End item;\r
 106 \r
 107     Unit insert : procedure(nom : string,key : integer,s : menu);\r
 108     var e : item;\r
 109     Begin\r
 110       e:=new item(nom,key,s);\r
 111       if(liste=none)\r
 112       then liste:=new ensemble;\r
 113       fi;\r
 114       call liste.insert(e);\r
 115     End insert;\r
 116 \r
 117     Unit virtual affichemenu : procedure;\r
 118     End affichemenu;\r
 119 \r
 120    End Menu;\r
 121 \r
 122    Unit Menu_V : Menu Class;\r
 123 \r
 124     Unit  virtual affichemenu : procedure;\r
 125     Var cour  : item,\r
 126         tlen  : arrayof char,\r
 127         len   : integer,\r
 128         xx,yy : integer;\r
 129     Begin\r
 130      call liste.initialise;\r
 131      xx:=x; yy:=y;\r
 132      if(liste.getelm(cour))\r
 133      then while(cour<>none)\r
 134            do\r
 135             call father.outxytext(xx,yy,cour.nom,col_e,col_f);\r
 136             tlen:=unpack(cour.nom);\r
 137             len:=upper(tlen)-lower(tlen)+1;\r
 138             kill(tlen);\r
 139             if(father.ListM=none)\r
 140             then father.ListM:=new LClic;\r
 141             fi;\r
 142             call father.ListM.insert(new elm_c(0 ,xx,yy,xx+len*8,yy+14));\r
 143                                            (* id *)\r
 144             yy:=yy+20;\r
 145             if not liste.getelm(cour)\r
 146             then exit\r
 147             fi\r
 148            od\r
 149      fi\r
 150     End affichemenu;\r
 151 \r
 152    End Menu_V;\r
 153 \r
 154    Unit Menu_H : Menu Class;\r
 155    End Menu_H;\r
 156 \r
 157    Unit Bottons : Widgets Class;\r
 158    End Bottons;\r
 159 \r
 160    Unit Racc : Bottons Class;\r
 161    End Racc;\r
 162 \r
 163    Unit Opt_list : Bottons Class;\r
 164    End Opt_list;\r
 165 \r
 166    Unit Oneline : Opt_list Class;\r
 167    End Oneline;\r
 168 \r
 169    Unit Multiline : Opt_list Class;\r
 170    End Multiline;\r
 171 \r
 172    Unit Botton : Bottons Class;\r
 173    End Botton;\r
 174 \r
 175    Unit Lift : Widgets Class;\r
 176    End Lift;\r
 177 \r
 178    Unit Lift_V : Lift Class;\r
 179    End Lift_V;\r
 180 \r
 181    Unit Lift_H : Lift Class;\r
 182    End Lift_H;\r
 183 \r
 184    (*****************************************************************************)\r
 185    (*          deuxieme famille de classes : les structures de donnees          *)\r
 186    (*****************************************************************************)\r
 187    Unit element : class;  (* general *)\r
 188    End element;\r
 189 \r
 190    Unit elm_c : element class(id,x1,y1,x2,y2 : integer); (* listclic *)\r
 191    End elm_c;\r
 192 \r
 193    Unit elm_a : element class(p : Applications);  (* liste application *)\r
 194    End elm_a;\r
 195 \r
 196 \r
 197    Unit Ensemble : CLass;\r
 198    Var root,last : node,\r
 199        courant   : node;\r
 200 \r
 201     Unit node : class(elm : element);\r
 202     Var next : node;\r
 203     End node;\r
 204 \r
 205     Unit virtual insert : procedure(e : element);\r
 206     Begin\r
 207      if not member(e)\r
 208      then if empty\r
 209           then root:=new node(e);\r
 210                last:=root;\r
 211           else last.next:=new node(e);\r
 212                last:=last.next;\r
 213           fi\r
 214      fi\r
 215     End insert;\r
 216 \r
 217     Unit virtual delete : procedure(e : element);\r
 218     Var flag : node;\r
 219     Begin\r
 220      if member(e)\r
 221      then flag:=courant.next;\r
 222           if flag=last\r
 223           then last:=courant;\r
 224                courant.next:=none;\r
 225                kill(flag);\r
 226           else if courant.next<>none\r
 227                then courant.next:=courant.next.next;\r
 228                     kill(flag);\r
 229                fi\r
 230           fi\r
 231      fi\r
 232     End delete;\r
 233 \r
 234     Unit virtual member : function (e : element) : boolean;\r
 235     Var  savecou : node,\r
 236          bl : boolean;\r
 237     Begin\r
 238      courant:=root;\r
 239      savecou:=courant;\r
 240      bl:=false;\r
 241      while(courant<>none)\r
 242       do\r
 243        if not egalite(courant.elm,e)\r
 244        then savecou:=courant;\r
 245             courant:=courant.next;\r
 246        else bl:=true;\r
 247             exit;\r
 248        fi\r
 249       od;\r
 250       courant:=savecou;\r
 251       result:=bl;\r
 252     End member;\r
 253 \r
 254     Unit virtual egalite : function (e1,e2 :element) :boolean;\r
 255     End egalite;\r
 256 \r
 257     Unit empty : function : boolean;\r
 258     Begin\r
 259      result:=(root=none);\r
 260     End empty;\r
 261 \r
 262     Unit initialise : procedure;\r
 263     Begin\r
 264      courant:=root;\r
 265     End initialise;\r
 266 \r
 267     Unit getelm : function(output e : element) :boolean;\r
 268     Begin\r
 269      if(courant<>none)\r
 270      then e:=courant.elm;\r
 271           result:=true;\r
 272           courant:=courant.next;\r
 273      else result:=false;\r
 274      fi\r
 275     End getelm;\r
 276 \r
 277    End Ensemble;\r
 278 \r
 279    Unit Queue : Ensemble Class;\r
 280    End Queue;\r
 281 \r
 282    Unit Ofpriority : Queue Class;\r
 283    End Ofpriority;\r
 284 \r
 285    Unit ListD : Ensemble Class;\r
 286    End ListD;\r
 287 \r
 288    Unit LClic : ListD Class;\r
 289 \r
 290     Unit virtual egalite : function (e1,e2 :element) :boolean;\r
 291     Begin\r
 292      if (e1 qua elm_c.x1=e2 qua elm_c.x1 and e1 qua elm_c.x2=e2 qua elm_c.x2\r
 293          and e1 qua elm_c.y1=e2 qua elm_c.y1 and e1 qua elm_c.y2=e2 qua elm_c.y2)\r
 294      then result:=TRUE;\r
 295      else result:=FALSE;\r
 296      fi\r
 297     End egalite;\r
 298 \r
 299     Unit appartient : function (x,y : integer) : boolean;\r
 300     Var e : elm_c,\r
 301         b : boolean;\r
 302     Begin\r
 303      call initialise;\r
 304      b:=false;\r
 305      while(getelm(e))\r
 306       do\r
 307        if (x>=e.x1 and x<=e.x2 and y>=e.y1 and y<=e.y2)\r
 308        then  b:=TRUE;\r
 309              exit;\r
 310        fi\r
 311       od;\r
 312      result:=b;\r
 313     End appartient;\r
 314 \r
 315    End LClic;\r
 316 \r
 317    Unit LBot : ListD Class;\r
 318    End LBot;\r
 319 \r
 320    Unit LAppli : ListD Class;\r
 321    End LAppli;\r
 322 \r
 323    Unit LKey : ListD Class;\r
 324    End LKey;\r
 325 \r
 326    Unit LWin : ListD Class;\r
 327    End LWin;\r
 328 \r
 329    Unit Stack : Ensemble Class;\r
 330    End Stack;\r
 331 \r
 332 \r
 333    (*****************************************************************************)\r
 334    (*                           Famille de process                              *)\r
 335    (*****************************************************************************)\r
 336    Unit Applications : process (node,x1,y1,x2,y2 : integer,father : Gest_Wind);\r
 337    Var w      : windows, (* maine *)\r
 338        Filles : windows, (* son *)\r
 339        i      : integer;\r
 340 \r
 341     Unit virtual gestionnaire : procedure(id : integer);\r
 342     Begin\r
 343     End gestionnaire;\r
 344 \r
 345    Begin\r
 346       writeln("coucou");\r
 347       w:=new windows(father.getw,x1,y1,x2,y2);\r
 348      return;\r
 349       writeln("toto");\r
 350       call w.option(Noir,3,VertClair,15,VertCLair,Noir,unpack("nom"));\r
 351       call w.affiche;\r
 352       do\r
 353       od;\r
 354    End Applications;\r
 355 \r
 356   (************************************************************************)\r
 357   (************************************************************************)\r
 358    Unit Gest_event : mouse process (node : integer,gest : gest_wind);\r
 359 \r
 360     Unit ready : procedure;\r
 361     End ready;\r
 362 \r
 363     Unit event : function(output v,h,p,l,r,c : integer) : boolean;\r
 364     Begin\r
 365      result:=getpress(v,h,p,l,r,c);\r
 366     End;\r
 367 \r
 368    Var i :integer,\r
 369        v,h,p,l,r,c : integer;\r
 370    Begin\r
 371       return;\r
 372       accept ready;\r
 373       call init(1,1);\r
 374       call showcursor;\r
 375       do\r
 376        if(event(v,h,p,l,r,c))\r
 377        then call gest.event(v,h,p,l,r,c);\r
 378        fi;\r
 379       od\r
 380    End Gest_event;\r
 381 \r
 382   (***********************************************************************)\r
 383   (***********************************************************************)\r
 384    Unit Gest_wind : iiuwgraph process(node,x1,y1,x2,y2 : integer,gest:gest_event);\r
 385    Var i,k :integer,\r
 386        v,p,h,l,r,c : integer,\r
 387        ListK       : LKey,\r
 388        ListM       : LClic,\r
 389        ListA       : LAppli,\r
 390        w           : windows,\r
 391        j           : graph;\r
 392 \r
 393 \r
 394     Unit getinfo : procedure (g : gest_event);\r
 395     Begin\r
 396      gest:=g;\r
 397      disable getinfo;\r
 398      writeln("getinfo");\r
 399     End getinfo;\r
 400 \r
 401     Unit event : procedure (input lv,lh,lp,ll,lr,lc : integer);\r
 402     Begin\r
 403      v:=lv; h:=lh; p:=lp; l:=ll; r:=lr; c:=lc;\r
 404     End event;\r
 405 \r
 406     Unit traitement : procedure;\r
 407     Begin\r
 408      if((h=164 and l=27) or   c=3)\r
 409      then call fin;\r
 410      fi;\r
 411 \r
 412      (* recherche dans un arbre des fenetres filles si l'evenement *)\r
 413      (* appartient a qqn                                           *)\r
 414 \r
 415 \r
 416 \r
 417     End traitement;\r
 418 \r
 419     Unit fin : procedure;\r
 420     begin\r
 421      call groff;\r
 422      writeln("on ferme");\r
 423      call endrun;\r
 424     End fin;\r
 425 \r
 426   (***********************************************************************)\r
 427     Unit graph : windows class;\r
 428 \r
 429      Unit virtual rectangle : procedure (x1,y1,x2,y2,c : integer);\r
 430      Begin\r
 431       call patern(x1,y1,x2,y2,c,0);\r
 432      End rectangle;\r
 433 \r
 434      Unit virtual rectanglef : procedure (x1,y1,x2,y2,c : integer);\r
 435      Begin\r
 436       call patern(x1,y1,x2,y2,c,1);\r
 437      End rectanglef;\r
 438 \r
 439      Unit virtual ligne : procedure (x1,y1,x2,y2,c : integer);\r
 440      Begin\r
 441       call color(c);\r
 442       call move(x1,y1);\r
 443       call draw(x2,y2);\r
 444      End ligne;\r
 445 \r
 446      Unit virtual outxyascii : procedure (x,y,car,cf,cb :integer);\r
 447      Begin\r
 448       call move(x,y);\r
 449       call color(cf);\r
 450       call border(cb);\r
 451       call hascii(car);\r
 452      End outxyascii;\r
 453 \r
 454      Unit virtual outxytext : procedure (x,y :integer, chaine :string,c1,c2 :integer);\r
 455      Begin\r
 456       call outstring(x,y,chaine,c1,c2);\r
 457      End outxytext;\r
 458 \r
 459      Unit virtual affichesuite : procedure;\r
 460      Var x,y : integer;\r
 461      Begin\r
 462       x:=x1+100-lborder; y:=y1+lbande+lborder+1;\r
 463       call rectanglef(x,y,x+lborder,y2-lborder-1,cborder);\r
 464       x:=x+lborder; y:=y2-100-lborder;\r
 465       call rectanglef(x,y,x2-lborder,y+lborder,cborder);\r
 466       xdeb:=x1+100+10;\r
 467       ydeb:=y1+lborder+lbande+10;\r
 468      End affichesuite;\r
 469 \r
 470     End graph;\r
 471 \r
 472     Unit initialisation1 : procedure;\r
 473     Var itermed1 : menu_v,\r
 474         i,j : integer;\r
 475     Begin\r
 476       i:=w.lborder+10+20; j:=y1+w.lborder+10+w.lbande+20*4;\r
 477       itermed1:=new menu_V(w.father,i,j,Blanc,GrisFonce);\r
 478       call itermed1.insert("Nouveau",319,none);\r
 479       call itermed1.insert("Ouvrir",320,none);\r
 480       call itermed1.insert("D\82placer",321,none);\r
 481       call itermed1.insert("Copier",322,none);\r
 482       call itermed1.insert("Supprimer",323,none);\r
 483       call itermed1.insert("Propri\82t\82",324,none);\r
 484       i:=w.lborder+10; j:=y1+w.lborder+10+w.lbande;\r
 485       w.barcde:=new menu_V(w.father,i,j,Blanc,GrisFonce);\r
 486       call w.barcde.insert("Fichier",315,itermed1);\r
 487       call w.barcde.insert("Options",316,none);\r
 488       call w.barcde.insert("Fenetre",317,none);\r
 489       call w.barcde.insert("Aide",318,none);\r
 490     End initialisation1;\r
 491 \r
 492     Unit initialisation2 : procedure;\r
 493     Begin\r
 494      ListA:=new LAppli;\r
 495     End initialisation2;\r
 496 \r
 497     Unit xdeb :  function : integer;\r
 498     Begin\r
 499      result:=w.xdeb;\r
 500     End xdeb;\r
 501 \r
 502     Unit ydeb : function : integer;\r
 503     Begin\r
 504      result:=w.ydeb;\r
 505     End ydeb;\r
 506 \r
 507     Unit getw : function : windows;\r
 508     Begin\r
 509      result:=w;\r
 510     End getw;\r
 511 \r
 512 \r
 513    Begin\r
 514       call gron(0 );  (* 3 = 1024x768x256 *)\r
 515       j:=new graph(none,x1,y1,x2,y2);\r
 516       w:=new windows(j,x1,y1,x2,y2);\r
 517       call w.option(Grisfonce,3,BleuClair,15,BleuCLair,Blanc,unpack("Gest_Wind"));\r
 518       call initialisation1;\r
 519       call w.affiche;\r
 520       call J.option(Grisfonce,3,BleuClair,15,BleuCLair,Blanc,unpack("Gest_Wind"));\r
 521       call j.affichesuite;\r
 522       return;\r
 523       accept getinfo;\r
 524       enable xdeb,ydeb,getw;\r
 525       call gest.ready;\r
 526       call initialisation2;\r
 527       do\r
 528        accept event;\r
 529        call traitement;\r
 530       od;\r
 531       call groff;\r
 532    End Gest_wind;\r
 533 \r
 534 \r
 535 (*****************************************************************************)\r
 536 (*                   P r o g r a m  m e   P r i n c i p a l                  *)\r
 537 (*****************************************************************************)\r
 538 Var i  : integer,\r
 539     G1 : Gest_wind,\r
 540     Z1 : applications,\r
 541     G2 : Gest_event,\r
 542     x,y :integer;\r
 543 Begin\r
 544    G1:=new Gest_wind(0,0,0,640,480,none);\r
 545    G2:=new Gest_event(0,G1);\r
 546    resume(G1);\r
 547    resume(G2);\r
 548    call G1.getinfo(G2);\r
 549 \r
 550    x:=G1.xdeb;\r
 551    writeln("x=",x);\r
 552    y:=G1.ydeb;\r
 553    writeln("y=",y);\r
 554    Z1:=new applications(0,x+10,y+10,x+330,y+210,G1);\r
 555 \r
 556 \r
 557    call G1.ListA.insert(new elm_a(Z1));\r
 558    resume(Z1);\r
 559 End.\r
 560 \r
 561 \r
 562 \r
 563 \r
 564 \r
 565 \r
 566 \r
 567 \r