DP Tool Club 19/CD_ASCQ_19_010295.iso/dos/prg/pas/ktools/source/otxtview.pas

Pascal/Delphi Source File | 1994-11-13 | 14KB | 622 lines

Unit OTxtView;
{ objet générique en mode texte }
{ K.B. octobre-novembre 1994 }

{$IFDEF debug}
 {$A+,B-,D+,E-,F-,I+,L+,N-,R+,S+,V-,W+,X+}
{$ELSE}
 {$A+,B-,D-,E-,F-,I+,L-,N-,R-,S-,V-,W+,X+}
{$ENDIF}

INTERFACE

Uses Dos, UDrivers, UTextScr, OTableau, OGenView;

Const
 { constantes d'Etat }
 stOmbre      = $0100;
 stSauveEcran = $0200;
 stCurseur    = $0400;

 { constantes d'erreur }
 erMono = 100;

 { Positions de palette }
 pBleu  = 1;
 pGris  = 4;
 pVert  = 7;
 pCyan  = 10;
 pRouge = 13;

Type
 TColorPal=String[40];
 TStr30=String[30];

 PTextView = ^TTextView;
 TTextView = object(TGenView)
  PalOffset   : Byte;
  SavedScreen : PWordBuffer;
  Constructor Init(X,Y,L,H:Integer);
  Destructor  Done; virtual;
  Procedure   Select; virtual;
  Procedure   UnSelect; virtual;
  Procedure   DrawBegin; virtual;
  Procedure   SauveEcran; virtual;
  Procedure   RestitueEcran; virtual;
  Function    GetColor(n:Byte):Byte;
  Procedure   Ecrire(S:String;x,y,c:Byte);
  End;

 TMenuItem=record
  Nom:TStr30;
  Touche:Word;
  End;

 PStatusLine=^TStatusLine;
 TStatusLine=object(TTextView)
  Table:TTableau;
  Constructor Init;
  Destructor Done;virtual;
  Procedure HandleEvent(Var Event:TEvent);virtual;
  Procedure Draw;virtual;
  Procedure AjouterItem(N:TStr30;K:Word);
  End;

 PHorloge=^THorloge;
 THorloge=object(TTextView)
  Seconde:Word;
  Constructor Init;
  Procedure Draw;virtual;
  End;

 PWindow=^TWindow;
 TWindow=object(TTextView)
  Titre:String[60]; {titre}
  Constructor Init(xi,yi,l,h:Integer;T:String);
  { fixe les dimensions et le titre , puis définit
    les valeurs par défaut }
  Procedure BackGround;virtual;
  { dessine le cadre }
  Procedure Draw; virtual;
  Procedure DrawInterior; virtual;
  Procedure Show;
  { affiche et sélectionne }
  Function SurCadre(P:TPoint):Boolean;
  { indique si le point est sur le cadre }
  Procedure ChangeTitre(S:String);
  { change le titre de la fenêtre }
  Function Largeur:Byte;
  { largeur de l'intérieur de la fenêtre, sans le bord }
  Function Hauteur:Byte;
  { hauteur de l'intérieur de la fenêtre, sans le bord }
  Procedure HandleEvent(Var Event:TEvent);virtual;
  { réaction à un évènement }
  { procédure virtuelle à redéfinir à chaque fois }
  { en standard, l'appui sur Echap ou le click sur le bouton droit
    provoquent la fermeture }
  End;

 PTextApp=^TTextApp;
 TTextApp=object(TGenApp)
  PalOffset : Byte;
  Titre:String[80];       {titre sur la première ligne}
  Horloge:PHorloge;
  StatusLine:PStatusLine; {ligne d'état}
  Fond:Byte;              {caractère dessinant le bureau}
  Constructor Init;
  Procedure VideoInit; virtual;
  Procedure VideoDone; virtual;
  Procedure BackGround; virtual;
  Function  GetColor(n:Byte):Byte;
  Procedure InitStatusLine; virtual;
  Procedure GetEvent(Var Event:TEvent); virtual;
  Procedure HandleEvent(Var Event:TEvent); virtual;
  Procedure Patience(S:String);
  Procedure FinPatience;
  Procedure TempsMort;virtual;
  Procedure ClearDeskTop;
  End;

Var
 DefaultPal, CurPal:TColorPal;    { Palettes de couleurs }
 OldExitProc : Pointer;           { Procédure de sortie }

Const
 QuitMsg:String='Au revoir...';

Procedure MakeMenuItem(Var T:TMenuItem;N:TStr30;K:Word);
{ construit un élément de la ligne de statut }

IMPLEMENTATION

{$F+}
Procedure MyExitProc;
Begin
 ExitProc := OldExitProc;
 SetCursorType(NormalCursor);
 SetCursorPos(0,0);
 FillScreen(32+256*7);
 if QuitMsg<>''
    then writeln(QuitMsg);
End;
{$F-}

Procedure MakeMenuItem(Var T:TMenuItem;N:TStr30;K:Word);
Begin
 with T do
  begin
   Nom:=N;
   Touche:=K;
  end;
End;

{ objet TTextView }

Constructor TTextView.Init(X,Y,L,H:Integer);
Begin
 TGenView.Init(X,Y,L,H);
 SavedScreen:=nil;
 PalOffset:=pBleu;
 Ident:='TEXTVIEW';
End;

Destructor TTextView.Done;
Begin
 RestitueEcran;
 TGenView.Done;
End;

Procedure TTextView.DrawBegin;
Var P : TPoint;
    O : Integer;
Begin
 MakeGlobal(Origin,P);
 if Etat and stOmbre <> 0
    then O:=1
    else O:=0;
 MouseClipON(P.X,P.Y,P.X+Size.X+O,P.Y+Size.Y+O);
End;

Procedure TTextView.Select;
Begin
 if Etat and stSelectable = 0
    then exit;
 TGenView.Select;
 if Etat and stCurseur<>0
    then SetCursorType(NormalCursor)
    else SetCursorType(BlankCursor);
End;

Procedure TTextView.UnSelect;
Begin
 TGenView.UnSelect;
 SetCursorType(BlankCursor);
End;

Procedure TTextView.SauveEcran;
Var P : TPoint;
    O : Integer;
Begin
 if Etat and stSauveEcran = 0
    then exit;
 if SavedScreen=nil
    then begin
          MakeGlobal(Origin,P);
          if Etat and stOmbre<>0
             then O:=1
             else O:=0;
          GetMem(SavedScreen,(Size.X+O)*(Size.Y+O)*2);
          if SavedScreen=nil
             then begin
                   ErrorFlag:=erMemoire;
                   exit;
                  end;
          DrawBegin;
          ScreenToBuf(P.X,P.Y,P.X+Size.X-1+O,P.Y+Size.Y-1+O,SavedScreen^);
          DrawEnd;
         end;
End;

Procedure TTextView.RestitueEcran;
Var P : TPoint;
    O : Integer;
Begin
 if SavedScreen<>nil
    then begin
          MakeGlobal(Origin,P);
          if Etat and stOmbre<>0
             then O:=1
             else O:=0;
          DrawBegin;
          BufToScreen(P.X,P.Y,P.X+Size.X-1+O,P.Y+Size.Y-1+O,SavedScreen^);
          DrawEnd;
          FreeMem(SavedScreen,(Size.X+O)*(Size.Y+O)*2);
          SavedScreen:=nil;
         end;
End;

Function TTextView.GetColor(n:Byte):Byte;
Begin
 GetColor:=ord(CurPal[PalOffset+n]);
End;

Procedure TTextView.Ecrire(S:String;x,y,c:Byte);
Var P : TPoint;
Begin
 MakeGlobal(Origin,P);
 if P.Y+y=MouseY
    then DrawBegin;
 WriteXY(getcolor(c),P.X+x,P.Y+y,S);
 if P.Y+y=MouseY
    then DrawEnd;
End;

{ objet THorloge }

Constructor THorloge.Init;
Begin
 TTextView.Init(71,0,8,1);
 Seconde:=100;
End;

Procedure THorloge.Draw;
Var R  : String[10];
    W  : String[3];
    h,m,s,c : Word;
 Procedure Normalise;
 Begin
  if length(W)=1
     then W:='0'+W;
 End;
Begin
 GetTime(h,m,s,c);
 if s<>Seconde
    then begin
          Seconde:=s;
          str(h,W);
          Normalise;
          R:=W+':';
          str(m,W);
          Normalise;
          R:=R+W+':';
          str(Seconde,W);
          Normalise;
          R:=R+W;
          Ecrire(R,0,0,0);
         end;
End;

{ objet TStatusLine }

Constructor TStatusLine.Init;
Begin
 TTextView.Init(0,24,80,1);
 Etat:=stSauveEcran;
 Table.Init(3,1,sizeof(TMenuItem));
End;

Destructor TStatusLine.Done;
Begin
 Table.Done;
 TTextView.Done;
End;

Procedure TStatusLine.HandleEvent(Var Event:TEvent);
Var i:Integer;
    T:TMenuItem;
    p:Byte;
    E:TEvent;
    ok:Boolean;
Begin
 if Table.NombreItems=0
    then exit;
 if Event.What<>evMouseLDown
    then exit;
 if Event.Where.Y<>24
    then exit;
 p:=0;
 for i:=1 to Table.NombreItems do
  begin
   Table.Lire(T,i);
   if (Event.Where.x>=p) and (Event.Where.x<=p+length(T.Nom)-1)
      then begin
            Ecrire(T.Nom,p,0,1);
            ok:=true;
            repeat
             GetMouseEvent(E);
             ok:=E.Where.Y=24;
            until (E.What=evMouseLUp) or not ok;
            Ecrire(T.Nom,p,0,0);
            if ok
               then begin
                     Event.What:=evKeyDown;
                     Event.KeyCode:=T.Touche;
                    end;
            exit;
           end
      else p:=p+length(T.Nom)+2;
  end;
End;

Procedure TStatusLine.Draw;
Var i:Integer;
    T:TMenuItem;
    S:String;
Begin
 if Table.NombreItems=0
    then begin
          RestitueEcran;
          SauveEcran;
          exit;
         end;
 S:='';
 For i:=1 to Table.NombreItems do
  begin
   Table.Lire(T,i);
   S:=S+T.Nom+'  ';
  end;
 Ajuste(S,80);
 Ecrire(S,0,0,0);
End;

Procedure TStatusLine.AjouterItem(N:TStr30;K:Word);
Var T:TMenuItem;
Begin
 MakeMenuItem(T,N,K);
 Table.Ajouter(T);
End;

{ objet TWindow }

Constructor TWindow.Init(xi,yi,l,h:Integer;T:String);
{ définit une fenêtre }
Begin
 TTextView.Init(xi,yi,l,h);
 Titre:=T;
 Etat:=stOmbre+stSauveEcran+stSelectable;
End;

Procedure TWindow.BackGround;
Var P : TPoint;
Begin
 MakeGlobal(Origin,P);
 DrawBegin;
 Frame(P.X, P.Y, P.X+Size.X-1, P.Y+Size.Y-1,
       GetColor(0), Titre);
 if Etat and stOmbre<>0
    then Shadow(P.X, P.Y, P.X+Size.X-1, P.Y+Size.Y-1, 7);
 DrawEnd;
End;

Procedure TWindow.DrawInterior;
Begin
End;

Procedure TWindow.Draw;
Begin
 TTextView.Draw;
 DrawInterior;
End;

Function TWindow.Largeur:Byte;
{ renvoie la largeur de l'intérieur de la fenêtre }
Begin
 Largeur:=Size.X-2;
End;

Function TWindow.Hauteur:Byte;
{ renvoie la hauteur de l'intérieur de la fenêtre }
Begin
 Hauteur:=Size.Y-2;
End;

Function TWindow.SurCadre(P:TPoint):Boolean;
Var T:TPoint;
Begin
 MakeGlobal(Origin,T);
 if (((P.X=T.X) or (P.X=T.X+Size.X-1)) and (P.Y>=T.Y) and (P.Y<=T.Y+Size.Y-1))
    or (((P.Y=T.Y) or (P.Y=T.Y+Size.Y-1)) and (P.X>=T.X) and (P.X<=T.X+Size.X-1))
    then SurCadre:=true
    else SurCadre:=false;
End;

Procedure TWindow.Show;
Begin
 if not IsValid
    then exit;
 DrawBegin;
 SauveEcran;
 Draw;
 Select;
 DrawEnd;
End;

Procedure TWindow.ChangeTitre(S:String);
Var Tmp:String;
Begin
 Titre:=S;
 Tmp:=Titre;
 if length(Tmp)>Largeur-2
    then Tmp[0]:=chr(Largeur-2);
 while length(Tmp)<Largeur do
  Tmp:=THS+Tmp+THS;
 if length(Tmp)>Largeur
    then dec(Tmp[0]);
 Ecrire(Tmp,1,0,0);
End;

Procedure TWindow.HandleEvent(Var Event:TEvent);
Begin
 TTextView.HandleEvent(Event);
 case Event.What of
  evKeyDown:
   case Event.KeyCode of
    Echap: SetCommand(cmClose);
    else exit;
    end;
  evMouseRDown:
   if Etat and stSelected<>0
      then begin
            repeat
             GetMouseEvent(Event);
            until Event.What=evNothing;
            SetCommand(cmClose);
           end
      else exit;
  evCommand:
   case Event.Command of
    cmClose : ExitCode:=exAnnule;
    else exit;
    end;
  else exit;
  end;
 Event.What:=evNothing;
End;

{ objet TGenApp }

Constructor TTextApp.Init;
Begin
 MouseText:=true;
 TGenApp.Init;
 PalOffset:=pBleu;
 Titre:='';
 Fond:=$B1;
 SetCursorType(BlankCursor);
 Horloge:=New(PHorloge,Init);
 if Horloge<>nil
    then Insert(Horloge);
 InitStatusLine;
 if StatusLine<>nil
    then Insert(StatusLine);
 MouseLimits(0,0,Size.X-1,Size.Y-1);
 MouseX:=Size.X div 2;
 MouseY:=Size.Y div 2;
 MouseMoveTo(MouseX,MouseY);
 MouseShow;
End;

Procedure TTextApp.VideoInit;
Var ModeEcran : Word;
Begin
 GetVideoMode(ModeEcran);
 if ModeEcran=7
    then begin
          writeln('Ecran couleur nécessaire pour cette application.');
          writeln('Au revoir ...');
          halt(1);
         end;
 SetActivePage(0);
 DefaultPal:=
     chr(grisclair+16*bleu) + chr(bleu+16*grisclair) + chr(jaune+16*bleu)
   + chr(bleu+16*grisclair) + chr(grisclair+16*bleu) + chr(blanc+16*grisclair)
   + chr(blanc+16*vert) + chr(vert+16*grisclair) + chr(jaune+16*vert)
   + chr(bleu+16*cyan) + chr(cyan+16*bleu) + chr(blanc+16*cyan)
   + chr(grisclair+16*rouge) + chr(rouge+16*grisclair) + chr(jaune+16*rouge);
 CurPal:=DefaultPal;
 Size.X:=80;
 Size.Y:=25;
 OldExitProc := ExitProc;     { Sauve Proc de sortie précédente }
 ExitProc    := @MyExitProc;  { Insérons notre procédure de sortie }
End;

Procedure TTextApp.VideoDone;
Begin
 ExitProc := OldExitProc;
 SetCursorType(NormalCursor);
 SetCursorPos(0,0);
 FillScreen(32+256*7);
 if QuitMsg<>''
    then writeln(QuitMsg);
End;

Procedure TTextApp.BackGround;
Begin
 MouseHide;
 SetCursorPos(0,0);
 PutCharAttrib(32+256*GetColor(0),80);
 WriteXY(GetColor(0),0,0,Titre);
 SetCursorPos(0,1);
 PutCharAttrib(Fond+256*GetColor(0),24*80);
 MouseShow;
End;

Function TTextApp.GetColor(n:Byte):Byte;
Begin
 GetColor:=ord(CurPal[PalOffset+n]);
End;

Procedure TTextApp.TempsMort;
Begin
 if Horloge<>nil
    then Horloge^.Draw;
End;

Procedure TTextApp.InitStatusLine;
Begin
 StatusLine:=New(PStatusLine,Init);
End;

Procedure TTextApp.GetEvent(Var Event:TEvent);
Begin
 TGenApp.GetEvent(Event);
 StatusLine^.HandleEvent(Event);
End;

Procedure TTextApp.HandleEvent(Var Event:TEvent);
Var W,WPrec:PGenView;
Begin
 if Event.What=evCommand
    then if Event.Command=cmClose
            then begin
                  W:=PGenView(Event.InfoPtr);
                  WPrec:=W^.Prec;
                  W^.UnSelect;
                  dispose(W,Done);
                  if WPrec<>nil
                     then WPrec^.Select;
                  Event.What:=evNothing;
                  exit;
                 end;
 TGenApp.HandleEvent(Event);
End;

Procedure TTextApp.ClearDeskTop;
Var W,tmp : PGenView;
Begin
 W:=Child;
 tmp:=Child;
 { trouver le dernier enfant }
 while tmp<>nil do
  begin
   tmp:=W^.Suiv;
   if tmp<>nil
      then W:=tmp;
  end;
 { effacer les enfants sélectables }
 while W<>nil do
  begin
   tmp:=W^.Prec;
   if W^.Etat and stSelectable<>0
      then dispose(W,Done);
   W:=tmp;
  end;
 { curseur }
 SetCursorType(BlankCursor);
End;

Procedure TTextApp.Patience(S:String);
Begin
 Ajuste(S,80);
 WriteXY(getcolor(0),0,24,S);
End;

Procedure TTextApp.FinPatience;
Begin
 StatusLine^.Draw;
End;

END.

{                        Fin du fichier OTxtView.Pas                        }