La Commande Numérique sur la Production Bois

(*****************************************************
 EDNUM version 3.001e
 programmation commande numerique Num 750/760F
 Copyright (S) 1997-2010
 programmeur du logiciel A.Ara
 64150 Mourenx ville France.
 Licence d'utilisation accord dans un but démonstratif
 la vente du logiciel et interdite.
 Numero de serie 00-331-7431-A1133071e
******************************************************)
{==============  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 ScreenLine50;**)
  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 ? 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;

{***************************************************************************}
Function Filedate(F: String) : Longint;
 { Verifie la date enregitrement }
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; {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<>^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-1FinBuf 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<=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<>^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 (LongLength(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);
  (**Reg.AX:=$200;
     Reg.BH:=GetPage;
     Reg.DH:=GetmaxY+1;
     Reg.Dl:=0;
     Intr($10,reg);**)
 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 ? 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;
(******** anule le 2010 pour ordinteur(PX)******
Procedure ScreenLine50;
Begin
   Screen_VGA;
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 ? 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.