Program systemefenetrage; (***************************************************************************) (* Programme de systŠme de fenetrage avec boutons et gestion de la souris *) (* PATAUD Fr‚d‚ric & PEYRAT Fran‡ois 1993/1994 *) (***************************************************************************) Begin Pref iiuwgraph block Begin Pref mouse block Const Noir = 0, Bleu = 1, Vert = 2, Cyan = 3, Rouge = 4, Magenta = 5, Marron = 6, GrisClair = 7, GrisFonce = 8, BleuClair = 9, VertClair =10, CyanClair =11, RougeClair =12, MagentaClair=13, Jaune =14, Blanc =15; Const Touche_F1 =-59, Touche_F2 =-60, Touche_F3 =-61, Touche_F4 =-62, Touche_F5 =-63, Touche_F6 =-64, Touche_F7 =-65, Touche_F8 =-66, Touche_F9 =-67, Touche_F10 =-68, Touche_F11 =-69, Touche_F12 =-70; Const SIZEX = 639, SIZEY = 348; Var code : integer, COOR_X : integer, (*coordonn‚e relative en X dans la fenetre maine*) COOR_Y : integer, (*coordonn‚e relative en Y dans la fenetre maine*) W : Maine, B : arrayof Racc, M : arrayof Menu, clics : cliquer; (***************************************************************************) (* definition des procedures d'utilitaires graphiques *) (***************************************************************************) Unit Line : procedure (x1,y1,x2,y2,c : integer); Begin call color(c); call move(x1,y1); call draw(x2,y2); End Line; Unit Rectangle : procedure (x1,y1,x2,y2,c : integer); Begin call color(c); call move(x1,y1); call draw(x2,y1); call draw(x2,y2); call draw(x1,y2); call draw(x1,y1); End Rectangle; Unit Rectanglef : procedure (x1,y1,x2,y2,c : integer); var i : integer; Begin for i:=y1 to y2 do call Line(x1,i,x2,i,c); od End Rectanglef; (***************************************************************************) (* definition des classes d'‚l‚ments des listes *) (***************************************************************************) Unit Elmt : class(id : integer); End Elmt; Unit elm : Elmt class(x1,y1,x2,y2 :integer); End elm; (***************************************************************************) (* definition de la classe Bottons *) (***************************************************************************) Unit Bottons : Elmt class(x1,y1,x2,y2 : integer); (* x2-x1 et y2-y1 doit au mini etre de 8*) (* x1,y1 : integer coordonn‚es du point haut gauche *) (* x2,y2 : integer coordonn‚es du point bas droit *) Var etat : boolean; (* true si bouton enable *) Unit affiche : procedure; Begin call Line(x1,y1,x2,y1,Blanc); (* Lignes en blanc *) call Line(x1,y1+1,x2-1,y1+1,Blanc); call Line(x1,y1,x1,y2,Blanc); call Line(x1+1,y1+2,x1+1,y2-1,Blanc); call Line(x1+1,y2,x2,y2,GrisFonce); (* Lignes en gris fonce *) call Line(x1+2,y2-1,x2,y2-1,GrisFonce); call Line(x2,y2,x2,y1+1,GrisFonce); call Line(x2-1,y2-1,x2-1,y1+2,GrisFonce); call Rectanglef(x1+2,y1+2,x2-2,y2-2,GrisClair); (* centre en gris *) call AfficheSuite; End affiche; Unit virtual AfficheSuite : procedure; End; Unit virtual bot_enable : procedure; End; Unit virtual bot_disable : procedure; End; End Bottons; (***************************************************************************) (* definition de la classe Menu derivant de Bottons *) (***************************************************************************) Unit Menu : Bottons class; Var cnom : integer, (* couleur du nom du bouton *) nom : string; (* nom du bouton *) Unit affiche_nom : procedure; Begin call move(x1+5,y1+(y2-y1)/4+1); call color(cnom); call outstring(nom); End affiche_nom; Unit virtual bot_enable : procedure; var e : elm; Begin cnom:=RougeClair; e:=new elm(id,x1,y1,x2,y2); call clics.Insert(e); call affiche_nom; End bot_enable; Unit virtual bot_disable : procedure; var e : elm; Begin cnom:=Rouge; e:=new elm(id,x1,y1,x2,y2); call clics.Delete(e); call affiche_nom; End bot_disable; Unit virtual AfficheSuite : procedure; Begin if (etat) then call bot_enable; else call bot_disable; fi; End AfficheSuite; End Menu; (***************************************************************************) (* definition de la classe Racc derivant de Bottons *) (***************************************************************************) Unit Racc : Bottons class (procedure sprite(x1,y1,x2,y2 :integer)); Unit virtual bot_enable : procedure; var e : elm; Begin e:=new elm(id,x1,y1,x2,y2); call clics.Insert(e); call sprite(x1,y1,x2,y2); End bot_enable; Unit virtual bot_disable : procedure; var e : elm; Begin e:=new elm(id,x1,y1,x2,y2); call clics.Delete(e); call sprite(x1,y1,x2,y2); End bot_disable; Unit virtual AfficheSuite : procedure; Begin if etat then call bot_enable; else call bot_disable; fi; End AfficheSuite; End Racc; (***************************************************************************) (* definition de la classe Windows *) (***************************************************************************) Unit Windows : class(x1,y1,x2,y2 : integer); (* x2-x1 et y2-y1 doit au mini etre 33 *) Var numero : integer, (* numero d'identification de la fenetre *) cborder : integer; (* couleur du pourtour *) Unit affiche : procedure; Begin call Line(x1,y1,x2,y1,cborder); (* lignes haut *) call Line(x1,y1+1,x2,y1+1,cborder); call Line(x1,y1,x1,y2,cborder); (* lignes gauche *) call Line(x1+1,y1,x1+1,y2,cborder); call Line(x2,y1,x2,y2,cborder); (* Lignes droite *) call Line(x2-1,y1,x2-1,y2,cborder); call Line(x1,y2,x2,y2,cborder); (* Lignes bas *) call Line(x1,y2-1,x2,y2-1,cborder); call Line(x1+16,y1,x1+16,y1+1,Noir); (* Lignes noires *) call Line(x2-16,y1,x2-16,y1+1,Noir); call Line(x1+16,y2,x1+16,y2-1,Noir); call Line(x2-16,y2,x2-16,y2-1,Noir); call Line(x1,y1+16,x1+1,y1+16,Noir); call Line(x1,y2-16,x1+1,y2-16,Noir); call Line(x2,y1+16,x2-1,y1+16,Noir); call Line(x2,y2-16,x2-1,y2-16,Noir); call AffSuite; End affiche; Unit virtual AffSuite : procedure; End AffSuite; Unit gestionnaire : function : integer; Var l,r,c : boolean, x,y : integer, rep : integer, nbbot : integer; Begin do call getpress(0,x,y,nbbot,l,r,c); if l then result:=clics.Appartient(x,y); exit; fi; rep:=inkey; if (rep>=Touche_F5 and rep<=Touche_F1) then result:=-rep-58; exit; fi; od; End gestionnaire; End Windows; (***************************************************************************) (* definition de main d‚rivant de la classe Windows *) (***************************************************************************) Unit Maine : Windows class; var cnom : integer, (* couleur du nom de la fenetre *) nom : string, (* nom de la fenetre *) cbande : integer, (* couleur de la bande du nom de la fenetre *) Bout : Listbot, (* liste des boutons rattach‚s … la fenetre *) Lwind : ListW, (* liste des fenetres filles *) Horiz : AccelerateH, (* accelerateur horizontal *) Verti : AccelerateV; (* accelerateur vertical *) var i :integer; Unit virtual AffSuite : procedure; Begin call Rectanglef(x1+17,y1+2,x2-17,y1+15,cbande); call Rectanglef(x1+3,y1+17,x2-3,y1+33,cbande); call move(x1+(x2-x1)/3,y1+5); call color(cnom); call outstring(nom); if (Horiz<>none) then call Horiz.affiche; fi; if (Verti<>none) then call Verti.affiche; fi; Bout.Courant:=Bout.head; while(Bout.Courant<>none) do call Bout.Courant.data qua Bottons.affiche; Bout.Courant:=Bout.Courant.next; od; End AffSuite; Unit iconify : procedure; var i : integer, l,r,c : boolean, x,y : integer, nboot : integer, rep : integer; Begin call cls; kill(clics); call rectangle(1,SIZEY-40,40,SIZEY,BleuClair); call rectangle(2,SIZEY-39,39,SIZEY-1,BleuClair); call move(5,SIZEY-20); call outstring("Root"); call showcursor; do call getpress(0,x,y,nboot,l,r,c); if l then if(x>=1 and x<=40 and y<=SIZEY and y>=SIZEY-40) then exit; fi; fi; rep:=inkey; if (rep=13) (* validation *) then exit; fi; od; call hidecursor; call cls; clics:=new cliquer; call W.affiche; End iconify; End Maine; (***************************************************************************) (* definition de Accelerate d‚rivant des classes Windows et Bottons *) (***************************************************************************) Unit Accelerate : Bottons class; Var Bs : arrayof Racc, PosX : integer, PosY : integer, LX,LY: integer; Unit virtual AfficheSuite : procedure; (* descend de bottons *) End AfficheSuite; Unit virtual bot_enable : procedure; Begin call W.Bout.Insert(Bs(1)); call W.Bout.Insert(Bs(2)); Call W.Bout.Insert(Bs(3)); etat:=True; End bot_enable; Unit virtual bot_disable : procedure; Begin call W.Bout.Delete(Bs(1)); call W.Bout.Delete(Bs(2)); call W.Bout.Delete(Bs(3)); etat:=False; End bot_disable; Unit virtual Deplace : procedure; End Deplace; Begin inner; call bot_enable; End Accelerate; (***************************************************************************) (* definition de AccelerateH d‚rivant de Accelerate *) (***************************************************************************) Unit AccelerateH : Accelerate class; Var x : integer, MaxX : integer, MinX : integer; Unit virtual AfficheSuite : procedure; (* descend de bottons *) Begin call Rectanglef(x1+18,y1+3,x2-18,y2-3,Noir); MaxX:=x2-18-LX; MinX:=x1+18; End AfficheSuite; Unit virtual DeplacerLeft : procedure; var e : elm; Begin call Rectanglef(PosX,PosY,PosX+LX,PosY+LY,Noir); PosX:=PosX-5; if PosXMaxX then PosX:=MaxX; Bs(3).etat:=False; e:=new elm(Bs(3).id,Bs(3).x1,Bs(3).y1,Bs(3).x2,Bs(3).y2); call clics.Delete(e); kill(e); fi; if not (Bs(1).etat) then Bs(1).etat:=True; e:=new elm(Bs(1).id,Bs(1).x1,Bs(1).y1,Bs(1).x2,Bs(1).y2); call clics.Insert(e); fi; Bs(2).x1:=PosX; Bs(2).y1:=PosY; Bs(2).x2:=PosX+LX; Bs(2).y2:=PosY+LY; call Bs(2).affiche; End DeplacerRight; Begin array Bs dim (1:3); Bs(1):=new Racc(id+1,x1+2,y1+2,x1+15,y1+15,spr_right); Bs(1).etat:=True; x:=(x2-x1)/2; PosX:=x-5; PosY:=y1+3; LX:=11; LY:=y2-y1-6; Bs(2):=new Racc(id+2,PosX,PosY,PosX+LX,PosY+LY,spr_point); Bs(2).etat:=True; Bs(3):=new Racc(id+3,x2-15,y2-15,x2-2,y2-2,spr_left); Bs(3).etat:=True; End AccelerateH; (***************************************************************************) (* definition de AccelerateV d‚rivant de Accelerate *) (***************************************************************************) Unit AccelerateV : Accelerate class; Var y : integer, MaxY : integer, MinY : integer; Unit virtual AfficheSuite : procedure; (* descend de bottons *) Begin call Rectanglef(x1+3,y1+18,x2-3,y2-18,Noir); MaxY:=y2-18-LY; MinY:=y1+18; End AfficheSuite; Unit virtual DeplacerUp : procedure; var e : elm; Begin call Rectanglef(PosX,PosY,PosX+LX,PosY+LY,Noir); PosY:=PosY-5; if PosYMaxY then PosY:=MaxY; Bs(3).etat:=False; e:=new elm(Bs(3).id,Bs(3).x1,Bs(3).y1,Bs(3).x2,Bs(3).y2); call clics.Delete(e); kill(e); fi; if not (Bs(1).etat) then Bs(1).etat:=True; e:=new elm(Bs(1).id,Bs(1).x1,Bs(1).y1,Bs(1).x2,Bs(1).y2); call clics.Insert(e); fi; Bs(2).x1:=PosX; Bs(2).y1:=PosY; Bs(2).x2:=PosX+LX; Bs(2).y2:=PosY+LY; call Bs(2).affiche; End DeplacerDown; Begin array Bs dim (1:3); Bs(1):=new Racc(id+1,x1+2,y1+2,x1+15,y1+15,spr_upper); Bs(1).etat:=True; y:=(y2-y1)/2; PosX:=x1+3; PosY:=y-5; LX:=x2-x1-6; LY:=11; Bs(2):=new Racc(id+2,PosX,PosY,PosX+LX,PosY+LY,spr_point); Bs(2).etat:=True; Bs(3):=new Racc(id+3,x2-15,y2-15,x2-2,y2-2,spr_lower); Bs(3).etat:=True; End AccelerateV; (***************************************************************************) (* definition de la classe Son d‚rivant des classes Windows et elmt *) (***************************************************************************) Unit Son : Elmt coroutine; Var aa : Windows, Horiz : AccelerateH, (* accelerateur horizontal *) Verti : AccelerateV; (* accelerateur vertical *) Begin pref Windows(0,0,0,0) block begin aa:=this Windows; (* instructions *) detach; end End Son; (***************************************************************************) (* definition de la classe Ensemble (c'est une liste) *) (***************************************************************************) Unit Ensemble : class; Var Head : Node, Courant : Node, Last : Node; Unit Node : class(data : elmt); Var next : Node; End Node; Unit virtual egalite : function (x,y : elmt) :boolean; End egalite; Unit Empty : function : boolean; Begin if Head=none then result:=True; else result:=False; fi; End; Unit Member : function (n : elmt) : boolean; Var bl : boolean, saveCou : Node; Begin Courant:=Head; saveCou:=Courant; bl:=False; While (Courant<>none) do if not egalite(Courant.data,n) then saveCou:=Courant; Courant:=Courant.next; else bl:=True; exit; fi; od; Courant:=SaveCou; result:=bl; End Member; Unit Insert : procedure (n : elmt); Var bl : boolean; Begin bl:=Member(n); if not bl then if Empty then Head:=new Node(n); Last:=Head; else Last.next:=new Node(n); Last:=Last.next; fi; fi; End Insert; Unit Delete : procedure (n : elmt); Var bl : boolean, flag : Node; Begin bl:=Member(n); if bl then flag:=Courant.next; if flag=Last then Last:=Courant; courant.next:=none; kill(flag); else courant.next:=Courant.next.next; kill(flag); fi; fi; End Delete; End Ensemble; (***************************************************************************) (* definition de la classe cliquer derivant de la classe ensemble *) (***************************************************************************) Unit cliquer : Ensemble class; Unit virtual egalite : function (x,y : elmt) : boolean; Begin if (x.id)=(y.id) then result:=True; else result:=False; fi; End egalite; Unit Appartient : function(x,y : integer) : integer; var bl : boolean; Begin bl:=False; Courant:=Head; while (Courant<>none) do if(x<(Courant.data qua elm.x2) and x>(Courant.data qua elm.x1) and y<(Courant.data qua elm.y2) and y>(Courant.data qua elm.y1)) then bl:=True; exit; else Courant:=Courant.next; fi; od; if bl then result:=Courant.data qua elm.id; else result:=-1; fi; End Appartient; End cliquer; (***************************************************************************) (* definition de la classe Listbot d‚rivant de ensemble *) (***************************************************************************) Unit Listbot : Ensemble class; Unit virtual egalite : function (x,y : elmt) : boolean; Begin if (x.id) = (y.id) then result:=True; else result:=False; fi; End egalite; End Listbot; (***************************************************************************) (* definition de la classe ListW d‚rivant de ensemble *) (***************************************************************************) Unit ListW : Ensemble class; Unit virtual egalite : function (x,y : elmt) : boolean; Begin if (x qua Son.aa qua Windows.numero) = (y qua Son.aa qua Windows.numero) then result:=True; else result:=False; fi; End egalite; End ListW; (***************************************************************************) (* procedure d'affichage des sprites des boutons *) (***************************************************************************) (***************************************************************************) Unit spr_upper : procedure(x1,y1,x2,y2 : integer); var i,x,y : integer; Begin x:=(x2-x1)/2; y:=(y2-y1)/2; for i:=1 to y do call Line(x1+x-i/2,y1+y/2+i,x1+x+i/2,y1+y/2+i,Noir); od End spr_upper; (***************************************************************************) Unit spr_lower : procedure(x1,y1,x2,y2 : integer); var i,x,y : integer; Begin x:=(x2-x1)/2; y:=(y2-y1)/2; for i:=1 to y do call Line(x1+x-i/2,y2-y/2-i,x1+x+i/2,y2-y/2-i,Noir); od End spr_lower; (***************************************************************************) Unit spr_left : procedure(x1,y1,x2,y2 : integer); var i,x,y : integer; Begin x:=(x2-x1)/2; y:=(y2-y1)/2; for i:=1 to x do call Line(x2-x/2-i,y1+y-i/2,x2-x/2-i,y1+y+i/2,Noir); od End spr_left; (***************************************************************************) Unit spr_right : procedure(x1,y1,x2,y2 : integer); var i,x,y : integer; Begin x:=(x2-x1)/2; y:=(y2-y1)/2; for i:=1 to x do call Line(x1+x/2+i,y1+y-i/2,x1+x/2+i,y1+y+i/2,Noir); od End spr_right; (***************************************************************************) Unit spr_close : procedure(x1,y1,x2,y2 : integer);; var y : integer; Begin y:=(y2-y1)/2; call Rectanglef(x1+3,y1+y-1,x2-3,y1+y+1,Noir); End spr_close; (***************************************************************************) Unit spr_point : procedure(x1,y1,x2,y2 : integer);; var x,y : integer; Begin y:=(y2-y1)/2; x:=(x2-x1)/2; call Rectanglef(x1+x-1,y1+y-1,x1+x+1,y1+y+1,Noir); End spr_point; (***************************************************************************) (* procedure de gestion des boutons *) (***************************************************************************) (***************************************************************************) Unit Bot_Load : procedure; Const Largeur=200, Hauteur=100; Var fenet : Son, x,y : integer, savcli : cliquer; Begin x:=(W.x2-W.x1)/2; y:=(W.y2-W.y1)/2; fenet:=new Son(20); (* identite = 20 *) fenet.aa.x1:=x-Largeur/2; fenet.aa.y1:=y-Hauteur/2; fenet.aa.x2:=x+Largeur/2; fenet.aa.y2:=y+Hauteur/2; fenet.aa.numero:=10; savcli:=clics; (* on sauvegarde l'ensemble des zones de clics *) clics:=none; call fenet.aa.affiche; End Bot_Load; (***************************************************************************) Unit Bot_Quit : procedure; Const Largeur=200, Hauteur=100; Var fenet : Son, x,y : integer, savcli : cliquer; Begin x:=(W.x2-W.x1)/2; y:=(W.y2-W.y1)/2; fenet:=new Son(30); (* identite = 30 *) fenet.aa.x1:=x-Largeur/2; fenet.aa.y1:=y-Hauteur/2; fenet.aa.x2:=x+Largeur/2; fenet.aa.y2:=y+Hauteur/2; fenet.aa.numero:=10; savcli:=clics; (* on sauvegarde l'ensemble des zones de clics *) clics:=none; call fenet.aa.affiche; End Bot_Quit; (***************************************************************************) (* P R O G R A M M E P R I N C I P A L *) (***************************************************************************) Begin call gron(4); clics:=new cliquer; (* ensemble des zones de clic possible *) W:=new Maine(1,1,SIZEX,SIZEY); W.numero:=1; W.cborder:=BleuClair; W.cbande:=GrisClair; W.cnom:=BleuClair; W.nom:="Simulation de r‚seau routier"; W.Bout:=new ListBot; array B dim (0:2); B(2):=new Racc(102,W.x2-16,W.y1+2,W.x2-3,W.y1+15,spr_upper); B(2).etat:=True; call W.Bout.Insert(B(2)); B(1):=new Racc(101,B(2).x1-14,B(2).y1,B(2).x1-1,B(2).y2,spr_lower); B(1).etat:=True; call W.Bout.Insert(B(1)); B(0):=new Racc(100,W.x1+3,B(1).y1,W.x1+16,B(1).y2,spr_close); B(0).etat:=True; call W.Bout.Insert(B(0)); array M dim (0:4); M(0):=new Menu(1,W.x1+8,W.y1+18,W.x1+50,W.y1+32); M(0).nom:="Load"; M(0).etat:=True; call W.Bout.Insert(M(0)); M(1):=new Menu(2,W.x1+55,W.y1+18,W.x1+89,W.y1+32); M(1).nom:="Run"; M(1).etat:=False; call W.Bout.Insert(M(1)); M(2):=new Menu(3,W.x1+94,W.y1+18,W.x1+136,W.y1+32); M(2).nom:="Stop"; M(2).etat:=False; call W.Bout.Insert(M(2)); M(3):=new Menu(4,W.x1+141,W.y1+18,W.x1+215,W.y1+32); M(3).nom:="Continue"; M(3).etat:=False; call W.Bout.Insert(M(3)); M(4):=new Menu(5,W.x1+220,W.y1+18,W.x1+262,W.y1+32); M(4).nom:="Quit"; M(4).etat:=True; call W.Bout.Insert(M(4)); W.Horiz:=new AccelerateH(50,W.x1+2,W.y2-18,W.x2-18,W.y2-2); W.Verti:=new AccelerateV(60,W.x2-18,W.y1+34,W.x2-2,W.y2-18); call W.affiche; call showcursor; do code:=W.Gestionnaire; call hidecursor; case code when 1 : call Bot_Load; (* f1 : Load *) when 5 : exit; (* f5 : quit *) when 51 : call W.Horiz.DeplacerLeft; when 53 : call W.Horiz.DeplacerRight; when 61 : call W.Verti.DeplacerUp; when 63 : call W.verti.DeplacerDown; when 100 : exit; (* racc fin *) when 101 : call W.iconify; esac; call showcursor; od; call hidecursor; call groff; end end end.