Sources▲
Principaux fichiers sources▲
Voici les principaux fichiers sources du programme EDNUM. Ils ont été écrits avec Turbo Pascal et Turbo Assembler.
Unité BOX13.PAS▲
Sélectionnez
(*****************************************************
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.Win_Box.ASM▲
Sélectionnez
;=============================================
; 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 ================
; Fichier WIN_BOX.ASM
; Fichier assembleur utilise par l'unit Box13.pas
;=============================================
TITLE WIN_BOX
LOCALS @@
;=====================================
; Structure de donnees pour les coordonnees
;=====================================
X EQU (BYTE PTR 0)
Y EQU (BYTE PTR 1)
;=====================================
; Equivalences de l'espace de travail BIOS
;=====================================
CrtMode EQU (BYTE PTR 49H)
CrtWidth EQU (BYTE PTR 4AH)
DATA SEGMENT WORD PUBLIC
;===========================
; Donnees externes de l'unite Crt
;===========================
EXTRN CheckSnow:BYTE,WindMin:WORD,WindMax:WORD,TextAttr:BYTE
EXTRN GetMaxX:BYTE,GetMaxY:BYTE
DATA ENDS
CODE SEGMENT BYTE PUBLIC
ASSUME CS:CODE,DS:DATA
;=====================================
; PROCEDURE Writexy(X, Y: Byte; S: String);
;=====================================
PUBLIC Writexy
Writexy:
PUSH BP
MOV BP,SP
LES BX,[BP+6] ;charge le pointeur de la chaine S
MOV CL,ES:[BX] ;charge dans CL la longeur de la chaine
MOV DL,[BP+12] ;charche X
MOV DH,[BP+10] ;charche Y
MOV SI,OFFSET CS:CrtWriteStr
CALL CrtWrite
POP BP
RETF 8
;==================================
; PROCEDURE Putxy(X, Y: Byte; S: String);
;==================================
PUBLIC Putxy
Putxy:
PUSH BP
MOV BP,SP
LES BX,[BP+6] ;charge le pointeur de la chaine S
MOV CL,ES:[BX] ;charge dans CL la longeur de la chaine
MOV DL,[BP+12] ;charche X
MOV DH,[BP+10] ;charche Y
MOV SI,OFFSET CS:CrtWriteStr
CALL CrtEcran
POP BP
RETF 8
;==================================
; PROCEDURE WriteCn(Y: Byte; S: String);
;==================================
PUBLIC WriteCn
WriteCn:
PUSH BP
MOV BP,SP
LES BX,[BP+6] ;charge le pointeur de la chaine S
MOV CL,ES:[BX] ;charge dans CL la longeur de la chaine
MOV AL,windmax.X ;Charge la cordone x max d'ecran
INC AL
MOV AH,WindMin.X
INC AH
SUB AL,AH
INC AL
XOR AH,AH
SUB AL,CL ;soustrait la longeur de la chaine
JC Resul0
MOV DL,2 ;charge 2 pour diviseur
Div DL ;divise AL/2
INC AL
MOV DL,AL ;charche X
XOR AX,AX ;remet AX ? 0
MOV DH,[BP+10] ;charche Y
MOV SI,OFFSET CS:CrtWriteStr
CALL CrtWrite
Resul0: POP BP
RETF 6
;==============================================
; PROCEDURE WriteChar(X, Y, Count: Byte; Ch: Char);
;==============================================
PUBLIC WriteChar
WriteChar:
PUSH BP
MOV BP,SP
MOV CL,[BP+8]
MOV DL,[BP+12] ;X
MOV DH,[BP+10] ;y
MOV SI,OFFSET CS:CrtWriteChar
CALL CrtWrite
POP BP
RETF 8
;========================================
; PROCEDURE BoxFill(x1,y1,x2,y2:Byte; Ch: Char);
; BP+14,12,10 8] [BP+6]
;========================================
PUBLIC BOXFill
BOXFill:
MOV SI,OFFSET CS:CrtWriteChar
JMP SHORT CommonFill
;=========================================
; PROCEDURE ReadBuf(x1,y1,x2,y2:Byte; var Buf);
; BP+16,14,12,10] [BP+6]
;=========================================
PUBLIC ReadBuf
ReadBuf:
MOV SI,OFFSET CS:CrtReadWin
JMP SHORT CommonWin
; PROCEDURE WriteBuf(x1,y1,x2,y2:Byte; var Buf);
; BP+16,14,12,10] [BP+6]
PUBLIC WriteBuf
WriteBuf:
MOV SI,OFFSET CS:CrtWriteWin
JMP SHORT CommonWin
;====================================
; Routine commune pour ReadWin/WriteWin
;====================================
CommonWin:
PUSH BP
MOV BP,SP
MOV AL,[BP+12] ;X2
MOV AH,[BP+10] ;Y2
MOV CL,[BP+16] ;X1
MOV CH,[BP+14] ;Y1
CALL ControlBox
CMP AL,0
JE FinBuf
XOR AL,AL
XOR CX,CX
MOV DL,[BP+16] ;X1
DEC DL
MOV DH,[BP+14] ;Y1
DEC DH
MOV CL,[BP+12] ;X2
DEC CL
SUB CL,DL ;CL = X2-X1
INC CX
@@1: PUSH CX
PUSH DX
PUSH SI
CALL CrtBlock
POP SI
POP DX
POP CX
Mov AH,[BP+10] ;Y2
Dec AH
INC DH
CMP DH,AH ;Y1 <= Y2
JBE @@1
Finbuf: POP BP
RETF 12
;============================
; Block Apele par FillBox
;============================
CommonFill:
PUSH BP
MOV BP,SP
MOV AL,[BP+10] ;X2
MOV AH,[BP+8] ;Y2
MOV CL,[BP+14] ;X1
MOV CH,[BP+12] ;Y1
CALL ControlBox
CMP AL,0
JE FinFil
XOR AL,AL
XOR CX,CX
MOV DL,[BP+14] ;Charge X1
DEC DL
MOV DH,[BP+12] ;Charge Y1
DEC DH
MOV CL,[BP+10] ;Charge X2
DEC CL
SUB CL,DL
INC CX
@@1: PUSH CX
PUSH DX
PUSH SI
CALL CrtBlock
POP SI
POP DX
POP CX
Mov AH,[BP+8] ;Charge Y2
Dec AH
INC DH
CMP DH,AH
JBE @@1
FinFil: POP BP
RETF 10
;==============================================
; Cordones: AL = X2 AH = Y2
; CL = X1 CH = Y1
; Returne: AL = 1 si cordones son bonnes sino AL = 0
;==============================================
ControlBox:
CMP AL,GetMaxX ;80d
JG Exit
CMP AH,GetMaxY ;25d ou 50d
JG Exit
CMP CL,1
JL Exit
CMP CH,1
JL Exit
CMP CL,AL
JG Exit
CMP CH,AH
JG Exit
XOR CX,CX
XOR AH,AH
MOV AL,1
Ret
Exit: XOR CX,CX
XOR AX,AX
Ret
;===========================
; Envoie chaine vers l'ecran
;===========================
CrtWriteStr:
PUSH DS
MOV AH,TextAttr
LDS SI,[BP+6]
INC SI
JC @@4
@@1: LODSB
MOV BX,AX
@@2: IN AL,DX
TEST AL,1
JNE @@2
CLI
@@3: IN AL,DX
TEST AL,1
JE @@3
MOV AX,BX
STOSW
STI
LOOP @@1
POP DS
RET
@@4: LODSB
STOSW
LOOP @@4
POP DS
RET
;===============================
; Ecriture de caracteres vers l'ecran
;===============================
CrtWriteChar:
MOV AL,[BP+6]
MOV AH,TextAttr
JC @@4
MOV BX,AX
@@1: IN AL,DX
TEST AL,1
JNE @@1
CLI
@@2: IN AL,DX
TEST AL,1
JE @@2
MOV AX,BX
STOSW
STI
LOOP @@1
RET
@@4: REP STOSW
RET
;=====================================
; Lecture de l'ecran vers le tampon fenetre
;=====================================
CrtReadWin:
PUSH DS
PUSH ES
POP DS
MOV SI,DI
LES DI,[BP+6] ;Charge dans DI le pointeur
CALL CrtCopyWin
MOV [BP+6],DI
POP DS
RET
;=====================================
; Recopie du tampon de fenetre vers l'ecran
;=====================================
CrtWriteWin:
PUSH DS
LDS SI,[BP+6]
CALL CrtCopyWin
MOV [BP+6],SI
POP DS
RET
;===============================
; Routine de copie de tampon fenetre
;===============================
CrtCopyWin:
JC @@4
@@1: LODSW ;charge dans AX bouble mot
MOV BX,AX
@@2: IN AL,DX
TEST AL,1
JNE @@2
CLI
@@3: IN AL,DX
TEST AL,1
JE @@3
MOV AX,BX
STOSW
STI
LOOP @@1
RET
@@4: REP MOVSW
RET
;========================================
; Realise operation ecran rapor a la fenetre active
; In CL = Longueur tampon
; SI = Pointeur sur procedure Write
; BP = Pointeur sur cadre de pile
; DL = cordone X
; DH = cordone Y
;========================================
CrtWrite:
DEC DL
ADD DL,WindMin.X
JC CrtExit
CMP DL,WindMax.X
JA CrtExit
DEC DH
ADD DH,WindMin.Y
JC CrtExit
CMP DH,WindMax.Y
JA CrtExit
XOR CH,CH
JCXZ CrtExit
MOV AL,WindMax.X
SUB AL,DL
INC AL
CMP CL,AL
JB CrtBlock
MOV CL,AL
;==============================
; Realise l'operation ecran
; In CL = Longueur tampon
; DX = Coordonnees ecran
; SI = Pointeur sur procedure
;=============================
CrtBlock:
MOV AX,40H
MOV ES,AX
MOV AL,DH
MUL ES:CrtWidth
XOR DH,DH
ADD AX,DX
SHL AX,1
MOV DI,AX
MOV AX,0B800H
CMP ES:CrtMode,7
JNE @@1
MOV AH,0B0H
@@1: MOV ES,AX
MOV DX,03DAH
CLD
CMP CheckSnow,1
JMP SI
; Sortie des routines ecran
CrtExit:
RET
;============================================
; Realise operation ecran rapor a la fenetre 80x25
; In CL = Longueur tampon
; SI = Pointeur sur procedure Write
; BP = Pointeur sur cadre de pile
; DL = cordone X DH = cordone Y
;=============================================
CrtEcran:
CMP DL,1 ; cordone X
JB CrtExit ; saut si inferieur a 1
CMP DH,1 ; cordone Y
JB CrtExit ; saut si inferieur a 1
CMP DL,80
JA CrtExit ; saut si superieur a 80
Dec DL ; DL contien X
DEC DH ; Dh contien Y
CMP DH,GetMaxY
JA CrtExit ; saut si superieur a 25
XOR CH,CH
JCXZ CrtExit
MOV AL,GetMaxX ; charge AL 80
SUB AL,DL ; sustrait , AL = (AL-DL)
INC AL
CMP CL,AL
JB CrtBlock
MOV CL,AL
JMP SHORT CrtBlock
;========================================
; function CrtSize(x1,y1,x2,y2:Byte): Word;
; BP+ 12,10,8, 6
;========================================
PUBLIC CrtSize
CrtSize:
PUSH BP
MOV BP,SP
PUSH BX
MOV AL,[BP+8]
DEC AL
MOV AH,[BP+6]
DEC AH
MOV BL,[BP+12]
DEC BL
MOV BH,[BP+10]
DEC BH
;AX contien X2,Y2
SUB AX,BX ;BX contien X1,Y1
ADD AX,101H
MUL AH
SHL AX,1
POP BX
POP BP
RETF 8
;================ Debut BoxChar ===================
;PROCEDURE Rectangle(X1, Y1, X2, Y2: Byte; Cadre:Cadreforme);
PUBLIC Rectangle
Rectangle:
PUSH BP
MOV BP,SP
PUSH DI
PUSH SI
MOV AL,[BP+10] ;y2
MOV AH,[BP+14] ;y1
CMP AL,AH
JNA @@3 ;si Al<=AH / y2 <= Y1 fin
DEC AL ;initialise cordones Ecran Max = 0,0 et 79,24
DEC AH
MOV [BP+10],AL ;ecri les cordonees su la pile decrementes
MOV [BP+14],AH
MOV AL,[BP+12] ;cordonee X2
MOV AH,[BP+16] ;cordonee X1
CMP AL,AH ;si AL<=AH / X2 <= X1 fin
JNA @@3
DEC AL
DEC AH
MOV [BP+12],AL
MOV [BP+16],AH
LES DI,[BP+6] ;forme de cadre simple ou double
Call BlockRectangle1
@@3: POP SI
POP DI
POP BP
RETF 12
BlockRectangle1: ;block depandant de procedure Rectangle
MOV DL,[BP+16] ;X1 Affiche angle1 haut Gauche
MOV DH,[BP+14] ;y1
XOR CX,CX
MOV CL,01
MOV AL,ES:[DI+0]
Call BlockWrite1
MOV DL,[BP+16] ;X1 Trace ligne horizontal Haut
MOV DH,[BP+14] ;y1
INC DL
XOR CX,CX
MOV CL,[BP+12] ;nonbre de fois ? afficher
SUB CL,[BP+16] ;CL = X2-X1
MOV AL,ES:[DI+1]
Call BlockWrite1
MOV DL,[BP+12] ;X2 Affiche angle2 haut droite
MOV DH,[BP+14] ;y1
XOR CX,CX
MOV CL,1
MOV AL,ES:[DI+2]
Call BlockWrite1
MOV DL,[BP+16] ;X1 Affiche angle3 bas gauche
MOV DH,[BP+10] ;y2
XOR CX,CX
MOV CL,01
MOV AL,ES:[DI+3]
Call BlockWrite1
MOV DL,[BP+16] ;X1 Trace ligne horizontal Bas
MOV DH,[BP+10] ;y2
INC DL
XOR CX,CX
MOV CL,[BP+12] ;nonbre de fois ? afficher
SUB CL,[BP+16] ;CL = X2-X1
MOV AL,ES:[DI+1]
Call BlockWrite1
MOV DL,[BP+12] ;X2 Affiche angle4 bas droite
MOV DH,[BP+10] ;y2
XOR CX,CX
MOV CL,1
MOV AL,ES:[DI+4]
Call BlockWrite1
MOV DL,[BP+16] ;X1 Traze ligne Hauteur Gauche
MOV DH,[BP+14] ;y1
INC DH
XOR CX,CX
MOV CL,1
MOV AL,ES:[DI+5]
Call BlockWriteHaut
MOV DL,[BP+12] ;X2 Trace ligne Hauteur Droite
MOV DH,[BP+14] ;y1
INC DH
XOR CX,CX
MOV CL,1
MOV AL,ES:[DI+5]
Call BlockWriteHaut
MOV AH,2 ;positione curseur interieur de cadre
MOV BH,0
MOV DL,[BP+16] ;X1
MOV DH,[BP+14] ;y1
INC DL
INC DH
INT 10h
RET
;====================================
; Entrees: DL cordonee " X "
; DH cordonee " Y "
; CX nombre de caracteres ? ecrire
; AL Caractere ASCII
;====================================
BlockWrite1: ;block depandant de procedure BoxChar
MOV AH,2 ;fonction positione curseur sur l'ecran
MOV BH,0
INT 10h
MOV AH,9 ;fonction ecrire sur l'ecran
MOV BH,0
MOV BL,TextAttr
INT 10h
RET
;======================================
; Entrees: DH cordonee: " Y1"
; DL cordonee: " X1 ou X2 "
; AL caractere ASCII
; CX nombre de caracteres ? ecrire
; Sortie: Cant Y1 >= Y2
;======================================
BlockWriteHaut: ;block depandant procedure BoxChar
@@2: CMP DH,[BP+10] ;controle si y1 < que Y2
JGE @@1
MOV AH,2 ;foction positione curseur
MOV BH,0
INT 10h
MOV AH,9 ;foction ecrire ecran
MOV BH,0 ;page ecran ? ecrire
MOV BL,TextAttr ;atribut de caractere
INT 10h
INC DH ;incremente cordonee Y1
JMP @@2 ;saut
@@1: RET
;==== End Rectangle ====
;================================================
; Function GetkeyByte:Byte revoit le nø de la touche Tape
;================================================
PUBLIC GetKeyByte
GetKeyByte:
MOV AH,1
Int 16h
Jz @@2 ;PasCaractere Disponibles
MOV AH,0
Int 16h
CMP AL,0
Je @@1 ;Si AL =0 Saut
RetF ;Sino Resulta dans AL
@@1: MOV AL,AH
RetF
@@2: MOV AX,0000H
RetF
;==========================
;Function GetPrn:Boolean
;==========================
PUBLIC GetPrn
GetPrn:
MOV AH,2
MOV DX,0
Int 17h
CMP AH,90h
JNE @@1
MOV AL,01
RETF
@@1: MOV AL,00
RETF
;========================
;Function TestPrn:Integer
;========================
PUBLIC TestPrn
TestPrn:
MOV AH,2
MOV DX,0
Int 17h
MOV AL,AH
RETF
;===========================================
;Procedure ClearBufKey vide le buffer du clavier
;===========================================
PUBLIC ClearBufKey
ClearBufKey:
MOV AH,1 ;fonction: encore caracteres dans buffer ?
Int 16h ;appeler interruction clavier BIOS
JE @@1 ;plus de daractere dans le buffer -->Fin
XOR AH,AH ;fonction retire caractere du buffer
Int 16h
JMP ClearBufKey ;tester si encore des caracteres
@@1: XOR AX,AX ;tout est en ordre
RETF ;retour au programme d'appel
;================================
; Function GetTexte:Byte;
;================================
PUBLIC GetTexte
GetTexte:
XOR AX,AX
MOV AL,[TextAttr]
SHL AL,1
SHL AL,1
SHL AL,1
SHL AL,1
XOR AH,AH
SHR AL,1
SHR AL,1
SHR AL,1
SHR AL,1
RETF
;==========================
;Function GetFond:Byte;
;==========================
PUBLIC GetFond
GetFond:
XOR AX,AX
MOV AL,[TextAttr]
SHL AL,1
XOR AH,AH
SHR AL,1
SHR AL,1
SHR AL,1
SHR AL,1
SHR AL,1
RETF
;========================
;Function SegEcran:Word;
;========================
PUBLIC SegEcran
SegEcran:
MOV AH,0FH ;Focntion lire parametres video du BIOS
INT 10H
CMP AL,7 ;est une carte mono
JNE @@1 ;nom ----> @@1
MOV AX,0B000h ;carte Mono
RET
@@1: MOV AX,0B800h ;carte Couleur
RETF
;===============================
;Function OfsEcran(X,Y:Byte):Word;
;===============================
PUBLIC OfsEcran
OfsEcran:
PUSH BP
MOV BP,SP
PUSH ES
MOV DL,[BP+8] ;cordone "X"
MOV DH,[BP+6] ;cordone "Y"
DEC DL
DEC DH
MOV AX,40H ;Segment variables video du BIOS
MOV ES,AX ;ES Segment variables Bios
MOV AL,DH ;AL cordonnee ligne =(Y-1)
MUL ES:Byte Ptr [4AH] ;ES:4Ah = nonbre de colones par ligne BIOS
XOR DH,DH ;resutat de multiplication dans AX
ADD AX,DX ;addition la cordonnee (X-1)
SHL AX,1 ;decalage ? gauche de 1 bit = AX * 2
POP ES
POP BP
RETF 4
;========================================
;Procedure HigthBox(x1,y1,x2,y2:Byte;Color:Byte);
;========================================
PUBLIC HighBox
HighBox:
PUSH BP
MOV BP,SP
MOV CL,[BP+14] ;cordone X1
MOV CH,[BP+12] ;cordone Y1
MOV AL,[BP+10] ;cordonee X2
MOV AH,[BP+8] ;cordonee Y2
CALL ControlBox
MOV DL,[BP+14] ;cordonee X1
MOV DH,[BP+12] ;Cordonee Y1
DEC DL
DEC DH
MOV AL,50H ;calcule l'adresse de x1,y1
MUL DH
XOR DH,DH
ADD AX,DX
Shl AX,1
INC AX ; AX + 1 pour l'attribut du caractere
MOV DI,AX ;Adresse de X1,Y1
MOV BX,AX ;Adresse de reserve
MOV AX,0B800H ;ecran couleur
PUSH AX
POP ES
MOV DL,[BP+12] ;cordonee Y1
MOV DH,[BP+8] ;cordonee Y2
@@3: CMP DL,DH ;texte Y1 et Y2
JNLE @@2 ;fin si y1 > Y2
MOV CL,[BP+10] ;cordonee X2
SUB CL,[BP+14] ;cordonee X1
INC CL
XOR CH,CH ;CL = longeur de la ligne
JCXZ @@2 ;Fin si CX = zero
MOV AL,17d
MOV AH,[BP+6] ;Code couleur pour l'inversement
MUL AH
MOV AH,AL
@@1: MOV AL,ES:[DI]
XOR AL,AH ;77H ;change le attribut du l'octet
MOV ES:[DI],AL
INC DI ;Incremente de deux pour trouver l'attribut suivant
INC DI
LOOP @@1
ADD BX,00A0H ;Adresse de reserve + 160d change de ligne
MOV DI,BX
INC DL ;y1 := y1+1
JMP @@3 ;Boucle
@@2: POP BP ;Fin
RETF 10
;=======================================
;Procedure BoxColor(x1,y1,x2,y2:Byte;Color:Byte);
;=======================================
PUBLIC BoxColor
BoxColor:
PUSH BP
MOV BP,SP
MOV DL,[BP+14] ;cordonee X1
MOV DH,[BP+12] ;Cordonee Y1
DEC DL
DEC DH
MOV AL,50H ;calcule l'adresse de x1,y1
MUL DH
XOR DH,DH
ADD AX,DX
Shl AX,1
INC AX ; AX + 1 pour l'attribut du caractere
MOV DI,AX ;Adresse de X1,Y1
MOV BX,AX ;Adresse de reserve
MOV AX,0B800H ;ecran couleur
PUSH AX
POP ES
MOV DL,[BP+12] ;cordonee Y1
MOV DH,[BP+8] ;cordonee Y2
@@3: CMP DL,DH ;texte Y1 et Y2
JNLE @@2 ;fin si y1 > Y2
MOV CL,[BP+10] ;cordonee X2
SUB CL,[BP+14] ;cordonee X1
INC CL
XOR CH,CH ;CL = longeur de la ligne
JCXZ @@2 ;Fin si CX = zero
MOV AL,17d
MOV AH,[BP+6] ;Code couleur
;MUL AH
;MOV AH,AL
@@1: MOV AL,ES:[DI]
Mov AL,AH ;77H ;change le attribut du l'octet
MOV ES:[DI],AL
INC DI ;Incremente de deux pour trouver l'attribut suivant
INC DI
LOOP @@1
ADD BX,00A0H ;Adresse de reserve + 160d change de ligne
MOV DI,BX
INC DL ;y1 := y1+1
JMP @@3 ;Boucle
@@2: POP BP ;Fin
RETF 10
CODE ENDS
END
;============================
; End de Fichier WIN_BOX.ASM
;============================Miniscul.ASM▲
Sélectionnez
;=============================================
; 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 Miniscul
; resulta sur fonction type String
;=================================
CODE SEGMENT BYTE PUBLIC
ASSUME CS:CODE
PUBLIC Miniscul
MajResult EQU DWORD PTR [BP+10]
MajChaine EQU DWORD PTR [BP+6]
;===========================
;Function Uppers(S:String):String;
;===========================
Miniscul PROC FAR
PUSH BP
MOV BP,SP
PUSH DS
LDS SI,MajChaine ;charge l'adresse de la chaine
LES DI,MajResult ;Charge l'adresse du resultat
CLD ;indicateur de direction ? 0
LODSB ;charge la longeur de la chaine
STOSB ;copie dans resultat
MOV CL,AL ;longeur de la chaine dans CX
XOR CH,CH ;met CH ? zero
JCXZ U3 ;Saut si Cx = 0
U1: LODSB ;charge caractere dans AL, incremente SI
CMP AL,'A' ;saut si caractre diferan de
JB U2
CMP AL,'Z' ;l'intervalle 'a' ? 'z'
JA U2
ADD AL,'a'-'A' ;converti en majuscule
U2: STOSB ;copie dans resultat
LOOP U1 ;boucle tant que cx diferan de zero
;d?cremente CX sans modifier les indicateurs
U3: POP DS ;depile Ds
POP BP ;depile Bp
Ret 4 ;Retour de pile 6 octets
Miniscul ENDP ;fin de procedure
CODE ENDS
END
;=============================
;End Fichier Miniscul
;=============================Uppers.ASM▲
Sélectionnez
;=============================================
; 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 Uppers.asm
; resulta sur fonction type String
;=================================
Code Segment byte public
assume CS:Code
PUBLIC Uppers
;===============================
; Function Uppers(s: String):String
;===============================
MajResult EQU DWORD PTR [BP+10]
MajChaine EQU DWORD PTR [BP+6]
Uppers Proc Far
Push BP
Mov BP,SP
Push DS
LDS SI,MajChaine
LES DI,MajResult
CLD
LODSB
STOSB
MOv CL,AL
XOR CH,CH
JCXZ U3
U1: LODSB
CMP AL,'a'
JB U2
CMP AL,'z'
JA U2
SUB AL,'a'-'A'
U2: STOSB
LOOP U1
U3: POP DS
POP BP
RET 4
Uppers ENDP
CODE ENDS
End
;=================================
; End Fichier Uppers.asm
;=================================Screen.ASM▲
Sélectionnez
;=============================================
; 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 Screen.ASM
;==================================
MODEL TPASCAL
LOCALS
DATASEG
EXTRN CheckSnow : BYTE
CODESEG
PUBLIC MoveToScreen, MoveFromScreen
;====================================================
; procedure MoveToScreen(var Source, Dest; Len : Word);
;
; Recopie une zone memoire entre RAM et memoire video en gerant
; un eventuel effet de neige sur certains ecrans CGA.
; Variables:
; Source : Pointeur long vers la zone RAM ? copier
; Dest : Pointeur long vers la zone video ? ecraser
; Len : Quantite d'octets ? copier
;=====================================================
Proc MoveToScreen Source : DWord, Dest : DWord, Len : Word
push ds
mov bh,[CheckSnow] ; Charge valeur de CheckSnow
lds si,[Source] ; Pointeur source dans DS:SI
les di,[Dest] ; Pointeur dest dans ES:DI
mov cx,[Len] ; Len dans CX
jcxz @@0 ; Fin si Len = 0
cmp si,di ; Teste si source est avant destination
jle @@1 ; Si oui, copie ? partir de la fin
cld ; Incrementation de copie de chainesnes
jmp short @@2
@@1:
add si,cx ; Amene SI et DI en fin de zones memoire
sub si,2
add di,cx
sub di,2
std ; Decrementation chaines
@@2:
cmp bh,0 ; Si CheckSnow = false, affichages rapides
je @@7
@@3:
shr cx,1 ; Conversion octets en mots
mov dx,3DAh ; DX pointe sur le port d'etat de CGA
mov bl,9
@@4:
lodsw ; Lecture d'un mot
mov bp,ax ; Le sauve dans BP
@@5:
in al,dx ; Lit l'etat du 6845
rcr al,1 ; Teste si en balayage ligne
jb @@5 ; Boucle si oui : on evite d'ecrire
; pendant ce temps. Il n'y a de temps que
; pour exactement 1 STOSW
cli ; Et surtout pas d'interruptions !
@@6:
in al,dx ; Lit l'etat du 6845
and al,bl ;Teste les deux balayages : si la carte video
; n'indique pas de balayage ligne pendant
; le balayage trame, on peut envoyer plusieurs
; caracteres pendant la trame
jz @@6 ; Boucle si = 0
mov ax,bp ;Lit le mot de l'ecran video
stosw ; Le sauve
sti ; Demasque les interruptions
loop @@4 ; Au suivant !
jmp short @@0
@@7:
shr cx,1 ; Conversion d'octets en mots
rep movsw
@@0:
pop ds ; Restaure DS
ret
ENDP
;==============================================================
; procedure MoveFromScreen(var Source, Dest; Len : Word);
;
; Recopie une zone de memoire video en memoire normale en gerant l'effet de
; neige des ancienness cartes CGA.
; Variables:
; Source : Pointeur long vers la zone video ? copier
; Dest : Pointeur long vers la zone memoire vive ? ecraser
; Len : Quantite d'octets ? copier
;===============================================================
Proc MoveFromScreen Source : DWord, Dest : DWord, Len : Word
push ds
mov bh,[CheckSnow]
lds si,[Source]
les di,[Dest]
mov cx,[Len]
jcxz @@0
cmp si,di
jle @@1
cld
jmp short @@2
@@1:
add si,cx
sub si,2
add di,cx
sub di,2
std
@@2:
cmp bh,0
je @@6
@@3:
shr cx,1
mov dx,3DAh
@@4:
in al,dx
rcr al,1
jb @@4
cli
@@5:
in al,dx
rcr al,1
jnb @@5
lodsw
sti
stosw
loop @@4
jmp short @@0
@@6:
shr cx,1
rep movsw
@@0:
pop ds
ret
ENDP
END
;=================================
; Fin Fichier Screen.ASM
;=================================Unité Get_key7.PAS▲
Sélectionnez
{============================================
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
============================================}
{===========================================}
Unite Get_key7.pas
============================================}
{$O+,F+}
Unit Get_Key7;
Interface
Const
Shift_D:Boolean=False;
Shift_G:Boolean=False;
Ctrl:Boolean=False; { press key Ctrl ok }
Alt:Boolean=False; { press key Alt ok }
Inser_mode:Boolean=True; { press key Inser ok }
Key_Code:Boolean=False; { code clavier etendue ok }
Function KeyBoard:Byte;
Procedure Beep;
Implementation
Uses crt,Dos;
Var Reg_DOS:Registers;
Procedure Beep;
{** Genere un bip grave **}
begin
Sound(4071);
Delay(50);
NoSound;
end;
{** Beep **}
Function KeyBoard:Byte;
Var ch:Char;
Begin
Reg_DOS.AX:=$0C00;
MsDos(Reg_DOS);
ch:=Readkey;
If Mem[0:$417] And 128 = 128 Then Inser_Mode:=True
Else Inser_mode:=False;
If Mem[0:$417] And 8 = 8 Then Alt :=True
Else Alt:=False;
If Mem[0:$417] And 4 = 4 Then Ctrl:=True
Else Ctrl:=False;
If Mem[0:$417] And 2 = 2 Then Shift_G:=True
Else Shift_G:=False;
If Mem[0:$417] And 1 = 1 Then Shift_D:=True
Else Shift_D:=False;
If (ch = #0) then
Begin
KeyBoard:=Ord(Readkey);
Key_Code:=True;
End
else
Begin
KeyBoard:=ord(ch);
Key_Code:=False;
end;
End; {** end keyBoard **}
End.Unité Graphe Trace.PAS▲
Sélectionnez
{============== FICHIER DE EDNUM =====================}
{ Unite Graphe Trace.pas Usinage machines a c.n. }
{ programmation Pascal }
{ Copyright (S) 1997-2011 }
{ programmeur du programme A.Ara }
{ 64150 Mourenx ville France. }
{ Licence d'utilisation accord dans un but démonstratif }
{ Unite Graphe Trace.pas: graphiques EDnum c.n du bois }
{=======================================================}
{=======================================================}
{ }
{ ED9FNUM comprend La fonction Miroir / ED Rotation }
{ les variables L0 .. L19 }
{ }
{=======================================================}
{$O+,F+}
Unit ED13FNUM;
Interface
{***define __TYPE_M100__} {** Si la machine demande de serrer la piece **}
{$IFDEF __Type_M100__}
Const Serrage_Piece:Boolean=False;
{$ENDIF}
Procedure InitGraphique;
Procedure GraPhique_Numeriqe(RepertoireFile1,NomFile1:String);
Function SuprimeCommentaires(S:String):String;
Function VerifyLetreIso(SSS:String):Boolean;
Function Decode_Ligne(Var lig:Integer;Texte:String):Boolean;
Procedure Init_Table(uu:Integer);
Procedure Numerical;
Procedure Metre_un_Veille;
Implementation
Uses crt,Dos,GRAPH,
Crtkey,
Get_Key,
Buffs , {**}
Buff_Tex , {**}
NUM_Buff , {**}
VAR_NUM , {**}
OPEN_GPH , {**}
UFormule , {**}
UTIL7F , {**}
FONC_GXM , {**}
RepetG77; {**}
Const
LetreNotISO:set of Char = [#0..#9,#12,#14..#25,#27..#31,#33..#36,#38,#39,#59,#63,#91..#255];
Type ResolutionPreference = (Lower, Higher);
Var ix : Integer;
ReserveZ: Integer;
Snnn : String[3];
Scommand: String[6];
Modale : Boolean;
Function Decode_Ligne(Var lig:Integer;Texte:String):Boolean;
Label Finis;
Const
Commande1: Array[1..40] Of String[4] = ('G0', 'G00','G1', 'G01','G2', 'G02',
'G3', 'G03','G', 'GXY','GXYZ',
'M2', 'M02','M3', 'M03','M4', 'M04',
'M5', 'M05','M6', 'M06','G51','G59',
'G52','G79','G77','G54','G80','G81','G82',
'G83','G84','G85','G86','G87','G88',
'G89','G45','M100','M101'); {**G90','G91');***}
Var Recherche,tex :String;
i,u,NN,s,n,Z :Integer;
cc,a,x,Err :Integer;
_P,_ER,_Z,Vii :Real;
StrVar :String[40];
StrVar1 :String[40];
Valeur :Real;
NN_ligne :Longint;
Temporal :String[20];
Procedure Analise_Commande(xx:Byte);
var Trouve:Boolean;
u:Byte;
begin
i:=xx-1;
While (i>2) DO
begin
Trouve:=False;u:=1;
While (Not Trouve) And (u<=40) Do
begin
if (Tab128[i]=Commande1[u]) Then
begin
Temporal:=Tab128[i];
Tab128[i]:=Tab128[i-1];
Tab128[i-1]:=Temporal;
trouve:=True;
end;
Inc(u);
end;
Dec(i);
end;
end;
begin
if Ordinateur486 Then begin end;
For i:=1 To 20 DO Tab128[i]:='';
texte:=Uppers(Texte)+' ';
a:=1;x:=0;
cc:=length(texte);
z:=1;
Repeat
tex:=Copy(Texte,a,cc);
s:=pos(' ',tex);
Recherche:=Copy(tex,1,s);
n:=length(Recherche);
Inc(a,n);
if Recherche<>' ' Then
begin
Recherche:=Copy(Recherche,1,n-1);
if length(Recherche)>40 Then
begin
Erreur_Formule(4,0,Tab128[1]);
Decode_Ligne:=False;
Goto Finis;
end
else
begin
if (Modale) And (z=2) And (Pos('G',Texte)=0) Then
begin
if (((Recherche[1]='X') OR (Recherche[1]='Y')) And
((Scommand='G0') OR (Scommand='G1') OR
(Scommand='G2') OR (Scommand='G3') OR
(Scommand='G00') OR (Scommand='G01') OR
(Scommand='G02') OR (Scommand='G03') OR
(Scommand='G81') OR (Scommand='G82') OR
(Scommand='G83') OR (Scommand='G84') OR
(Scommand='G85') OR (Scommand='G86') OR
(Scommand='G87') OR (Scommand='G88') OR
(Scommand='G89'))) Then
begin
Tab128[z]:=Scommand;
Inc(z);
Tab128[z]:=Recherche;
end;
end;
if (Recherche='G') Then
begin
Recherche:='G1';
Scommand:='G1';
end;
if (z>1) And ((Recherche='GXY') OR (Recherche='GXYZ')) Then
begin
Scommand:='G1';
Tab128[z]:=Scommand;
Inc(z);
Tab128[z]:='X0';
Inc(z);
Tab128[z]:='Y0';
if Recherche='GXYZ'Then
begin
Inc(z);
Tab128[z]:='Z0';
end;
End
else
tab128[z]:=Recherche;
if (z>1) Then
begin
if (Recherche='G0') OR (Recherche='G00') Then Scommand:='G0'
else
if (Recherche='G1') OR (Recherche='G01') Then Scommand:='G1'
else
if (Recherche='G2') OR (Recherche='G02') Then Scommand:='G2'
else
if (Recherche='G3') OR (Recherche='G03') Then Scommand:='G3'
else
if ((Recherche='M2') OR (Recherche='M02') OR
(Recherche='M3') OR (Recherche='M03') OR
(Recherche='M4') OR (Recherche='M04') OR
(Recherche='M5') OR (Recherche='M05') OR
(Recherche='M6') OR (Recherche='M06') OR
(Recherche='G51') OR (Recherche='G79') OR
(Recherche='G77') OR (Recherche='G54') OR
(Recherche='G80') OR (Recherche='G59')) Then Scommand:='G1'
else
if ( (Recherche='G81') OR
(Recherche='G82') OR (Recherche='G83') OR
(Recherche='G84') OR (Recherche='G85') OR
(Recherche='G86') OR (Recherche='G87') OR
(Recherche='G88') OR (Recherche='G89')) Then
Scommand:=Recherche;
end;
end;
if (Tab128[z]='X') OR (Tab128[z]='Y') OR (Tab128[z]='Z') Then
Insert('0',Tab128[z],2);
Inc(z);
end;
Until (a>cc) OR (z=limite);
if z>2 Then Analise_Commande(z);
if ((Tab128[2]='G0') OR (Tab128[2]='G00') OR
(Tab128[2]='G1') OR (Tab128[2]='G01')) And
(POS('Z',Tab128[3])=1) And (Tab128[4]='') Then
begin
Tab128[2]:=Tab128[3];
Tab128[3]:='';
end;
U:=1;
if (Tab128[u]='M2') OR (Tab128[u]='M02') Then
begin
if (Tab128[u]='M02') Then Tab128[u]:='M2';
C^[Lig].CN:=Tab128[u];
if (u=1) And (Lig>1) Then
begin
StrVar:=Copy(C^[Lig-1].CN,2,Length(C^[Lig-1].CN));
{$R-}
Val(StrVar,Valeur,Err);
{$R+}
if (Err=0) Then
begin
Valeur:=Valeur+1;
Str(Round(Valeur),StrVar);
C^[Lig].CN:='N'+StrVar;
end;
end;
FIN_M2:=False;
Inc(Lig);
Decode_Ligne:=False;
Goto Finis;
End
else
if Tab128[u]<>'' Then
begin
if Tab128[1][1]<>'N' Then Erreur_Formule(20,0,Tab128[1])
else
begin
StrVar:=Copy(Tab128[1],2,Length(Tab128[u]));
{$R-}
Val(StrVar,NN_Ligne,Err);
{$R+}
if (Err<>0) OR (NN_Ligne>32767) Then Erreur_Formule(21,0,Tab128[1])
else
if N_Number>=NN_Ligne Then Erreur_Formule(26,0,Tab128[1])
else
N_number:=NN_Ligne;
end;
C^[Lig].CN:=Tab128[1];
Inc(u);
end;
if (Tab128[u]='M2') OR (Tab128[u]='M02') Then
begin
if (Tab128[u]='M02') Then Tab128[u]:='M2';
C^[Lig].CG:=Tab128[u];
FIN_M2:=False;
Inc(Lig);
Decode_Ligne:=False;
Goto Finis;
End
else
if (Tab128[u]='G91') OR (Tab128[u]='G90') Then
begin
if (Tab128[u]='G91') Then C^[Lig].CS:='G91'
else C^[Lig].CS:='G90';
Inc(u);
end;
if (Tab128[U]='M3') OR (Tab128[u]='M03') OR (Tab128[u]='M04') OR
(Tab128[u]='M4') OR (Tab128[u]='M5') OR (Tab128[u]='M05') Then
begin
if (Tab128[u]='M03') Then Tab128[u]:='M3';
if (Tab128[u]='M04') Then Tab128[u]:='M4';
if (Tab128[u]='M05') Then Tab128[u]:='M5';
cc:=2;
While (cc<Limite) And (Tab128[cc]<>'') DO
begin
if (Tab128[cc]='M3') OR (Tab128[cc]='M4') OR (Tab128[cc]='M5') Then
C^[Lig].CG:=Tab128[cc]
else
if Tab128[cc][1]='M' Then C^[Lig].CX:=Tab128[cc]
else
if Tab128[cc][1]='S' Then C^[Lig].CY:=Tab128[cc];
Inc(cc);
end;
end;
if Tab128[U]='G79' Then {Saut inconditionel/conditionel}
begin
C^[Lig].CG:=Tab128[U];
if Tab128[U+1][1]='N' Then C^[Lig].CX:=Tab128[U+1]
else
if Tab128[U+1][1]<>'' Then
begin
if (Condition(Tab128[U+1]) In[1,0]) Then
begin
C^[Lig].CY:=Tab128[U+1];
C^[Lig].CX:=Tab128[U+2];
End
else
begin
Erreur_Formule(5,Formule_Erreur,Tab128[1]);
Decode_Ligne:=False;
Goto Finis;
end;
end;
end;
if Tab128[U]='G77' Then {Repete bloc}
begin
C^[Lig].CG:=Tab128[U];
C^[Lig].CX:=Tab128[U+1];
C^[Lig].CY:=Tab128[U+2];
if POS('S',Tab128[U+3])>0 Then
begin
if I>0 Then
if (Not Controle_Formule(Copy(Tab128[U+3],2,Length(Tab128[U+3])),2)) Then
begin
Erreur_Formule(2,Formule_Erreur,Tab128[1]);
Decode_Ligne:=False;
Goto Finis;
End
else
C^[Lig].CR:=Tab128[U+3];
Tab128[U+3]:='';
End
else C^[Lig].CR:=' ';
end;
if Tab128[U]='G51' Then {Miroir}
begin
C^[Lig].CG:=Tab128[U];
C^[Lig].CX:=Tab128[U+1];
C^[Lig].CY:=Tab128[U+2];
end;
(***==========================================================
*if Tab128[U]='G54' Then {Validation des decalges}
* begin
* C^[Lig].CG:=Tab128[U];
* if Tab128[u+1][1]='X' Then C^[Lig].CX:=Tab128[U+1];
* if Tab128[u+2][1]='Y' Then C^[Lig].CY:=Tab128[U+2];
*
* if Tab128[u+1][1]='Y' Then C^[Lig].CY:=Tab128[U+1];
* if Tab128[u+2][1]='X' Then C^[Lig].CX:=Tab128[U+2];
*
* end;
***=======================================================***)
if (POS('ED',Tab128[U])=1) Then {**Rotation ED**}
begin
C^[Lig].CED:='ED';
if (POS('L',Tab128[U])>0) Then
begin
if Length(Tab128[u])<=Long_Formule Then
begin
i:=Pos('L',Tab128[U]);
if (i>1) And
(Controle_Formule(Copy(Tab128[u],3,Length(Tab128[U])),i)) Then
begin
New(C^[Lig].LED);
C^[Lig].LED^:=Copy(Tab128[u],3,Length(Tab128[U]));
DElete(Tab128[U],3,Length(Tab128[U]));
Insert('400',Tab128[U],3);
StrVar:=Copy(Tab128[u],3,Length(Tab128[u]));
End
else
begin
Erreur_Formule(1,Formule_Erreur,Tab128[1]);
Decode_Ligne:=False;
Goto Finis;
end;
End
else
begin
Erreur_Formule(6,0,Tab128[1]);
Decode_Ligne:=False;
Goto Finis;
end;
end;
end;
if POS('L',Tab128[U])>0 Then {**Variables**}
begin
if Length(Tab128[u])<=Long_Formule Then
begin
i:=Pos('L',Tab128[U]);
if i>1 Then
begin
if (Tab128[U][1] In['X','Y','R','I','J']) And
(Controle_Formule(Tab128[U],i)) Then
begin
Case Tab128[U][1] Of
'X': begin
New(C^[Lig].LX);
C^[Lig].LX^:=Copy(Tab128[u],2,Length(Tab128[U]));
end;
'Y': begin
New(C^[Lig].LY);
C^[Lig].LY^:=Copy(Tab128[u],2,Length(Tab128[U]));
end;
'R': begin
New(C^[Lig].LR);
C^[Lig].LR^:=Copy(Tab128[u],2,Length(Tab128[U]));
end;
'I': begin
New(C^[Lig].LI);
C^[Lig].LI^:=Copy(Tab128[u],2,Length(Tab128[U]));
end;
'J': begin
New(C^[Lig].LJ);
C^[Lig].LJ^:=Copy(Tab128[u],2,Length(Tab128[U]));
end;
end;
DElete(Tab128[U],2,Length(Tab128[U]));
Insert('-30000',Tab128[U],2);
End
else
begin
Erreur_Formule(2,Formule_Erreur,Tab128[1]);
Decode_Ligne:=False;
Goto Finis;
end;
End
else
if (i=1) And (Tab128[U][1]='L') Then
begin
if (Controle_Formule(Tab128[U],i)) Then
begin
New(C^[Lig].LA);
C^[Lig].LA^:=Tab128[u]; {**L=formule**}
Tab128[u]:='$-40000';
End
else
begin
Erreur_Formule(1,Formule_Erreur,Tab128[1]);
Decode_Ligne:=False;
Goto Finis;
end;
end;
End
else
begin
Erreur_Formule(6,0,Tab128[1]);
Decode_Ligne:=False;
Goto Finis;
end;
end;
if (Tab128[U]='G80') Then {**Stop Circle Percage**}
begin
Circle_Percage:=False;
C^[Lig].CG:=Tab128[U];
if Tab128[U+1]<>'' Then C^[Lig].CX:=Tab128[U+1];
if Tab128[U+2]<>'' Then C^[Lig].CY:=Tab128[U+2];
if Tab128[U+3]<>'' Then C^[Lig].CR:=Tab128[U+3];
ModeG81:='';
Z_G81:='';
ERG81:='';
F_G81:='';
End
else
if (Circle_Percage) OR (Tab128[U]='G81') OR (Tab128[U]='G82') OR
(Tab128[U]='G83') OR (Tab128[U]='G84') OR (Tab128[U]='G85') OR
(Tab128[U]='G86') OR (Tab128[U]='G87') OR (Tab128[U]='G88') OR
(Tab128[U]='G89') Then {Circle Percage}
begin
if (Circle_Percage) AND (Tab128[u]<>'G81') And (Tab128[U]<>'G81') And
(Tab128[U]<>'G82') And (Tab128[U]<>'G83') And (Tab128[U]<>'G84') And
(Tab128[U]<>'G85') And (Tab128[U]<>'G86') And (Tab128[U]<>'G87') And
(Tab128[U]<>'G88') And (Tab128[U]<>'G89') Then
begin
if ModeG81<>'' Then C^[lig].CG:=ModeG81;
if F_G81<>'' Then C^[lig].CF:=F_G81;
i:=2;
While Tab128[i]<>'' DO Inc(i);
if Tab128[i]='' Then Tab128[i]:=Z_G81;
if Tab128[i+1]='' Then Tab128[i+1]:=ERG81;
End
else
begin
Circle_Percage:=True;
i:=2;
While Tab128[i]<>'' DO
begin
if POS('G8',Tab128[i])>0 Then
begin
C^[Lig].CG:=Tab128[i];
ModeG81:=Tab128[i];
End
else
if POS('ER',Tab128[i])>0 Then
begin
ERG81:=Tab128[i];
End
else
if POS('Z',Tab128[i])>0 Then
begin
Z_G81:=Tab128[i];
End
else
if POS('F',Tab128[i])>0 Then
begin
C^[Lig].CF:=Tab128[i];
F_G81:=Tab128[i];
end;
Inc(i);
end; {while}
end; {end bloc}
End
else
if Tab128[U]='G45' Then {**controle La commande G45**}
begin
cc:=U+1;_Z:=0.0;_ER:=0.0;_P:=0.0;Err:=0;Vii:=0.0;
While (cc<20) And (Err=0) And (Tab128[cc]<>'') DO
begin
if (Pos('Z',Tab128[cc])>0) Then
begin
StrVar1:=Tab128[cc];
StrVar1:=Copy(StrVar1,2,Length(StrVar1));
{$R-}
Val(StrVar1,_z,Err); {**valeur de Z**}
{$R+}
End
else
if (Pos('ER',Tab128[cc])>0) Then
begin
StrVar1:=Tab128[cc];
StrVar1:=Copy(StrVar1,3,Length(StrVar1));
{$R-}
Val(StrVar1,_ER,Err); {**valeur de ER**}
{$R+}
End
else
if (Pos('EP',Tab128[cc])=0) And (Pos('P',Tab128[cc])>0) then
begin
StrVar1:=Tab128[cc];
StrVar1:=Copy(StrVar1,2,Length(StrVar1));
{$R-}
Val(StrVar1,_P,Err); {**valeur de P**}
{$R+}
if (Err=0) And (_P<=0.0) then Err:=-1;
End
else
if (Pos('EP',Tab128[cc])>0) then
begin
Vii:=0.0;
StrVar1:=Tab128[cc];
StrVar1:=Copy(StrVar1,3,Length(StrVar1));
{$R-}
Val(StrVar1,Vii,Err); {**valeur de EP**}
{$R+}
if (Err=0) And (Vii<=0.0) then Err:=-1;
End
else
if (Pos('EQ',Tab128[cc])=0) And (Pos('Q',Tab128[cc])>0) then
begin
Vii:=0.0;
StrVar1:=Tab128[cc];
StrVar1:=Copy(StrVar1,2,Length(StrVar1));
{$R-}
Val(StrVar1,Vii,Err); {**valeur de Q**}
{$R+}
if (Err=0) And (Vii<=0.0) then Err:=-1;
End
else
if (Pos('EQ',Tab128[cc])>0) then
begin
Vii:=0.0;
StrVar1:=Tab128[cc];
StrVar1:=Copy(StrVar1,3,Length(StrVar1));
{$R-}
Val(StrVar1,Vii,Err); {**valeur de EQ**}
{$R+}
if (Err=0) And (Vii<=0.0) then Err:=-1;
End
else
if (Pos('EB',Tab128[cc])>0) then
begin
Vii:=0.0;
StrVar1:=Tab128[cc];
StrVar1:=Copy(StrVar1,3,Length(StrVar1));
{$R-}
Val(StrVar1,Vii,Err); {**valeur de EB**}
{$R+}
if (Err=0) And (Vii<=0.0) then Err:=-1;
End
else
if (Pos('EX',Tab128[cc])>0) then
begin
Vii:=0.0;
StrVar1:=Tab128[cc];
StrVar1:=Copy(StrVar1,3,Length(StrVar1));
{$R-}
Val(StrVar1,Vii,Err); {**valeur de EX**}
{$R+}
if (Err=0) And (Vii<=0.0) then Err:=-1;
End
else
if (Pos('EY',Tab128[cc])>0) then
begin
Vii:=0.0;
StrVar1:=Tab128[cc];
StrVar1:=Copy(StrVar1,3,Length(StrVar1));
{$R-}
Val(StrVar1,Vii,Err); {**valeur de EY**}
{$R+}
if (Err=0) And (Vii<=0.0) then Err:=-1;
end;
Inc(cc);
end; {**fin de while**}
if (Err=0) Then
begin
{**Erreur si P plus Grand que (Z*-1)+R**}
if ( _P > ((_z * -1)+_ER) ) Then
begin
Erreur_Formule(66,0,Tab128[1]);
Decode_Ligne:=False;
Exit;
Goto Finis;
end;
End
else
begin
Erreur_Formule(3,0,Tab128[1]);
Decode_Ligne:=False;
Exit;
Goto Finis;
end;
end; {**fin de controle du commande G45**}
{$IFDEF __Type_M100__}
if (Tab128[U]='M100') OR (Tab128[U]='M101') Then {**Serrage Piece**}
begin
C^[Lig].CG:=Tab128[U];
end;
{$ENDIF}
if (Tab128[U]<>'G77') And (Tab128[u]<>'' ) And
(Tab128[u]<>'M3' ) And (Tab128[u]<>'M03' ) And (Tab128[u]<>'M04' ) And
(Tab128[u]<>'M4' ) And (Tab128[u]<>'M5' ) And (Tab128[u]<>'M05') And
(Tab128[U]<>'G79') And (Tab128[U]<>'G51') And (Tab128[U]<>'M100') And
(Tab128[U]<>'M101') Then
While (U<20) And (Tab128[u]<>'') And (ErreurFile=0) DO
begin
if (Tab128[u]='G1') OR (Tab128[u]='G01') OR (Tab128[u]='G2') OR
(Tab128[u]='G02') OR (Tab128[u]='G3') OR (Tab128[u]='G03') OR
(Tab128[u]='G0') OR (Tab128[u]='G00') OR (Tab128[u]='M6') OR
(Tab128[u]='M06') OR (Tab128[u]='G45') OR (Tab128[u]='G59') OR
(Tab128[u]='G81') OR (Tab128[u]='G') OR (Tab128[u]='G54')
Then
begin
if (Tab128[u]='G00') OR (Tab128[u]='G') Then Tab128[u]:='G0'
else
if Tab128[u]='G01' Then Tab128[u]:='G1'
else
if Tab128[u]='G02' Then Tab128[u]:='G2'
else
if Tab128[u]='G03' Then Tab128[u]:='G3'
else
if Tab128[u]='M06' Then Tab128[u]:='M6';
if (Tab128[U]='G0') OR (Tab128[u]='G1') OR (Tab128[u]='G59') OR
(Tab128[U]='G54') Then
begin
cc:=2;A:=0;
While (cc<20) And (A<1) And (Tab128[cc]<>'') DO
begin
if (Pos('X',Tab128[cc])>0) OR (Pos('Y',Tab128[cc])>0) Then
Inc(A);
Inc(cc);
end;
if A>0 Then C^[lig].CG:=Tab128[u];
End
else
C^[lig].CG:=Tab128[u];
End
else
if Tab128[u][1]='M' Then C^[Lig].CR:=Tab128[u]
else
if (Tab128[u]='G40') OR (Tab128[u]='G41') OR (Tab128[u]='G42') Then
C^[lig].CX:=Tab128[u]
else
if (Tab128[u]='G90') OR (Tab128[u]='G91') OR (Tab128[u][1]='S') Then
C^[lig].CS:=Tab128[u]
else
if (Tab128[u][1]='F') Then
C^[lig].CF:=Tab128[u]
{*a1*} else
begin
if (Pos('EB',Tab128[u])>0) OR (Pos('EX',Tab128[u])>0) OR
(Pos('EY',Tab128[u])>0) OR (Pos('ER',Tab128[u])>0) OR
(Pos('EP',Tab128[u])>0) OR (Pos('EQ',Tab128[u])>0) OR
(Pos('ED',Tab128[u])>0)
Then
StrVar:=Copy(Tab128[u],3,Length(Tab128[u]))
else
StrVar:=Copy(Tab128[u],2,Length(Tab128[u]));
if POS('L',Tab128[U])>0 Then {Variables}
begin
if Length(Tab128[u])<=Long_Formule Then
begin
i:=Pos('L',Tab128[U]);
if (i>1) And (Tab128[U][1] In['X','Y','R','I','J']) And
(Controle_Formule(Copy(Tab128[u],2,Length(Tab128[U])),i)) Then
begin
Case Tab128[U][1] Of
'X': begin
New(C^[Lig].LX);
C^[Lig].LX^:=Copy(Tab128[u],2,Length(Tab128[U]));
end;
'Y': begin
New(C^[Lig].LY);
C^[Lig].LY^:=Copy(Tab128[u],2,Length(Tab128[U]));
end;
'R': begin
New(C^[Lig].LR);
C^[Lig].LR^:=Copy(Tab128[u],2,Length(Tab128[U]));
end;
'I': begin
New(C^[Lig].LI);
C^[Lig].LI^:=Copy(Tab128[u],2,Length(Tab128[U]));
end;
'J': begin
New(C^[Lig].LJ);
C^[Lig].LJ^:=Copy(Tab128[u],2,Length(Tab128[U]));
end;
end;
DElete(Tab128[U],2,Length(Tab128[U]));
Insert('-30000',Tab128[U],2);
StrVar:=Copy(Tab128[u],2,Length(Tab128[u]));
End
else
if (i=1) And (Tab128[U][1]='L') And
(Controle_Formule(Copy(Tab128[u],2,Length(Tab128[U])),i)) Then
begin
New(C^[Lig].LA);
C^[Lig].LA^:=Tab128[u];
Tab128[u]:='$-40000';
StrVar:=Copy(Tab128[u],2,Length(Tab128[u]));
End
else
begin
Erreur_Formule(1,Formule_Erreur,Tab128[1]);
Decode_Ligne:=False;
Goto Finis;
end;
End
else
begin
Erreur_Formule(6,0,Tab128[1]);
Decode_Ligne:=False;
Goto Finis;
end;
end; {formule}
{$R-}
Val(StrVar,Valeur,Err);
{$R+}
if (Err<>0) OR (Valeur>99999.999) Then
begin
{Efface_Mesaje;}
Erreur_Formule(3,0,Tab128[1]);
Decode_Ligne:=False;
Exit;
End
else
{*a2*} begin
Case Tab128[u][1] Of
'X': W^[lig].X:=Valeur;
'Y': W^[lig].Y:=Valeur;
'Z': W^[lig].Z:=Valeur;
'R': W^[lig].R:=Valeur;
'I': W^[lig].I:=Valeur;
'J': W^[lig].J:=Valeur;
'D': if Round(Valeur) In[1..Max_Outils] Then W^[lig].D:=Round(Valeur);
'T': if Round(Valeur) In[0..32] Then W^[lig].T:=Round(Valeur);
'E': begin
if Pos('EB',Tab128[u])>0 Then W^[lig].R:=Valeur
else
if Pos('EX',Tab128[u])>0 Then W^[lig].I:=Valeur
else
if Pos('EY',Tab128[u])>0 Then W^[lig].J:=Valeur
else
if Pos('ER',Tab128[u])>0 Then W^[lig].K:=Valeur
else
if Pos('ED',Tab128[u])>0 Then
begin
if (Valeur>=0) And (Valeur<=360) Then
W^[lig].ED:=Round(Valeur);
if C^[Lig].CED<>'ED' Then C^[Lig].CED:='ED';
end;
end;
end; { ** case **}
{*a2*} end;
Valeur:=0;
{*a1*} end;
Inc(u);
end; {**While**}
if Tab128[1]<>'' Then Inc(Lig);
Decode_Ligne:=True;
Finis:
end;
Function SuprimeCommentaires(S:String):String;
var ch:Char;
i,nc1,Nc2:Integer;
begin
nc1:=0;nc2:=0;
For I:=1 To Length(S) Do
begin
if S[i]='(' Then Inc(nc1);
if S[i]=')' Then Inc(nc2);
end;
if nc1<>nc2 Then
begin
if nc1>nc2 Then ch:=')'
else ch:='(';
SuprimeCommentaires:=Ch;
End
else
begin
Repeat
nc1:=Pos('(',S);
nc2:=Pos(')',S);
if nc2-nc1>39 Then
begin
SuprimeCommentaires:='>40';
ch:='#';
nc1:=0;
End
else
if nc1>0 Then Delete(S,nc1,(nc2-nc1)+1);
Until (nc1=0);
if ch<>'#' Then
begin
I:=Length(S);
While (S[i]=#32) And (i>0) DO Dec(i);
if i>0 Then S:=Copy(S,1,i)
else S:='';
SuprimeCommentaires:=S;
end;
end;
end;
Function VerifyLetreIso(SSS:String):Boolean;
Var i,LongSSS:Integer;
Trouve:Boolean;
begin
LongSSS:=Length(SSS);i:=1;Trouve:=False;
While (i<=LongSSS) And (Not Trouve) DO
begin
if SSS[i] In LetreNotISO Then Trouve:=True
else
Inc(i);
end;
VerifyLetreISO:=Trouve;
end;
Procedure Lire_Index;
Var SC,ST : String;
Lire : Boolean;
S : String;
kk : Byte;
Err,NNN: Integer;
SN : String[6];
Compare, Block:Boolean;
begin
Scommand:='G1';
Modale:=TRUE;
ErreurFile:=0;
S:='';Err:=1;
Block:=False;
N_Number:=0; {**control denumeration de lignes**}
TextRec(Fictex).BufPos:=0;
While (Not Eof(FicTex)) And (Not Block ) Do
begin
{$i-}
Read(Fictex,S);
{$I+}
if (S[1]='%') Then
begin
S:=Copy(S,2,Length(S));
if (Pos('(',S)>0) OR (Pos(')',S)>0) Then
begin
S:=SuprimeCommentaires(S+' ');
if (S='(') OR (S=')') OR (S='>40') then
begin
Efface_Mesaje;
if S='>40' Then
Mesaje('Error - the commentaire max 40 carct. Stop line: '+
'% prog')
else
Mesaje('Error not "'+S+'" the commentaire. Line: % prog');
KK:=keyBoard;
Efface_Mesaje;
ErreurFile:=2;
Exit;
end;
end;
if S<>'' Then
begin
if VerifyLetreISO(S) Then
begin
Efface_Mesaje;
Mesaje('Error - not ISO character. Stop line: % prog');
KK:=keyBoard;
Efface_Mesaje;
ErreurFile:=2;
Exit;
End
end;
{$R-}
Val(S,nnn,Err);
{$R+}
if (Err=0) Then
begin
if (nnn>0) And (nnn<=9999) Then Block:=True
else Err:=2;
{$I-}
ReadLN(FicTex);
{$I+}
end;
end
else
begin
{$I-}
Readln(FicTex);
{$I+}
end;
end;
if Err<>0 Then
begin
ErreurFile:=12;
Efface_Mesaje;
Str(ErreurFile,S);
Mesaje('ERRR -- Number programm not correct: '+S);
KK:=KeyBoard;
Efface_Mesaje;
Exit;
end;
if Block Then
begin
Lire:=True;
Nbr:=1;
While (Not Eof(FicTex)) And (Lire) And (ErreurFile=0) Do
begin
{$I-}
Readln(Fictex,St);
{$I+}
if (Pos('(',ST)>0) OR (Pos(')',ST)>0) Then
begin
St:=SuprimeCommentaires(ST+' ');
if (ST='(') OR (ST=')') OR (ST='>40') then
begin
if (Nbr>1) And (C^[Nbr-1].CN<>'') Then
Sn:=C^[Nbr-1].CN
else Str(Nbr,Sn);
Efface_Mesaje;
if ST='>40' Then
Mesaje('Error - the commentaire max 40 carct. Stop line: '+Sn)
else
Mesaje('Error not "'+ST+'" the commentaire. Stop line: '+Sn);
KK:=keyBoard;
Efface_Mesaje;
ErreurFile:=2;
Exit;
end;
end;
if St<>'' Then
begin
if VerifyLetreISO(St) Then
begin
if (Nbr>1) And (C^[Nbr-1].CN<>'') Then
Sn:=C^[Nbr-1].CN
else Str(Nbr,Sn);
Efface_Mesaje;
Mesaje('Error - not ISO character. Stop line: '+Sn);
KK:=keyBoard;
Efface_Mesaje;
ErreurFile:=2;
Exit;
End
end;
if St<>'' Then
begin
if (Nbr<MaxLig) Then
begin
{*Modale:=TRUE;}
St:=St+' ';
if Not Decode_Ligne(Nbr,ST) Then Exit;
{*Modale:=FALSE;}
End
else
begin
ErreurFile:=7;
Str(MaxLig,SC);
Mesaje('Error: Too much lines [maximum:'+Sc+']');
ChKey:=keyBoard;
Chkey:=27;
Efface_Mesaje;
end;
end;
end; { while }
End
else ErreurFile:=1;
Circle_Percage:=False;
Modale:=FALSE;
end;
Procedure Control(Max:integer);
var i : Integer;
X_Max,X_Min : Real;
Y_Max,Y_Min : Real;
begin
X_Max:=0;
X_Min:=0;
Y_Max:=0;
Y_Min:=0;
ECHELLE:=1;
Echelle2:=False;
MaxiX:=0;
MaxiY:=0;
MiniX:=0;
MiniY:=0;
for i:=1 To max Do
begin
if W^[i].X>X_Max Then X_Max:=W^[i].X;
if W^[i].Y>Y_Max Then Y_Max:=W^[i].Y;
if (W^[i].X>-30000) And (W^[i].X<X_Min) Then
begin
if (C^[i].CG<>'G59') And (C^[i].CG<>'G54') Then X_Min:=W^[i].X;
end;
if (W^[i].Y>-30000) And (W^[i].Y<Y_Min) Then
begin
if (C^[i].CG<>'G59') And (C^[i].CG<>'G54') Then Y_Min:=W^[i].Y;
end;
end;
MaxiX:=X_Max;MaxiY:=Y_Max;
MiniX:=X_Min;MiniY:=Y_Min;
if (ABS(X_Min)+X_Max)>MAX_X-60 Then Echelle2:=True;
if (ABS(Y_Min)+Y_Max)>MAX_Y-60 Then Echelle2:=True;
if Echelle2 Then
begin
ECHELLE:=(ABS(Y_Min)+Y_Max)/(MAX_Y-60);
if (ABS(X_Min)+X_Max)/(MAX_X-40)>ECHELLE Then
ECHELLE:=(ABS(X_Min)+X_Max)/(MAX_X-60);
For i:=1 To max Do
begin
if W^[i].X>-30000 Then W^[i].X:=W^[i].X / ECHELLE;
if W^[i].Y>-30000 Then W^[i].Y:=W^[i].Y / ECHELLE;
if W^[i].R>-30000 Then W^[i].R:=W^[i].R / ECHELLE;
if W^[i].I>-30000 Then W^[i].I:=W^[i].I / ECHELLE;
if W^[i].J>-30000 Then W^[i].J:=W^[i].J / ECHELLE;
{ if W^[i].K>-30000 Then W^[i].K:=W^[i].K / ECHELLE;}
(***=== anule ==============================================
* if C^[i].CG='G45' Then
* begin
* i:=i;
* if W^[i].I>-30000 Then W^[i].I:=W^[i].I / ECHELLE;
* if W^[i].J>-30000 Then W^[i].J:=W^[i].J / ECHELLE;
* if W^[i].K>-30000 Then W^[i].K:=W^[i].K / ECHELLE;
* end;
****====================================================***)
end;
end;
end;
Procedure Open_Fic(Reperto,Neime:String);
begin
if FileOpen Then
begin
{$i-}
Close(FicTex);
{$i+}
end;
FileOpen:=False;
FillChar(BufTexte^,SizeOf(Buf___Ptr),#32);
Assign(FicTex,Reperto+Neime);
SetTextBuf(FicTex,BufTexte^);
{$I-}
Reset(FicTex);
{$I+}
if Ioresult= 0 Then
begin
Read(Fictex,BufTexte^[1]);
FileOpen:=TRUE;
End
else FileOpen:=False;
end;
Procedure GO_Programme;
Label Pase,Fin_Error;
Var WW,G77_Nbr1,JJ : integer;
TXX,TYY,TRR : Real;
N1,N2,S,S2 : String;
begin
if FileOpen Then
begin
Graph.SetColor(14);
Circle(PmX,PmY,4);
line(PmX+2,PmY,Pmx+2,Pmy+2);
line(PmX-2,PmY,Pmx+2,Pmy);
PosX:=0;PosY:=0;
Graph.SetColor(15);
MiroirX:=1;
MiroirY:=1;
ED_Rotation:=False;
Angle_ED:=0;
Reyon_Util:=4;
Init_Variables;
Mode:=True; {* Par defut Mode est G90 *}
Valeur_de_Z(Haut_Z);
Fin_M2:=False;
JJ:=1;
PosX:=0;PosY:=0;
Chkey:=0;
{$IFDEF __Type_M100__}
Serrage_Piece:=False;
{$ENDIF}
While (jj<=Nbr) And (Not Fin_M2) DO
begin
Affiche_Line(C^[jj].CN,W^[jj].X,W^[jj].Y);
Delay(TempoOK);
{Inc(DeplacementBlocs);}
if C^[jj].CS<>'' Then
begin
if (C^[jj].CS='G90') Then
begin
Mode:=True;
Affiche_Mode;
End
else
if C^[jj].CS='G91' Then
begin
Mode:=False;
Affiche_Mode;
end;
end;
{$IFDEF __Type_M100__}
if C^[jj].CG='M100' Then Serrage_Piece:=True;
if C^[jj].CG='M101' Then Serrage_Piece:=False;
{$ENDIF}
if C^[jj].CG='M6' Then
begin
{$IFDEF __Type_M100__}
if (Not Serrage_Piece) Then
begin
ERREUR_Execution(COTEZ,15,Pos_line,0,0);
Goto Fin_Error;
end;
{$ENDIF}
CoteZ:=Haut_Z;
M6(C^[jj].CN,W^[jj].T,W^[jj].D);
Valeur_de_Z(Haut_Z);
End
else
if (W^[jj].Z>-30000) And (W^[jj].Z<>CoteZ) Then
Valeur_de_Z(Round(W^[jj].Z));
if ((C^[jj].Cx='G41') OR
(C^[jj].Cx='G42') OR
(C^[jj].Cx='G40')) Then Decale(C^[jj].Cx);
if C^[jj].LA <>NIL Then
begin
if Controle_Formule(C^[jj].LA^,1) Then
else ERREUR_Execution(COTEZ,5,Pos_line,Formule_Erreur,0);
if Calcule_Formule(C^[jj].LA^,1) Then
else ERREUR_Execution(COTEZ,6,Pos_line,Formule_Erreur,0);
if (Debugger) And (DebugCode='V') Then
Debuger_Valeur(Debug_Var,C^[JJ].CN);
end;
if C^[jj].LX <>NIL Then
begin
if Controle_Formule(C^[jj].LX^,2) Then
else ERREUR_Execution(COTEZ,5,Pos_line,Formule_Erreur,0);
if Calcule_Formule(C^[jj].LX^,2) Then
else ERREUR_Execution(COTEZ,6,Pos_line,Formule_Erreur,0);
TXX:=Valeur_Variable / ECHELLE;
if (Debugger) And (DebugCode='V') Then
Debuger_Valeur(Debug_Var,C^[JJ].CN);
End
else
TXX:=W^[jj].X;
if C^[jj].LY<>NIL Then
begin
if Controle_Formule(C^[jj].LY^,2) Then
else ERREUR_Execution(COTEZ,5,Pos_line,Formule_Erreur,0);
if Calcule_Formule(C^[jj].LY^,2) Then
else ERREUR_Execution(COTEZ,6,Pos_line,Formule_Erreur,0);
TYY:=Valeur_Variable / ECHELLE;
if (Debugger) And (DebugCode='V') Then
Debuger_Valeur(Debug_Var,C^[JJ].CN);
End
else
TYY:=W^[jj].Y;
TRR:=-30000;
if (C^[jj].LR<>NIL) And ((C^[jj].CG='G2') OR (C^[jj].CG='G3')) Then
begin
if Controle_Formule(C^[jj].LR^,2) Then
else ERREUR_Execution(COTEZ,5,Pos_line,Formule_Erreur,0);
if Calcule_Formule(C^[jj].LR^,2) Then
else ERREUR_Execution(COTEZ,6,Pos_line,Formule_Erreur,0);
TRR:=Valeur_Variable / ECHELLE;
if (Debugger) And (DebugCode='V') Then
Debuger_Valeur(Debug_Var,C^[JJ].CN);
end
else
TRR:=W^[jj].R;
if (TXX<=-30000) Then TXX:=PosX;
if (TYY<=-30000) Then TYY:=PosY;
if (C^[jj].CG<>'G59') And (C^[jj].CG<>'G54') Then
begin
if (Not Mode) And (W^[jj].X>-30000) Then TXX:=PosX+TXX;
if (Not Mode) And (W^[jj].Y>-30000) Then TYY:=PosY+TYY;
end;
if (C^[jj].CED='ED') Then
begin
if C^[jj].LED<>NIL Then
begin
if Controle_Formule(C^[jj].LED^,2) Then
else ERREUR_Execution(COTEZ,5,Pos_line,Formule_Erreur,0);
if Calcule_Formule(C^[jj].LED^,2) Then
else ERREUR_Execution(COTEZ,6,Pos_line,Formule_Erreur,0);
if (Valeur_Variable>=0) And (Valeur_Variable<=360) Then
begin
if mode Then Angle_ED:=Valeur_Variable
else
Angle_ED:=Angle_ED+Valeur_Variable;
if (Angle_ED>=0) And (Angle_ED<=360) Then
ED_Rotation:=TRUE
else
begin
if (W^[jj].ED<>0) Then ERREUR_Execution(COTEZ,4,Pos_line,0,0);
ED_Rotation:=False;
ED_Rotation:=False;
Angle_ED:=0;
end;
End
else
ERREUR_Execution(COTEZ,4,Pos_line,0,0);
if (Debugger) And (DebugCode='V') Then
Debuger_Valeur(Debug_Var,C^[JJ].CN);
End {end -50000}
else
if (W^[jj].ED>=0) And (W^[jj].ED<=360) Then
begin
ED_Rotation:=TRUE;
if mode Then Angle_ED:=W^[jj].ED
else
Angle_ED:=Angle_ED+W^[jj].ED;
End
else
begin
if (W^[jj].ED<>0) Then ERREUR_Execution(COTEZ,4,Pos_line,0,0);
ED_Rotation:=False;
ED_Rotation:=False;
Angle_ED:=0;
end;
end;
if (Angle_ED>0) And (Angle_ED<=360) Then
begin
if (C^[jj].CG<>'G59') And (C^[jj].CG<>'G54') Then
Rotation_SUR_G3(TXX,TYY,Angle_ED)
else
begin
Angle_ED:=0;
ED_Rotation:=False;
end;
end;
(*******************************************************************
* if C^[jj].CG='G59' Then
* Voir(TXX,TYY,' '+C^[jj].CN+' '+C^[jj].CG+' --> Fin Angle');
*******************************************************************)
if ((MiroirX=-1) And (W^[jj].X>-30000)) Then TXX:=(TXX * -1);
if ((MiroirY=-1) And (W^[jj].Y>-30000)) Then TYY:=(TYY * -1);
if C^[jj].CG='G59' Then
begin
PosX:=0;
PosY:=0;
G59(TXX,TYY);
Goto Pase;
End
else
if C^[jj].CG='G0' Then G0(PosX,PosY,TXX,TYY,C^[jj].CX)
else
if C^[jj].CG='G1' Then G1(PosX,PosY,TXX,TYY,C^[jj].CX)
else
if (C^[jj].CG='G2') And (MiroirX=1) And (MiroirY=1) Then
G2(PosX,PosY,TXX,TYY,TRR,W^[jj].I,W^[jj].J)
else
if (C^[jj].CG='G3') And (MiroirX=1) And (MiroirY=1) Then
begin
G3(PosX,PosY,TXX,TYY,TRR,W^[jj].I,W^[jj].J)
End
else
if (C^[jj].CG='G2') And ((MiroirX=-1) OR (MiroirY=-1)) Then
begin
if (MiroirX=-1) And (MiroirY=-1) Then
G2(PosX,PosY,TXX,TYY,TRR,W^[jj].I,W^[jj].J)
else
G3(PosX,PosY,TXX,TYY,TRR,W^[jj].I,W^[jj].J);
End
else
if (C^[jj].CG='G3') And ((MiroirX=-1) OR (MiroirY=-1)) Then
begin
if (MiroirX=-1) And (MiroirY=-1) Then
G3(PosX,PosY,TXX,TYY,TRR,W^[jj].I,W^[jj].J)
else
G2(PosX,PosY,TXX,TYY,TRR,W^[jj].I,W^[jj].J);
End
else
if C^[jj].CG='M3' Then
begin
{$IFDEF __Type_M100__}
if (Not Serrage_Piece) Then
begin
ERREUR_Execution(COTEZ,15,Pos_line,0,0);
Goto Fin_Error;
end;
{$ENDIF}
M3(C^[jj].CN,C^[jj].CX,C^[jj].CY)
End
else
if C^[jj].CG='M4' Then
begin
{$IFDEF __Type_M100__}
if (Not Serrage_Piece) Then
ERREUR_Execution(COTEZ,15,Pos_line,0,0);
Goto Fin_Error;
{$ENDIF}
M4(C^[jj].CN,C^[jj].CX,C^[jj].CY);
End
else
if C^[jj].CG='M5' Then M5(C^[jj].CN,C^[jj].CX,C^[jj].CY)
else
if C^[jj].CG='G45' Then
begin
ReserveZ:=CoteZ;
Valeur_de_Z(0);
G0(PosX,PosY,TXX,TYY,'');
Valeur_de_Z(ReserveZ);
G45(Round(TXX),Round(TYY),Round(W^[jj].I),Round(W^[jj].J),Round(W^[jj].R));
Valeur_de_Z(Round(W^[jj].K*ECHELLE));
End
else
if C^[jj].CG='G77' Then
begin
G77_Nbr1:=0;
if Affiche_G77(C^[jj].CN,C^[jj].CX,C^[jj].CY,C^[jj].CR,G77_Nbr1) Then
begin
N1:=C^[jj].CX;
N2:=C^[jj].CY;
if G77_Nbr1>0 Then
begin
if Formule_Erreur=0 Then
begin
ww:=1;
While (ww<=G77_Nbr1) And (ChKey<>27) DO
begin
Repeter_Bloc(N1,N2);
inc(ww);
end;
end;
End
else
Repeter_Bloc(N1,N2);
end;
End
else
if C^[jj].CG='G54' Then G54(TXX,TYY)
else
if ((C^[jj].CG='G81') OR (C^[jj].CG='G82') OR (C^[jj].CG='G83') OR
(C^[jj].CG='G84') OR (C^[jj].CG='G85') OR (C^[jj].CG='G86') OR
(C^[jj].CG='G87') OR (C^[jj].CG='G88') OR (C^[jj].CG='G89'))
Then
begin
ReserveZ:=CoteZ;
Valeur_de_Z(0);
Valeur_de_Z(ReserveZ);
G81(TXX,TYY, W^[jj].K, C^[jj].CG, C^[jj].CF);
End
else
if C^[jj].CG='G80' Then G80
else
if (C^[jj].CN='M2') OR (C^[jj].CG='M2') Then
begin
{$IFDEF __Type_M100__}
if (Serrage_Piece) Then
begin
ERREUR_Execution(COTEZ,16,Pos_line,0,0);
Goto Fin_Error;
end;
{$ENDIF}
Fin_M2:=True;
End
else
if C^[jj].CR[1]='M' Then
begin
if C^[jj].CR='M2' Then
begin
{$IFDEF __Type_M100__}
if (Serrage_Piece) Then
begin
ERREUR_Execution(COTEZ,16,Pos_line,0,0);
Goto Fin_Error;
end;
{$ENDIF}
Fin_M2:=True;
End
else MMM(C^[jj].CN,C^[jj].CR);
End
else
{Miroir} if C^[jj].CG='G51' Then G51(C^[jj].CN,C^[jj].CX,C^[jj].CY)
else
if C^[jj].CG='G79' Then
begin
G79(jj,C^[jj].CN,C^[jj].CX,C^[jj].CY);
end;
{$IFDEF __Type_M100__}
if (C^[jj].CG='M101') And (Serrage_Piece) Then
begin
Serrage_Piece:=False;
end;
{$ENDIF}
pase:
ChKey:=GetKeyDelay(Opertion_Tempo);
if ChKey in [27,62,68] Then
begin
case ChKey of
27: begin
ChKey:=27;
Fin_M2:=True;
end;
62: if Key_Code Then
begin
Cadriage;
ChKey:=0;
Inc(jj);
end;
68: if Key_Code Then
begin
ERREUR_Execution(CoteZ,14,Pos_Line,0,0);
if ChKey = 27 Then
begin
ChKey:=27;
Fin_M2:=True;
End
else
begin
Chkey:=0;
Inc(jj);
end;
end;
end;
End {****if Type_Key <> 0****}
else Inc(jj);
if Not ChKey in [27,62,68] Then chKey:=0;
end; {** while - for **}
Fin_Error:
if (ChKey = 27) Then
begin
if jj>1 Then N1:=C^[jj].CN
else N1:='0';
ERREUR_Execution(COTEZ,13,N1,0,0);
End
else
if ((CoteZ<0) AND (CoteZ>-30000)) OR (BROCHE) Then
begin
if Nbr>1 Then N1:=C^[Nbr-1].CN
else N1:='0';
ERREUR_Execution(COTEZ,1,N1,0,0);
end;
Mode:=True;
SetTextJustify(CenterText, TopText);
SetTextStyle(0,0,1);
OutTextXY(MAX_X div 2, MAX_Y-15, 'End Programm');
Beep;
ChKey:=KeyBoard;
ChKey:=0;
SetTextJustify(0,0);
SetTextStyle(0, HorizDir, 0);
end;
end;
{$I NC_NUM3.PAS} (*** ficier a inclure***)
Function File_Premier(Rep,Nom:String):Boolean;
Var File_OK:Boolean;
begin
File_OK:=False;
Init_Table(1);
Neime:=Nom;
Init_Table(1);
if (Nom<>'') Then Open_Fic(Rep,Nom);
if FileOpen Then
begin
DG41:=False;
DG42:=False;
DG40:=False;
PosX:=0.0;
PosY:=0.0;
Choix:=6;
Nom:=Neime;
File_OK:=True;
End
else
begin
DG41:=False;
DG42:=False;
DG40:=False;
PosX:=0.0;
PosY:=0.0;
Choix:=1;
Nom:='';
Neime:='';
Nom:='';
File_OK:=False;
end;
File_Premier:=File_OK;
end;
Procedure GraPhique_Numeriqe(RepertoireFile1,NomFile1:String);
begin
BotonX:=1;
Choix:=1;
End_Programm_Num:=False;
ErreurFile:=0;
Nbr:=0;
MiroirX:=1;
MiroirY:=1;
Circle_Percage:=False;
Z_G81:='';
ERG81:='';
ECHELLE:=1;
BROCHE:=False;
Chkey:=0;
MiniX:=0;
MiniY:=0;
MaxiX:=0;
MaxiY:=0;
DG41:=False;
DG42:=False;
DG40:=True;
{** Opertion_Tempo et Tempo son initialises sur Ednum.pas **}
{** Tempo:=50; **}
{** Opertion_Tempo:=8000;**}
{**TempoOK:=10; **}
Marke_Outil:=False;
Mode:=True;
Neime:='';
Nom:='';
PosX:=0.0;
PosY:=0.0;
Outil_Courant:='T0 > D0';
FileOpen:=False;
ED_Rotation:=False;
Angle_ED:=0;
if NomFile1<>'' then
begin
if File_Premier(RepertoireFile1,NomFile1) Then MENUXX(True)
else
MENUXX(False);
End
else MENUXX(False);
end;
Procedure Init_Table_Ouverture;
Var i:Byte;
begin
For ix:=1 To MaxLig DO
begin
W^[ix].X:=-30000;
W^[ix].Y:=-30000;
W^[ix].Z:=-30000;
W^[ix].R:=-30000;
W^[ix].I:=-30000;;
W^[ix].J:=-30000;;
W^[ix].K:=-30000;;
W^[ix].D:=255;
W^[ix].ED:=400;
W^[ix].T:=255;
C^[ix].CN:='';
C^[ix].CG:='';
C^[ix].CX:='';
C^[ix].CY:='';
C^[ix].CR:='';
C^[ix].CED:='';
C^[ix].CF:='';
C^[ix].CS:='';
C^[ix].LA:=NIL;
C^[ix].LX:=NIL;
C^[ix].LY:=NIL;
C^[ix].LR:=NIL;
C^[ix].LI:=NIL;
C^[ix].LJ:=NIL;
C^[ix].LED:=NIL;
end;
Init_Variables;
CoteZ:=-30000;
For i:=1 To NumBars DO TabB[i]:=0;
end;
Procedure Numerical;
Var u,i,XX,YY,PPMY:integer;
PPMX:Integer;
ColorTT:Byte;
begin
PPMY:=GetMaxY+120;
PPMX:=50;
ColorTT:=15;
{SetBox(15,4,66,8,3,15,7);}
SetBox(10,4,71,9,3,15,7);
SetBox(4,12,79,27,8,15,7);
SetColor(12);
SetTextStyle(2,0,4);
Outtextxy(500,460,'programming: A.ARA');
SetTextStyle(1,0,1);
SetTextJustify(0, TopText);
SetColor(4);
SetTextStyle(0,0,3);
Outtextxy(120,68,'NUMERICAL CONTROL');
Outtextxy(130,105,' 2001');
SetTextStyle(0,0,0);
SetViewPort(0,0,GetMAXX,GetMAXy,clipON);
SetColor(Colortt);
SetFillStyle(1,3);
Bar(PPMX+311,PPMY-308,PPMX+327,PPMY-388);
Bar(PPMX+327,PPMY-374,PPMX+352,PPMY-328);
Bar(PPMX+327,PPMY-328,PPMX+401,PPMY-315);
Rectangle(PPMX+311,PPMY-308,PPMX+327,PPMY-388);
Line(PPMX+206,PPMY-357,PPMX+311,PPMY-357);
Line(PPMX+327,PPMY-374,PPMX+352,PPMY-374);
Line(PPMX+352,PPMY-374,PPMX+352,PPMY-328);
Line(PPMX+352,PPMY-357,PPMX+486,PPMY-357);
Line(PPMX+486,PPMY-347,PPMX+373,PPMY-347);
Line(PPMX+486,PPMY-339,PPMX+396,PPMY-339);
Line(PPMX+327,PPMY-328,PPMX+401,PPMY-328);
Line(PPMX+401,PPMY-315,PPMX+327,PPMY-315);
Line(PPMX+401,PPMY-315,PPMX+401,PPMY-328);
Line(PPMX+206,PPMY-315,PPMX+311,PPMY-315);
Line(PPMX+206,PPMY-344,PPMX+293,PPMY-344);
Line(PPMX+486,PPMY-323,PPMX+401,PPMY-323);
SetColor(Colortt);
Line(PPMX+242,PPMY-297,PPMX+437,PPMY-297);
Line(PPMX+178,PPMY-265,PPMX+243,PPMY-297);
Line(PPMX+374,PPMY-265,PPMX+437,PPMY-296);
Line(PPMX+374,PPMY-258,PPMX+437,PPMY-290);
Line(PPMX+178,PPMY-265,PPMX+374,PPMY-265);
Line(PPMX+374,PPMY-258,PPMX+178,PPMY-258);
Line(PPMX+374,PPMY-248,PPMX+178,PPMY-248);
Line(PPMX+374,PPMY-238,PPMX+178,PPMY-238);
Line(PPMX+374,PPMY-228,PPMX+178,PPMY-228);
Line(PPMX+374,PPMY-248,PPMX+438,PPMY-280);
Line(PPMX+374,PPMY-238,PPMX+438,PPMY-270);
Line(PPMX+374,PPMY-228,PPMX+438,PPMY-260);
SetColor(14);
Line(PPMX+319,PPMY-295,PPMX+325,PPMY-308);
Line(PPMX+319,PPMY-295,PPMX+313,PPMY-308);
Line(PPMX+319,PPMY-308,PPMX+319,PPMY-295);
Line(PPMX+321,PPMY-308,PPMX+319,PPMY-295);
Line(PPMX+323,PPMY-308,PPMX+319,PPMY-295);
SetColor(3);
u:=2;
For i:=1 to 4 DO
begin
Line(PPMX+374,PPMY-258+u,PPMX+178,PPMY-258+u);
Line(PPMX+374,PPMY-258+u,PPMX+438,PPMY-290+u);
Inc(u,10);
end;
SetColor(ColorTT);
Bar(PPMX+486,PPMY-200,PPMX+521,PPMY-381);
Line(PPMX+486,PPMY-381,PPMX+506,PPMY-391);
Line(PPMX+521,PPMY-381,PPMX+541,PPMY-391);
Line(PPMX+506,PPMY-391,PPMX+541,PPMY-391);
Line(PPMX+541,PPMY-391,PPMX+541,PPMY-210);
Rectangle(PPMX+486,PPMY-200,PPMX+521,PPMY-381);
SetColor(8);
Rectangle(PPMX+493,PPMY-376,PPMX+516,PPMY-207);
SetColor(ColorTT);
Rectangle(PPMX+491,PPMY-376,PPMX+516,PPMY-205);
PPMY:=GetMaxY-30;
PPMX:=28;
u:=0;
For i:=0 To 10 Do
begin
Circle(PPMX+357+u,PPMY-163,2);
Inc(u,6);
end;
XX:=PPMX;
YY:=PPMY;
Dec(PPMX,45);
DEC(PPMY,15);
{ORDINA}
SetColor(11);
REctangle(PPMX+69,PPMY-171,PPMX+176,PPMY-192);
Line(PPMX+176,PPMY-192,PPMX+202,PPMY-201);
Line(PPMX+202,PPMY-184,PPMX+176,PPMY-171);
Line(PPMX+202,PPMY-201,PPMX+202,PPMY-184);
Line(PPMX+202,PPMY-201,PPMX+181,PPMY-201);
SetColor(4);
SetFillStyle(1,7);
Bar(PPMX+102,PPMY-200,PPMX+160,PPMY-237);
REctangle(PPMX+102,PPMY-200,PPMX+160,PPMY-237);
SetFillStyle(1,3);
SetColor(11);
REctangle(PPMX+100,PPMY-199,PPMX+160,PPMY-237);
REctangle(PPMX+97,PPMY-195,PPMX+165,PPMY-242);
Line(PPMX+116,PPMY-245,PPMX+181,PPMY-245);
Line(PPMX+181,PPMY-200,PPMX+181,PPMY-245);
Line(PPMX+97,PPMY-242,PPMX+116,PPMY-245);
Line(PPMX+165,PPMY-242,PPMX+181,PPMY-245);
Line(PPMX+165,PPMY-195,PPMX+181,PPMY-200);
Line(PPMX+69,PPMY-192,PPMX+97,PPMY-199);
REctangle(PPMX+76,PPMY-177,PPMX+112,PPMY-180);
REctangle(PPMX+76,PPMY-184,PPMX+112,PPMY-188);
REctangle(PPMX+55,PPMY-150,PPMX+135,PPMY-152);
Line(PPMX+80,PPMY-168,PPMX+163,PPMY-168);
Line(PPMX+55,PPMY-152,PPMX+80,PPMY-168);
Line(PPMX+135,PPMY-152,PPMX+163,PPMY-168);
{***}
Line(PPMX+135,PPMY-150,PPMX+163,PPMY-166);
u:=0;
For i:=0 To 9 Do
begin
Line(PPMX+140+u,PPMY-188,PPMX+140+u,PPMY-176);
Inc(u,3);
end;
SetColor(1);
u:=0;
For i:=0 To 5 Do
begin
Circle(PPMX+107+u,PPMY-230,1);
Circle(PPMX+107+u,PPMY-225,1);
Circle(PPMX+107+u,PPMY-220,1);
Circle(PPMX+107+u,PPMY-215,1);
Circle(PPMX+107+u,PPMY-210,1);
Circle(PPMX+107+u,PPMY-205,1);
Inc(u,4);
end;
SetColor(11);
u:=0;
For i:=0 To 10 Do
begin
Circle(PPMX+85+u,PPMY-164,1);
Circle(PPMX+78+u,PPMY-160,1);
Circle(PPMX+71+u,PPMY-156,1);
Inc(u,6);
end;
SetColor(15);
Inc(PPMX,30);
Inc(PPMY,35);
SetBox(7,21,21,26,3,15,7);
SetFillStyle(1,7);
Bar(PPMX+45,PPMY-140,PPMX+88,PPMY-110);
SetFillStyle(1,3);
SetColor(14);
Outtextxy(180,210,#27);
Line(185,213,195,213);
Outtextxy(180,350,#27);
Line(195,214,195,353);
Outtextxy(220,280,#26);
Line(185,353,195,353);
Line(195,283,220,283);
SetColor(15);
Rectangle(PPMX+43,PPMY-142,PPMX+90,PPMY-108);
Rectangle(PPMX+45,PPMY-140,PPMX+88,PPMY-110);
u:=0;
For i:=0 To 7 Do
begin
Circle(PPMX+45+u,PPMY-98,2);
Circle(PPMX+45+u,PPMY-88,2);
Circle(PPMX+45+u,PPMY-78,2);
Circle(PPMX+45+u,PPMY-68,2);
Inc(u,6);
end;
u:=0;
For i:=0 To 6 Do
begin
Circle(PPMX+107+u,PPMY-130,2);
Circle(PPMX+107+u,PPMY-120,2);
Circle(PPMX+107+u,PPMY-100,2);
Circle(PPMX+107+u,PPMY-80,2);
Circle(PPMX+107+u,PPMY-70,2);
Inc(u,6);
end;
end; {numerical}
PROCEDURE InitGraphique;
begin
Initialise_Graphique;
Debugger:=False;
N_Number:=0;
FIN_M2:=True;
ED_Rotation:=False;
Angle_ED:=0;
Reyon_Util:=4;
ZX:=0; ZY:=0; ZZ0:=0;
C:=Nil;
W:=Nil;
GetMem(BufTexte,SizeOf(Buf___Ptr));
New(W);
New(C);
Init_Table_Ouverture;
if (BufTexte<>Nil) And (W<>Nil) And (C<>Nil) Then
begin
Size_Menu_Buf:=ImageSize(1,1,30,30);
GetMeM(Menu_Buf,Size_Menu_Buf);
SetLineStyle(0,0,0);
Numerical;
ix:=KeyBoard;
{ix:=GetKeyDelay(32000);}
REstoreCRTMODE;
End
else
begin
Writeln('Error: Pas asez de Memoire vive.');
Writeln('Liberer la memoire ou retirer les programmes résidents.');
Writeln('Pressez une touche');
ch:=Readkey;
Halt(1);
end;
end; { De Proc‚dure Init}
Procedure Metre_un_Veille;
Const
Seed = 1958; { Valeur semence du générateur aléatoire }
NumPts = 2100; { Quantité de pixels à traiter }
PPP = 4;
Var
III,XXX, YYY, Color : WORD;
XXMax, YYMax : INTEGER;
_ViewInfo : ViewPortType;
ColorPoint : Integer;
Max__Color : WORD;
begin
Randomize; { Init générateur de nombres aléatoire }
Max__Color := Graph.GetMaxColor; { Récup + grand numéro de couleur de tracé }
GetViewSettings(_ViewInfo);
WITH _ViewInfo DO
begin
XXMax := (x2-x1-1);
YYMax := (y2-y1-1);
end;
WHILE NOT KeyPressed DO
begin
{** Pose pixels al‚atoires **}
RandSeed := Seed;
III := 0;
WHILE (NOT KeyPressed) AND (III < NumPts) DO
begin
Color:=Random(Max__Color)+1;
if Color>0 Then
begin
Inc(III);
Graph.PutPixel(Random(XXMax), Random(YYMax), Color);
end;
end;
{** Efface pixels **}
RandSeed := Seed;
III := 0;
WHILE (NOT KeyPressed) DO
begin
XXX := Random(XXMax)+1;
YYY := Random(YYMax)+1;
Color := Random(Max__Color)+1;
ColorPoint := Graph.GetPixel(XXX, YYY);
if (Graph.GetPixel(XXX, YYY)<>0) And (Color>0) And
(Color<>ColorPoint) Then
begin
if (iii=0) And (XXX-PPP>0) And (XXX-PPP<XXMax) And (YYY-PPP>0) And
(YYY-PPP<YYMax) Then
begin
Graph.PutPixel(XXX, YYY, 0);
Graph.PutPixel(XXX-PPP, YYY-PPP, Color);
iii:=1;
End
else
if (iii=1) And (XXX+PPP>0) And (XXX+PPP<XXMax) And (YYY+PPP>0) And
(YYY+PPP<YYMax) Then
begin
Graph.PutPixel(XXX, YYY, 0);
Graph.PutPixel(XXX+PPP, YYY+PPP, Color);
iii:=0;
end;
end;
end;
end;
end; {** Metre_un_Veille **}
End.
{**========end file unite ========**}Le dictionnaire▲
Démo des fonctions :
- Traduction Français / Anglais
- Traduction Anglais / Français
- Traduction et suggestions Français / Anglais
- Traduction et suggestions Anglais /Français
Les fichiers :
- Box13.tpu : pour les parties d'affichage.
- Var2.tpu : déclarations de variables.
- Buff1.tpu : déclaration de buffers.
- Get_Key1.tpu : entrées au clavier et définition de touches normales et Ctrl, Alt et touches F1 à F10.
- Traduc1.tpu : Unité de traduction définie avec des parties Directive IFDEF à compiler ou non compiler.
Exemple de directive $IFDEF - $ELSE - $ENDIF pour le mode de compilation :
Sélectionnez
{** $define __COPYDAF__ **}
{** $define __INCONNUS__ **}
{** $define __ERREUR__ **}Exemple partie de conditions simple :
Sélectionnez
{$ifdef __COPYDAF__}
Partie à compile si le nom à été déclare.
{$endif}Ou partie de conditions avec $else :
Sélectionnez
{$ifdef __COPYDAF__}
Partie à compiler si le nom a été déclare.
{$else}
Sinon compiler cette partie.
{$endif}
Les fichiers Demo_Dic.pas et .EXE doivent se trouver dans le répertoire du logiciel EDNUM.exe, où il y à le répertoire EDNUM\ contenant les fichiers du dictionnaire nécessaires : 1FraAng2.Idx - 2AngFra1.idx - FranAngl.dic.
Sur Traduc1.pas : les parties nom compilées font d'autres fonctions sur EDNUM, leur explication dans un avenir proche, si notre monde ou notre planète continue à tourner au tour du Soleil.
Le fichier compressé DemoTraduc.zip contient déjà le répertoire nécessaire EDNUM\ avec les fichiers du dictionnaire pour le fonctionnement de la Démo : 1FraAng2.Idx - 2AngFra1.idx - FranAngl.dic.
Les seules fonctions et procédures manquantes pour qu'il fonctionne avec TPW sont :
Sélectionnez
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 );
Function ReadBox (x, y : byte; Var SS : string; Longeur, MaxCh : byte ) : boolean;Téléchargement :
Fichier Demo_Dic.zip