{==============  FICHIER DE EDNUM  ======================}
{ Unite Graphe Trace.pas  Usinage machines a c.n. NUM750 }
{ programmation Turbo Pascal - Borland                   }
{ Copyright (S) 1997-2011                                }
{ programmeur du programme A.Ara                         }
{ 64150 Mourenx - France.                                }
{ Licence d'utilisation accord dans un but démonstratif  }
{ Unite box13.pas : graphiques EDnum c.n du bois num750  }
{========================================================}
{==============  FICHIER DE EDNUM  =================}
{* Types publiques de Fuffers destines a l'editeur *}
{* Max_Buffer=64512;      63 Ko.                   *}
{* Max_Buffer_Copy=5120;  5  ko                    *}
{* Unite BOX13.PAS                                 *}
{***************************************************}
{============================================================}
{  ScrollText( Direction, X1, Y1, X2, Y2, Nbr, Color );      }
{  Translation du texte - le texte est translate             }
{  puis la zone non concernee  est remise … blanc.           }
{============================================================}
{============================================================}
{  MoveText( X1, Y1, X2, Y2, NewX1, NewY1 );                 }
{  Deplace une zone de texte en une nouvelle position de     }
{ l'ecran                                                    }
{============================================================}
{============================================================}
{  ClearScreen(X1, Y1, X2, Y2, Attrib : Word);               }
{  Efface une zone de l'ecran                                }
{============================================================}

{$O+,F+}
 Unit Box13;

 Interface
 Uses Crt,Dos;

  {$L Win_Asm.Obj}
  {$L Miniscul.Obj}
  {$L Uppers.Obj}
  {$L Screen.Obj}

  {*== BOX13 constantes publiques ==*}

 Const
      Titres_Color:Byte=48;
      Menu_Color:Byte = 112;
      Dir_Color :Byte = 112;
      Edit_Color:Byte = 31;
      Error_Color:Byte= 78;
      Etat_Color:Byte = 23;
      Help_Color:Byte = 48;
      BX        :Byte= 3;
      Block_Color :Byte = 75;
      Marque_Color:Byte = 116;
      Char_Color  :Byte = 4;

      GetMaxEcranX = 80;
      GetMaxEcranY = 50;

      MinGetMaxEcranY = 25;
      EGAInstalled:Boolean=False;
      NoCursor = $2000;
      InsCursorSmall = $0007;
      InsCursorLarge = $000D;

TYPE  {Types publiques}

     ScreenColoneRange = 1..GetMaxEcranX;
     ScreenlineRange   = 1..GetMaxEcranY;
     VideoTypes = (MDA, CGA, MCGA, EGA, VGA);

     Direction  = (Up, Down, Left, Right);
     ScreenChar = record
                      Data : Char;
                      Attrib : Byte;
                  end;
     ScreenArray = array[ScreenLineRange, ScreenColoneRange] of ScreenChar;
     ScreenPointer = ^ScreenArray;

     EditColoneRange = 1..160;
     EditlineRange   = 1..GetMaxEcranY;

     ScreenPageXX  = array[EditLineRange, EditColoneRange] of ScreenChar;
     ScreenPagePtr = ^ScreenPageXX;


     CadreChars = Array[0..5] Of Char;
     KeysType   = (On,Off);

Const Double:CadreChars ='Éͻȼº';
      Simple:CadreChars ='ÚÄ¿ÀÙ³';

Var
     ScreenPtr  : ScreenPointer;
     ScreenPage :ScreenPagePtr;
     Getpage    : Byte;
     CrtGetMaxY    : ScreenLineRange;
     CrtGetMaxX    : ScreenColoneRange;
     VideoType  : VideoTypes;
     RES_Cursor : Word;
     InsCursor  : Word;
     OldMode    : Word;
     BaseEcran  : Pointer;
     TailleEcran:Word;    {renvoie la taille de l'ecran}
     Begin_heap :^Word;
     DisqueVirtuel:String[40]; {*designe le disque virtuel actif*}

{*=== Procedures et fonctions Publiques de BOX13 ==*}

  Function  Filedate(F: String) : Longint;
  Function  FileMaxSize(F : String) :Longint;
  Function  GetTexte:byte;
  Function  GetFond:Byte;
  Procedure SetColor(Texte,Fond:Byte);
  Function  GetCursor : Word;            { Renvoie l'aspect du curseur }
  Procedure SetCursor(NewCursor : Word); { Definit l'aspect du curseur }
  Procedure ScreenLine25;
  Procedure CsOn(x,y:byte);
  Procedure CsOff;
  Procedure PosXY(X,Y:Byte);

  Procedure Putxy(x,y:Byte;S:String);     {cordones sur 80x25 sans control}
  Procedure Writexy(x,y:Byte;S:String);
  Procedure WriteCn(y:Byte;S:String);
  Procedure WriteChar(x,y,Count:Byte;Ch:Char);

  Function  ReadBox(X,Y:Byte;Var SS: String;Longeur,MaxCh:Byte):Boolean;
  Function  ReadStr(X,Y:Byte;Var S1:String;Longeur:Byte):Boolean;
  Function  ReadNum(x,y,N:Byte):Integer;
  Function  ReadReal(x,y,N:Byte;Var Ent:Byte):Real;
  Function  CrtSize(X1,Y1,X2,Y2:Byte):Word;
  Procedure ReadBuf(X1,Y1,X2,Y2:Byte;Var Buf);
  Procedure WriteBuf(X1,Y1,X2,Y2:Byte;Var Buf);

  Procedure Rectangle(x1,y1,x2,y2:Byte;Var Cadre:CadreChars);
  Procedure HighBox(x1,y1,x2,y2,Colori:Byte);
  Procedure BoxColor(x1,y1,x2,y2,Colori:Byte);
  Procedure BoxFill(x1,y1,X2,Y2:Byte;Ch:Char);

  {*=====================================================================*}

  Procedure MoveToScreen(var Source, Dest; Len : Word);
  Procedure MoveFromScreen(var Source, Dest; Len : Word);
  Procedure ClrscrFinLineXY(Col : ScreenColoneRange; Row : ScreenLineRange);
  Procedure MoveText(OldX1, OldY1, OldX2, OldY2, NewX1, NewY1 : Word);

  {**Deplace une zone de texte en une nouvelle position de l'ecran**}

  Procedure ScrollText(Dir : Direction; X1, Y1, X2, Y2, Amt, Attrib : Word);

  {**Translation du texte - le texte est translate puis la zone non concernee est remise a blanc**}

  Procedure ClearScreen(X1, Y1, X2, Y2, Attrib : Word);
  {*Efface une zone de l'ecran*}

  Procedure WriteCar(x,Y:Byte;Caractere:Char);
  Procedure WriteClip(x,Y:Byte;Car:String;Clip:Byte);
  
  Function  Uppers(Str:String):String;
  Function  Miniscul(Str:String):String;

  Procedure KeyCaps(tipe:KeysType);

  Procedure KeyNum (tipe:KeysType);
  Function  GetPrn:Boolean;
  Function  TestPrn:Byte;

  Function  GetKeyByte:Byte;
  Function  SegEcran:Word;
  Function  OfsEcran(x,y:Byte):Word;
  Procedure ClearBufKey;
  Function Babi_Ti(NomA:String;U:Byte):String;
  Function Code_Babi_Ti(NomA:String;U:Byte):String;

 Implementation
 
 Uses Get_Key7;

 Type
    Buf255 = Array[1..255] of Char;

 Var Regg:Registers;
     {Num_Disk_Save:Byte;}
     ch:Char;


{***Verifie la date enregitrement***}
Function Filedate(F: String) : Longint;
var
  SR : SearchRec;
begin
   FindFirst(F, AnyFile, SR);
   If DosError = 0 Then Filedate:=SR.Time
   Else Filedate:=0;
end; { FileDate }


Function FileMaxSize(F : String) :Longint;
{***Verifie l'existence du fichier et la Taille***}
var SR : SearchRec;
begin
   FindFirst(F, AnyFile, SR);
   If (DosError=0) Then FileMaxSize:=Sr.Size
   Else FileMaxSize:=-1;
end; {*FileMaxSize*}


 Function Miniscul(Str:String):String;
 External {Miniscul};

 Function GetTexte:byte; {**Renvoie la couleur du texte**}
 External {Win_Box};

 Function GetFond:Byte; {**Remvoie la couleur du fond**}
 External {Win_Box};

 Procedure SetColor(Texte,Fond:Byte); {**Initialise la couleur texte et fond**}
 begin
    textAttr:=(Fond Shl 4)+Texte;
 End;

 Function  GetKeyByte:Byte;
 External {Win_Box};

 Procedure KeyCaps(tipe:KeysType);
  Begin
    Case Tipe Of
        On: If Mem[0:$417]<>(Mem[0:$417] OR  $40) Then Mem[0:$417]:=Mem[0:$417] OR  $40;
       OFf: If Mem[0:$417]=(Mem[0:$417] OR  $40) Then Mem[0:$417]:=Mem[0:$417] And $BF;
    End;
 End;

 
 Procedure KeyNum(tipe:KeysType);
 Begin
    Case Tipe Of
       On: If  Mem[0:$417]<>(Mem[0:$417] OR  $20) Then Mem[0:$417]:=Mem[0:$417] OR  $20;
       OFf: If  Mem[0:$417]=(Mem[0:$417] OR  $20) Then Mem[0:$417]:=Mem[0:$417] And $DF;
    End;
 End;


{**Positione le curseur sur les cordonnes X et Y dans la page 0**}

 Procedure PosXy(X,Y:Byte);
 Const Page=0;
 Var Reg:Registers; {*Registres unite Dos*}
 Begin
    Begin
       Reg.Ax:=2 shl 8;              {Numero de fonction}
       Reg.bx:=Page Shl 8;           {Page}
       Reg.dx:=(Y-1) Shl 8 + (X-1);  {Cordones}
       Intr($10,Dos.registers(Reg)); {Appel}
    End;
 End;

 
 Function  SegEcran:Word;
 External {Win_Box};

 Function  OfsEcran(x,y:Byte):Word;
 External {Win_Box};

 Procedure ClearBufKey;
 External {Win_Box};

 {**converti un majuscules une chaine**}
 Function Uppers(Str:String):String;
 External {Uppers};


{*********************************************************}
{ Entre: x,y codonees, Chaine de caracteres MaxWindow     }
{        Longeur: = place dans la boite                   }
{        MaxCh : nombre de caracteres dans la chaine Max  }
{ cadre: X1= x-2, X2 = x+longeur+1                        }
{ Sortie: renvoit False si operation anule par ESC        }
{    sino renvoit True                                    }
{  ReadBox(x,y,Chaine,longeurBox,nombre de caracteres)    }
{*********************************************************}

Function ReadBox(X,Y:Byte;Var SS: String;Longeur,MaxCh:Byte):Boolean;
Var S:Buf255;
    Bg,Key:Byte;
    i,X1,X2:Byte;
    debut,Pos:Byte;
    FinBuf:Byte;

Function Copi(Deb,Nb:Byte):String;
Var p:String;
    ii:Byte;
Begin
   p:='';ii:=0;
   While (ii<Nb) and (S[Deb+ii]<>^Z) DO
    Begin
     P:=P+S[Deb+ii];
     Inc(ii);
    End;
   Copi:=p;
End;

Begin
   X1:=X;
   X2:=X1+Longeur;
   For i:= 1 TO 255 DO S[i]:=' ';
   Key:=0;
   If SS<>'' Then
    Begin
       For i:=1 To Length(SS) DO
        S[i]:=SS[i];
       S[i+1]:=^Z;
       Finbuf:=i;

       If FinBuf>Longeur Then
        Begin
         Debut:=(FinBuf-Longeur)+1;
         If FinBuf>=MaxCh Then
          Begin
           Pos:=FinBuf;
           X:=(X1+longeur)-1;
          End
         Else
           Begin
            Pos:=FinBuf+1;
            X:=X1+Longeur;
           End;
         Putxy(X1,y,Copi(Debut,longeur));
         If Debut>1 Then Putxy(X1-1,Y,#17);
        End
       Else
        Begin
          Debut:=1;
          Putxy(X1,y,Copi(1,FinBuf));
          X:=Finbuf+X1;
          pos:=Finbuf+1;
        End;

       If GetFond =0 Then Bg:=7
        Else Bg:=GetFond;
       HighBox(X1,Y,X,Y,Bg);


       PosXy(X,Y);
       Key:=KeyBoard;
       If (Not Key_Code) And (Key<>13) And (Key in[32..255]) Then
        Begin
          For i:=0 TO Longeur DO Putxy(X1+i,Y,' ');
          For i:=1 To 255 DO S[i]:=' ';
          X:=X1;
          S[1]:=^Z;
          FinBuf:=0;
          Debut:=1;
          Pos:=1;
        End
         Else
          HighBox(X1,Y,X,Y,Bg);
    End  {* SS<>'' *}
   Else
    Begin
       X:=X1;
       S[1]:=^Z;
       FinBuf:=0;
       Debut:=1;
       Pos:=1;
    End;

   PosXy(X,Y);
   Repeat
     If (Key<>27) And (Key<>13) Then
      Begin
        {** Del possition curseur droite **}
        If (Key_Code) And (Key=83) and (Pos<=FinBuf) Then
         Begin
           For i:=Pos To FinBuf+1 DO
           S[i]:=S[i+1];
           S[i]:=' ';
           Dec(FinBuf);
           If Debut>1 Then  {* ramene le debut de un *}
            Begin
                Dec(Debut);
                Putxy(X1,Y,Copi(Debut,Longeur));
                Inc(X);
                PosXy(x,Y);
            End
           Else            {* eface vers la droite *}
            Putxy(X1,Y,Copi(Debut,Longeur)+' ');
         End {* end del droite *}

        Else
        {** del gauche **}
        If ((Not Key_Code) And (Key=8) and (Pos>1)) Then
         Begin
           If (Debut>1)  then
            Begin
               Dec(pos);
               Dec(Debut);
               If Debut=1 Then Putxy(X1-1,Y,' ');
               For i:=Pos To FinBuf+1 DO
                S[i]:=S[i+1];
               S[i]:=' ';
               Dec(FinBuf);
               Putxy(X1,Y,Copi(Debut,Longeur));
            End
           Else
            If (Debut=1) And (Pos<=Finbuf)  Then
             Begin
                For i:=pos-1 To FinBuf DO
                  S[i]:=S[i+1];
                S[i]:=' ';
                Dec(FinBuf);
                Dec(Pos);
                Dec(X);
                If FinBuf+X1-1<X2 Then Putxy(FinBuf+X1-1,Y,' ');
                Putxy(X1,Y,Copi(Debut,Longeur));
                PosXy(X,Y);
             End
           Else
           If Pos>FinBuf Then
             Begin
               Dec(Pos);
               S[pos]:=^Z;
               Dec(FinBuf);
               Dec(X);
               Putxy(X,Y,' ');
               PosXy(X,Y);
             End;
         End {* end del gauche *}
        Else
        {** fleche vers la quauche **}
{<-}    If (Key_Code) And (Key=75) And (pos>1) then
         Begin
            Dec(Pos);
            If X>X1 Then
             Begin
                Dec(X);
                PosXy(X,Y);
             End
             Else
             Begin
                 Debut:=Pos;
                 Putxy(X1,Y,Copi(Pos,Longeur));
             End;
            If pos=1 Then Putxy(X1-1,Y,' ');
         End {*end fleche gauche*}
        Else
        {** ramene le curseur debut gauche **}
{<<}    If (Key_Code) And (Key=71) Then
         Begin
          Putxy(X1,Y,Copi(1,Longeur));
          X:=X1;
          Pos:=1;
          Debut:=1;
          PosXy(X,Y);
          Putxy(X1-1,Y,' ');
         End  {*end debut gauche*}
        Else
        {** deplace fin droite >> **}
{>>}    If (Key_Code) And (Key=79) Then
         Begin
           If FinBuf>Longeur Then
            Begin
              For i:=0 To Longeur Do Putxy(X1+i,Y,' ');
              Debut:=(FinBuf-Longeur)+1;
              Pos:=FinBuf+1;
              Putxy(X1,y,Copi(Debut,longeur)+' ');
              X:=X1+Longeur;
            End
           Else
            Begin
              Debut:=1;
              X:=Finbuf+X1;
              pos:=Finbuf+1;
            End;
           PosXy(X,y);
         End  {*end Fin Droite*}
        Else
        {** deplace fleche droite une position **}
{->}    If (Key_Code) And (Key=77) And (Pos<=FinBuf) And (pos<MaxCh) then
         Begin
            Inc(Pos);
            If (X+1=X2) Then
             Begin
                If Pos<=FinBuf  Then
                 Begin
                   Inc(Debut);
                   Putxy(X1,Y,Copi(Debut,Longeur)+' ');
                 End
                Else
                If Pos<=MaxCh Then
                 Begin
                   Inc(Debut,1);
                   {Dec(X);}
                   Putxy(X1,Y,Copi(Debut,Longeur)+' ');
                   Putxy(X2-1,Y,'  ');
                   { PosXy(X,y);}
                 End;
             End
            Else
              Begin
                 Inc(X);
                 PosXy(X,y);
              End;
         End {* end fleche droite ****}
        Else
        {** insere caractere **}
{inser} If (Not Key_Code) And (Key in[32..255]) And (FinBuf<MaxCh) Then
         Begin
           If (X=X2-1) Then
             Begin
               For i:=FinBuf+1 Downto Pos DO
               S[i+1]:=S[i];
               S[pos]:=Chr(Key);
               Inc(Debut);
               Inc(Pos);
               Inc(FinBuf);
               Putxy(X1,Y,Copi(Debut,Longeur));
             End
           Else
           If (S[Pos]<>^Z) Then
             Begin
                For i:=FinBuf+1 Downto Pos DO
                 S[i+1]:=S[i];
                S[pos]:=Chr(Key);
                Inc(FinBuf);
                Inc(pos);
                Inc(X);
                Putxy(X1,Y,Copi(Debut,Longeur));
                PosXy(X,Y);
             End
           Else
           If (S[Pos]=^Z) And (X<=X2) Then
            Begin
                 S[pos]:=Chr(Key);
                 Inc(FinBuf);
                 Inc(Pos);
                 S[pos]:=^Z;
                 If X=X2 Then
                  Begin
                     Inc(Debut);
                     Putxy(X1,Y,Copi(Debut,Longeur));
                  End
                 Else
                 Begin
                   Putxy(x,Y,Chr(Key));
                   Inc(X);
                   PosXy(X,Y);
                 End;
            End;
         End; {*end inser*}

{mark}  If MaxCh>Longeur Then
         Begin
          If Debut>1 Then Putxy(X1-1,Y,#17) Else  Putxy(X1-1,y,' ');
          If FinBuf-Debut>=Longeur Then Putxy(X2,Y,#16)
           Else  Putxy(X2,y,' ');
         End;

{key}   Key:=KeyBoard;

      End;  {*end key<>27 and Key<>13*}

   Until (Key=27) OR (Key=13);

   If S[1]=^Z Then SS:=''
    Else
     Begin
        i:=1;
        While S[i]=#32 DO Inc(i);
        SS:=Copi(i,FinBuf);
    End;
   If Key=13 Then ReadBox:=True
    Else ReadBox:=False;
End;{*end ReadBox*}



{*********************************************************}
{ Entrees: X,Y codones de affichage Rapor a l'ecran 80x25 }
{          S1  Chaine de caracteres                       }
{    Longueur  nombre de caracteres maximum de entree     }
{                                                         }
{ operations:  EXC,Entree  Revoit la chaine telle qui et  }
{              affichage sur l'ecran.                     }
{              Del-Fleche-gauche: efface caracteres       }
{              Fleche-droite reinsere caracteres effaces  }
{*********************************************************}

Function ReadStr(X,Y:Byte;Var S1:String;Longeur:Byte):Boolean;
Var S:String;
    Long,N:Byte;
    i,X1,Key:Byte;
Begin
   X1:=X;
   S:=S1;
   N:=LengTh(S1);
   Long:=N;
   Putxy(X,y,S1);
   X:=X+N;
   PosXy(X,Y);

   Key:=KeyBoard;

   If (Not Key_Code) And (Key<>13) And (Key in[32..255]) Then
    Begin
       If N>0 Then
        For i:=0 TO Length(S1) DO
         Putxy(X1+i,Y,' ');
       X:=X1;
       Long:=0;
    End;

   Repeat
   If (Key<>27) And (Key<>13) Then
    Begin
       If ((Key=8)  OR (Key_Code) And (Key=75)) and (Long>0) Then
        Begin
           Dec(X);
           Putxy(X,Y,' ');
           PosXy(X,Y);
           Dec(Long);
        End
       Else
        If (Key_Code) And (Key=77) And (Long<N)  Then
         Begin
           Inc(Long);
           Putxy(X,Y,S[Long]);
           Inc(X);
           PosXy(X,Y);
         End
       Else
        If (Not Key_Code) And (Key in[32..255]) And (Long<Longeur) Then
         Begin
           If long+1>Length(S1) Then
            Begin
               S1:=S1+Chr(Key);
               S:=S1;
            End
           Else
            Begin
             S1[long+1]:=Chr(Key);
             S[long+1]:=Chr(Key);
            End;
           Putxy(X,Y,Chr(Key));
           Inc(X);
           Inc(Long);
           PosXy(X,Y);
           If Long>N Then N:=Long;
         End;

       Key:=KeyBoard;
    End;

   Until (Key=27) OR (Key=13);
   S1:=Copy(S,1,Long);
   If Key=13 Then ReadStr:=True
    Else ReadStr:=False;
End;{*end ReadStr*}


Procedure CsOn(x,y:Byte);
var reg:Registers;
begin
   Reg.AX:=$200;
   Reg.BH:=GetPage;
   Reg.DH:=Y-1;
   Reg.Dl:=X-1;
   Intr($10,reg);
 End;

 Procedure CsOff; {**etein le curseur**}
 var reg:Registers;
  begin
     Posxy(1,CrtGetmaXY+1);
 END;

 {**Renvoie True si l'imprimante et un etat de imprimer**}

 Function GetPrn:Boolean;
 External {Win_Box};

 Function TestPrn:Byte;
 External {Win_Box};

{** Positione le curseur sur les cordonnes X et Y dans la page 0 **}
{** centre le texte dans le Ecran ou la fenetre active sur laligne Y **}

Procedure WriteCn(y:Byte;S:String);
External {Win_Box};

{** Ecrit un texte aux cordonnees X et Y **}

Procedure Putxy(x,y:Byte;S:String); {sans control cordones 80x25}
External {Win_Box};

Procedure Writexy(x,y:Byte;S:String);
External {Win_Box};

Procedure WriteChar(x,y,Count:Byte;Ch:Char);
External {Win_Box};



{========================================================================}
{ X,y :    Enplacement a ecrire dans la fenetre active                   }
{   N :    Nombre de caracteres a ecrire maximun                         }
{ note:    la fonction retourne un entier limite entre -32768..32767     }
{========================================================================}
Function ReadNum(x,y,N:Byte):Integer;
Const Ligne='      ';
Var Err,nn:Integer;
    Nstr:String[6];
    Lig:String[6];
    Ch:Char;
    fin:Boolean;
    Nc:Byte;
Begin
    Err:=1;
    nn:=0;
    Nc:=1;
    Lig:=Copy(Ligne,1,N);
    Gotoxy(X-1,Y);
    Write(' ',Lig);
    GotoXy(x,y);
    Nstr:='';
    KeyCaps(On);
    KeyNum(On);
    Repeat
       Ch:=ReadKey;
       If (Ord(Ch)=8) And (nc>1) Then
        Begin
           NStr:=Copy(NStr,1,LengTh(NStr)-1);
           Gotoxy(WhereX-1,Y);
           Write(' ');
           Gotoxy(WhereX-1,Y);
           Nc:=Nc-1;
        End
         Else
           If (Ord(Ch)<>13) And (Nc<=N) and (Ch in['0'..'9','-']) then
            Begin
               NStr:=NStr+Ch;
               Write(Ch);
               Nc:=nc+1;
            End;

       If ((Ord(Ch)=13) And (Nstr<>'')) OR (Nc>N)  Then
        Begin
           {$R-}
           Val(Nstr,nn,Err);
           {$R+}
           If Err<>0 Then
            Begin
               Ch:=' ';
               Gotoxy(x-1,y);
               Write(' ',Lig);
               GotoXy(x,y);
               Nc:=1;NStr:='';
            End;
        End;

   Until ((Nstr='') And (Ord(Ch)=13)) OR (Err=0);
   KeyCaps(Off);
   KeyNum(Off);
   If Err=0 Then ReadNum:=nn
    Else ReadNum:=0;
   Beep;
End;




Function ReadReal(x,y,N:Byte;Var Ent:Byte):Real;
Const Ligne='           ';
Var Err:Integer;
    nn:Real;
    Nstr:String[11];
    Lig:String[11];
    Ch:Char;
    nc:Byte;
    fin:Boolean;
Begin
    Err:=1;
    nn:=0;
    Nc:=1;
    Lig:=Copy(Ligne,1,N);
    Gotoxy(X-1,Y);
    Write(' ',Lig);
    GotoXy(x,y);
    Nstr:='';
    {KeyCaps(On);}
    KeyNum(On);
    If Ent In[45,48..57] Then Ch:=Chr(Ent)
    Else Ch:='#';
    Repeat
       If (Ord(Ch)=8) And (nc>1) Then
        Begin
           NStr:=Copy(NStr,1,LengTh(NStr)-1);
           Gotoxy(WhereX-1,Y);
           Write(' ');
           Gotoxy(WhereX-1,Y);
           Nc:=Nc-1;
        End
         Else
           If (Ord(Ch)<>13) And (Nc<=N) and (Ch in['0'..'9','-','.']) then
            Begin
               NStr:=NStr+Ch;
               Write(Ch);
               Nc:=nc+1;
            End;
       Ch:=ReadKey;
       If ((Ord(Ch)=13) And (Nstr<>'')) OR (Nc>N)  Then
        Begin
           {$R-}
           Val(Nstr,nn,Err);
           {$R+}
           If Err<>0 Then
            Begin
               Ch:=' ';
               Gotoxy(x-1,y);
               Write(' ',Lig);
               GotoXy(x,y);
               Nc:=1;NStr:='';
            End;
        End;

   Until ((Nstr='') And (Ord(Ch)=13)) OR (Err=0) OR (Ord(ch)=27);
   {KeyCaps(Off);}
   If Err=0 Then ReadReal:=nn
    Else ReadReal:=0;
   Ent:=Ord(Ch);
   Beep;
End;



{**Renvoie le nombre d'octets necesaires … la sauvegarde de la region**}
{**Rectangulaire de Ecran specifiee, le nombre et arrondi au kilo octects**}

Function CrtSize(X1,Y1,X2,Y2:Byte):Word;
External {Win_Box};

{**Effectue une sauvegarde par octets de la region delimite**}

Procedure ReadBuf(X1,Y1,X2,Y2:Byte;Var Buf);
External {Win_Box};

{**Dessine une image par octets sauvegardee par GetImage**}

Procedure WriteBuf(X1,Y1,X2,Y2:Byte;Var Buf);
External {Win_Box};

{**dessine un Rectangle sur les cordonees**}
{**avec une forme qui peut etre simple traze ou Double**}

Procedure Rectangle(x1,y1,x2,y2:Byte;Var Cadre:CadreChars);
External {Win_Box};

{**inverse la region de le ecran  delimite par les cordonees**}

Procedure HighBox(x1,y1,X2,Y2,Colori:Byte);
External {Win_Box};

Procedure BoxColor(X1,Y1,X2,Y2,Colori:Byte);
External {Win_Box};

{**Rempli un rectangle avec un caractere determine**}
{**le caractere peut etre un code ASCII … eviter un code de control**}

Procedure BoxFill(x1,y1,X2,Y2:Byte;Ch:Char);
External {Win_Box};

{**Sauvegarde un ecran entier sur un fichier dans le disque designe par**}
[**par la constante type DisqueVirtuel, le numero donne a l'ecran repere**}
{**le ecran**}

Function GetCursor : Word;       {*Renvoie l'aspect du curseur*}
var
  Reg : Registers;
begin
  with Reg do
  begin
    AH := 3;
    BH := 0;
    Intr($10, Reg);
    GetCursor := CX;
  end; { Reg }
end; {*GetCursor*}



procedure SetCursor(NewCursor : Word);      {*Definit l'aspect du curseur*}
var
  Reg : Registers;
begin
  with Reg do
  begin
    AH := 1;
    BH := 0;
    CX := NewCursor;
    Intr($10, Reg);
  end; { with }
end; { SetCursor }


function PS2 : Boolean;
{ Renvoit True si vous travaillez avec un adaptateur video PS/2 }
var
  Regs : Registers;
begin
  Regs.AX := $1A00;
  Intr($10, Regs);
  PS2 := ((Regs.AL and $FF) = $1A) and
         ((Regs.BL and $FF) in [$07, $08, $0B, $0C]);
end; {*PS2*}



Procedure Screen_Init;
{ Detecte l'adaptateur video et
initialise differentes variables en consequence }
var
  Reg : Registers;
begin
  OldMode := LastMode;
  Reg.AH := $0F;
  Intr($10, Reg);     {* Cherche le mode video actuel *}
  if Reg.AL <> 7 then
  begin
    if EGAInstalled then
    begin
      if PS2 then
        VideoType := VGA
      else
        VideoType := EGA;
    end
    else begin
      if PS2 then
        VideoType := MCGA
      else
        VideoType := CGA;
    end;
    ScreenPtr := Ptr($B800, 0);
    BaseEcran := Ptr($B800, 0);
    if Reg.AL < 2 then
      CrtGetMaxX := 40
    else
      CrtGetMaxX := 80;
  end
  else begin
    VideoType := MDA;
    ScreenPtr := Ptr($B000, 0);
    BaseEcran := Ptr($B000, 0);
    CrtGetMaxX := 80;
  end;
   CrtGetMaxY := Hi(WindMax)+1;
  {*Res_Cursor := GetCursor;*}
  if (CrtGetMaxY = MinGetMaxEcranY) and (VideoType <> CGA) then
    InsCursor := InsCursorLarge
  else
    InsCursor := InsCursorSmall;
  TailleEcran:=MemW[$40:$4C];
end; {* Screen.Init *}

Procedure Screen_VGA;
{* Bascule l'affichage en 43/50-ligne *}
begin
  if CrtGetMaxY = MinGetMaxEcranY then
  begin
    TextMode(Lo(LastMode) + Font8x8);
    InsCursor := InsCursorSmall;
  end
  else begin
    TextMode(Lo(LastMode));
    InsCursor := InsCursorLarge;
  end;
  CrtGetMaxY:=(Hi(WindMax)+1);

  {*GetmaxY:=Mem[$40:$84]+1;*}
  TailleEcran:=MemW[$40:$4C];
end; {* Screen_Vga *}



Procedure ScreenLine25;
Begin
   {*Restaure le mode ecran et l'aspect curseur anterieurs au programme*}
   TextMode(OldMode);
   Screen_Init;
End;



procedure ClearScreen(X1, Y1, X2, Y2, Attrib : Word);
{* Efface une zone de l'ecran *}
var
  Reg : Registers;
begin
  if (X1 > X2) or (Y1 > Y2) then   { Valeurs illegales }
    Exit;
  with Reg do
  begin
    AX := $0600;              { Efface l'ecran par routine BIOS }
    BH := Attrib;
    CH := Pred(Y1);
    CL := Pred(X1);
    DH := Pred(Y2);
    DL := Pred(X2);
    Intr($10, Reg);
  end; { with }
end; { ClearScreen }



{**SCREEN**}

procedure MoveToScreen(var Source, Dest; Len : Word);
 external {SCREEN};

{**Deplacement de zones memoire entre memoire "normale" et memoire ecran**}
{**voir le source dans SCREEN.ASM**}

procedure MoveFromScreen(var Source, Dest; Len : Word);
 external  {SCREEN};

{**Deplacement de zones memoire entre memoire ecran et memoire "normale" **}
{**voir le source dans SCREEN.ASM**}

procedure MoveText(OldX1, OldY1, OldX2, OldY2, NewX1, NewY1 : Word);
{**Deplace une zone de texte en une nouvelle position de l'ecran**}
var
  Counter, Len : Word;
begin
  if (OldX2 < OldX1) or (OldY2 < OldY1) then
    Exit;
  Len := Succ(OldX2 - OldX1) shl 1;
  if NewY1 < OldY1 then
  begin     {* Deplacement en avant, ligne par ligne *}
    for Counter := 0 to OldY2 - OldY1 do
      MoveFromScreen(ScreenPtr^[OldY1 + Counter, OldX1],
                     ScreenPtr^[NewY1 + Counter, NewX1], Len)
  end
  else begin  {* Deplacement en arriŠre, ligne par ligne *}
    for Counter := OldY2 - OldY1 downto 0 do
      MoveFromScreen(ScreenPtr^[OldY1 + Counter, OldX1],
                     ScreenPtr^[NewY1 + Counter, NewX1], Len)
  end;
end; { MoveText }



procedure ScrollText(Dir : Direction; X1, Y1, X2, Y2, Amt, Attrib : Word);
{**Translation du texte le texte est translate puis la zone non concernee est remise a blanc**}
begin
  case Dir of
    Up : begin
      MoveText(X1, Y1 + Amt, X2, Y2, X1, Y1);
      ClearScreen(X1, Succ(Y2 - Amt), X2, Y2, Attrib);
    end;
    Down : begin
      MoveText(X1, Y1, X2, Y2 - Amt, X1, Succ(Y1));
      ClearScreen(X1, Y1, X2, Pred(Y1 + Amt), Attrib);
    end;
    Left : begin
      MoveText(X1 + Amt, Y1, X2, Y2, X1, Y1);
      ClearScreen(Succ(X2 - Amt), Y1, X2, Y2, Attrib);
    end;
    Right : begin
      MoveText(X1, Y1, X2 - Amt, Y2, X1 + Amt, Y1);
      ClearScreen(X1, Y1, Pred(X1 + Amt), Y2, Attrib);
    end;
  end; {*case*}
end; {*ScrollText*}



procedure ClrscrFinLineXY(Col : ScreenColoneRange; Row : ScreenLineRange);
{*Efface la fin de la ligne*}
begin
  GotoXY(Col, Row);
  ClrEOL;
end; {*ClrscrinLineXY*}



Procedure WriteCar(x,Y:Byte;Caractere:Char);
Var Reg:Registers;
Begin
   PosXy(x,y);
   Reg.AX:=9 shl 8 + Ord(Caractere);
   Reg.BL:=GetFond Shl 4 + Char_Color;
   Reg.BH:=GetPage;
   Reg.CX:=1;
   Intr($10,Reg);
End;



Procedure WriteClip(x,Y:Byte;Car:String;Clip:Byte);
Var Reg:Registers;
    I:Byte;
Begin
   For i:=0 TO Length(Car)-1 DO
   Begin
   PosXy(x+i,y);
   Reg.AX:=9 shl 8 + Ord(Car[i+1]);
   Reg.BL:=GetFond Shl 4 + Char_Color + Clip ;
   Reg.BH:=GetPage;
   Reg.CX:=1;
   Intr($10,Reg);
   End;
End;



Function Babi_Ti(NomA:String;U:Byte):String;
Var Nom1:String;
    i:Byte;
    car:Char;
Begin
   Nom1:='';
   Case U Of
    1:  For i:=1 To Length(NomA) DO
         Begin
          Car:=NomA[i];
          If Car=#191 Then Nom1:=Nom1+#32
           Else
          Nom1:=Nom1+Chr(Ord(Car)-70);
         End;
    2:  For i:=1 To Length(NomA) DO
         Begin
          Car:=NomA[i];
          If Car=#145 Then Nom1:=Nom1+#32
           Else
          Nom1:=Nom1+Chr(Ord(Car)-119);
         End;
    3:  For i:=1 To Length(NomA) DO
         Begin
          Car:=NomA[i];
          If Car=#250 Then Nom1:=Nom1+#32
           Else
          Nom1:=Nom1+Chr(Ord(Car)-127);
         End;
   End;
   Babi_ti:=nom1;
End;



Function Code_Babi_Ti(NomA:String;U:Byte):String;
Var Nom1:String[80];
    i:Byte;
    car:Char;
Begin
   Nom1:='';
   Case U Of
    1:  For i:=1 To Length(NomA) DO
         Begin
          Car:=NomA[i];
          If Ord(Car)=32 Then Nom1:=Nom1+#191
           Else
          Nom1:=Nom1+Chr(Ord(Car)+70);
         End;
    2:  For i:=1 To Length(NomA) DO
         Begin
          Car:=NomA[i];
          If Car=#32 Then Nom1:=Nom1+#145
           Else
          Nom1:=Nom1+Chr(Ord(Car)+119);
         End;
    3:  For i:=1 To Length(NomA) DO
         Begin
          Car:=NomA[i];
          If Car=#32 Then Nom1:=Nom1+#250
           Else
          Nom1:=Nom1+Chr(Ord(Car)+127);
         End;
   End;
   Code_Babi_ti:=nom1;
End;



Begin
    GetPage:=0;
    Res_Cursor:=GetCursor;
    TextMode(LastMode);
    {**ClearScreen(X1, Y1, X2, Y2, Attrib : Word);**}
    Screen_Init;

    {**Selectione la page ecran active Page 0**}
    Regg.AH:=5;
    Regg.AL:=Getpage;
    Intr($10,Regg);
    {**initialise disque virtuel**}
    {**Disque_Max;**}
    CheckSnow:=False;
    TextBackGround(Black);
    TextColor(White);
End.

©® document original sources pascal
  
Page Last Updated: Juin 27, 2011 | Page Editor: A. Ara | SiteMap Dans Une Autre Galaxie
Cet emplacement web non-commercial, et totalement libre & indépendant de tout les parti politique ou d'organisme officiel de toute nature. Nous réflexions sont exclusivement l'avis de personnes qui rejettent le massacre que la société fait aux animaux pour tout motif.