Aller à la recherche

L'unité V-Courbe

Cette unité permet de réaliser le tracé même de la fonction. La procédure trace_fonction permet de tracer en mode paramétré, cartésien ou polaire. Attention cependant aux fonctions 'dérive' et 'intégrale' qui n'analysent pas la fonction mais font le calcul en direct. Si vous vous retrouvez avec un point de rebroussement et donc une fonction non dérivable sur un intervalle donné ces deux procédures ne seront pas fiables. Ce point de rebroussement arrive dans de nombreuses configurations physique comme par exemple les logiciels ou la courbe qui représente la trajectoire de la bille a un superbe point de rebroussement à l'endroit du choc de la bille visée. Attention on est la en pascal en programmation orientée objet sans aucune récursivité.

Unit V_Courbe;

(*$DEFINE VERSION_FR *) (*$DEFINE DEB*) {$DEFINE VERSION_NORMALE} (*$DEFINE VERSION_MONO*) interface uses Strings, WinTypes, WinProcs, WinDos, Win31, WObjects, StdDlgs,

                                    Uimpri,CommDlg,TypKonst,my_math;

type

 PEWindow = ^TEWindow; {pour faire une fenêtre d'outils}
 TEWindow = object(TWindow)
   constructor Init(AParent: PWindowsObject; ATitle: PChar;X0,Y0:INTEGER);
   Destructor  Done; Virtual;
   procedure Paint(PaintDC: HDC; var PaintInfo: TPaintStruct); virtual;
   procedure SetUpWindow; Virtual;

END;

VAR

 {GWnd,}Geom_Wind: PWindow;
 Points,Video,Textes,Textes_Ciel: PCollection;
 V_points : Pcollection;
 T_F            : TransfertFonction;
 T_Txt          : TransfertTextes;
 T_Txth         : TransfertTexteh;
 T_macro        : Transfert_macro;
 T_M            : TransfertParam;
 T_Pol          : TransfertPolaire;
 T_P            : TransfertPoint;
 LogFont        : TlogFont;
 SaveObject               : THandle;
 Avec_fond,Deplace_Xor    : Boolean;
 Raffraichir,Nettoyer     : Boolean;
 Enfonce                  : Boolean;
 Raffraichissons          : Boolean;
 Imprime_La_Zone          : Boolean;
 Imprime_tout             : Boolean;
 Efface,Kontrol,En_Jaune  : Boolean;
 TEXTEA                   : ChaineL;
 Option_point             : BYTE;
   V_Cf,V_Cf1,V_Cstm,V_Cstp : String150;
   param :Array0..15,1..2 OF REAL;
   pp,n,pp1,n1:array1..40 of integer;
   H_fontes : array1..5 OF Integer;
   tb,tb1:array1..40 of real;
   VieuxTbX,VieuxTbY :REAL;
   err,maxs,maxt,maxs1,maxt1,I:integer;
   sf,tf,sf1,tf1:string40;
   xf,xf0,mf,pf,Quat_D:real;
   FLAG,MonEsc        : BOOLEAN;
   Bouge_Texte        : BOOLEAN;
   Param0             : BYTE; {1 -> cartésienne, 2-> paramétrée; 3-> polaire}
   ERREUR0,MIL:INTEGER;
   Chf,Chf1,V_Chf,MINO,MAXO,CSTM,CSTP,Cf,Cf1,Mon_Pas:STRING150;
   No,Ni,NNo,NNi,
   Nc,Xoo,Yoo,Xo,Yo,Vno,Vni,Vxo,Vyo        : INTEGER;
   Xorig,Yorig{,precision}  : INTEGER;
   Scroll_X,Scroll_Y        : INTEGER;
   Scroll_Vx,Scroll_VY      : INTEGER;
   Unite_XR,Unite_YR,   {ces deux variables sont utiles pour les repères noms normés}   
   UniteX,UniteY,
   Viel_UniteX,Viel_UniteY,
   rasto,ratio              : REAL;
   Region_Imp               : Hrgn;
   Degre_precis,mesure_precis:INTEGER;
   d_Scroll,compt_ole       : INTEGER;
   V_Fonc,A_Fonc            : INTEGER;
   Fonc,Compt_Nom           : INTEGER;
   Fonc_Aide                : INTEGER;
   On_Scrolle               : BYTE;
   Vitesse,R0               : INTEGER;
   {Reduc                    : Real;
   On_Reduit                : BOOLEAN;}
   {Export_VEC               : Boolean;}

procedure TRACE_FONC(DC:HDC;Color:TcolorRef); procedure ENTREE; function VALEUR(st:STRING):REAL; procedure Recupere_Chf1(St:STRING); function Cette_Courbe(St:STRING;VAR X,Y:REAL;An:INTEGER):BOOLEAN; Procedure Cale_Sur_Courbe(St:String;VAR X,Y:REAL); procedure Quelle_Fn_Affine; procedure Quelle_Fn_Param; procedure Quelle_Fn_polaire; procedure Quelle_XY(n:BYTE);{1 pour coord,2 pour rect,3 pour losange, 4 pour parallélo} function Supprime_ton:BOOLEAN; function Editor:BOOLEAN; procedure Histo_edit; procedure Ajoute_St(St:STRING;n:INTEGER); procedure Rempli_Buff_Affine; procedure Rempli_Buff_Polaire; procedure Rempli_Buff_Param; procedure Recupere_POs(n:INTEGER); Function RAOUND(X:REAL):INTEGER; Function Distance(x0,y0,x1,y1:REAL):REAL; {Procedure Init_Texte(VAR TexteN:ChaineL);} procedure Affiche(r:REAL;St:String;Pos:BYTE); procedure Texte_Cadre(DC:HDC;X0,Y0,X1,Y1:INTEGER ;TexteF:ChaineL;Transpar:BOOLEAN;P:INTEGER;N_font:BYTE); procedure Ma_TextOut(Dc:HDC;X,Y:INTEGER;Pch0:STRING;Lng:INTEGER); procedure Ecris_Reel(DC:HDC;r:Real;Virg,X,Y,Coul:longINT;Tal:INTEGER); procedure Ecris_ReelTrans(DC:HDC;r:Real;Virg,X,Y,Coul:longINT;Tal:INTEGER); {Function Maximum(X,Y:INTEGER):INTEGER;} function plusgrand(x1,x2,x3,x4:INTEGER):INTEGER; procedure Recup_Biss(VAR A,B,C,D:REAL;An:REAL); Procedure DEDANS(VAR x:REAL;a,b:REAL); procedure VIDE_BLANC(VAR Ch0:STRING); procedure Dess_Gomme(DC : HDC); procedure Dess_Xor(DC : HDC); procedure Dess_Norm(DC : HDC); function Rund(X:Real):INTEGER; {pour recaler avec scroller} function Rond(Y:Real):INTEGER; {pour recaler avec scroller} procedure m_vers_a(VAR st:STRING);

procedure debug(Fmt,debugstring: Pchar; var ARGLIST); procedure Fonte_par_defaut(H,I,n:Integer); procedure Kelle_Fonte(n:Integer); procedure RECT_PLEIN(DC:HDC;X,Y,Xp,Yp:INTEGER;Coul1,Coul2:TcolorRef); procedure Grise_Anime(OUI,Reduisant: BOOLEAN); procedure Grise_Menu(Att:INTEGER;Flag:BOOLEAN); function suis_je_droite(St:String;VAR X,Y:REAL):BOOLEAN; Function nombre_Derive(St:String;VAR X:Real):Real; Function nombre_primaire(St:String;VAR X:REAL;Xp:Real):Real; procedure derive(DC:HDC;Color:TcolorREf;St:String); procedure integrale(DC:HDC;Color:TcolorREf;St,Nm:String); function nouveau_nom(st1,st2:string):String; procedure Aff_macro(St:Macro_Char;n:BYTE); procedure Quelle_macro(n:BYTE); procedure rempli_buff_macro(ny:BYTE); function IntersC(St1,St2:String;VAR X,Y:REAL):BOOLEAN; procedure Dialogue_imprime; procedure Dialogue_presente(k:integer); procedure il_faut_commencer; {récupère le File_ROOT} procedure StRootCopy(VAR F_name:TfileX;St:STRING); procedure Extrait(Nm : STRING; VAR X,Y : REAL); procedure decompose_nom(Nm : STRING); procedure fait_nom(VAR Nm : STRING); {} IMPLEMENTATION {} uses var_ab;

procedure il_faut_commencer; {récupère le File_ROOT} VAR

 Dir: array0..fsDirectory of Char;
 Name: array0..fsFileName of Char;
 Ext: array0..fsExtension of Char;

BEGIN

 getmodulefilename(getmodulehandle('Geom96.exe'),File_root,179);
 filesplit(File_root,Dir,Name,Ext);
 STRCopy(File_root,Dir);

END;

procedure StRootCopy(VAR F_name:TfileX;St:STRING); VAR F_N : TfileX; BEGIN

vide_blanc(St);
IF st1<>'\' THEN StrPcopy(F_name,St)
              ELSE
               BEGIN
                StrCopy(F_name,File_root);
                StrPcopy(F_N,St);
                StrCat(F_name,F_N);
               END;

END;

constructor TEWindow.init; VAR Sx,Sy : INTEGER; BEGIN

 Sx:=GetSystemMetrics(Sm_CXScreen);{largeur de l'écran }
 Sy:=GetSystemMetrics(Sm_CYScreen);{hauteur de l'écran }
 TWindow.Init(Aparent,Atitle);
 Attr.X:=ROUND((Sx-Limage)/2);
 Attr.Y:=ROUND((Sy-Himage)/2);
 Attr.W:=Limage;
 Attr.H:=Himage;
 Attr.Style := Ws_visible or Ws_popup or Ws_border;

END; procedure TEWindow.SetUpWindow; BEGIN

Twindow.setUpwindow;
WindO:=Hwindow;

END;

destructor TEWindow.done; BEGIN

 Tobject.Done;
 TWindow.Done;
 deleteObject(Image);
 Himage:=0;

END; procedure TEWindow.paint(PaintDC: HDC; var PaintInfo: TPaintStruct); VAR oldBitmap : Hbitmap;

   MemDC :HDC;

BEGIN

  MemDC := CreateCompatibleDC(PaintDC);
  OldBitmap:=SelectObject(MemDC,Image);
  BitBlt(PaintDC,0,0,Limage,Himage,MemDC,0,0,SrcCopy);
  SelectObject(MemDC,OldBitmap);
  DeleteDC(MemDC);

END;

procedure Grise_Menu(Att:INTEGER;Flag:BOOLEAN); VAR TheTexT:ARRAY0..40 OF Char;

    I :INTEGER;

BEGIN

 IF Flag THEN I:=mf_ByCommand OR mf_Grayed
  ELSE I:=mf_Bycommand OR mf_UnHilite;
 GetMenuString(No_Menu,Att,TheText,40,mf_ByCommand);
 ModifyMenu(no_Menu,Att,I,Att,TheText);

END;

procedure Grise_Anime(OUI,Reduisant: BOOLEAN); VAR N: BYTE; BEGIN

 FOR N:=1 TO 5 DO BEGIN Grise_Menu(Id_Macro+n,OUI);GRise_Menu(600+N,OUI) END;
 FOR N:=1 TO 4 DO Grise_Menu(900+N,OUI);
 FOR N:=0 TO 6 DO Grise_Menu(470+N,OUI);
 FOR N:=0 TO 4 DO Grise_Menu(209+N,OUI);
 FOR N:=0 TO 8 DO BEGIN Grise_Menu(300+n,OUI);Grise_Menu(400+n,OUI); END;
 IF Reduisant THEN FOR N:=0 TO 5 DO Grise_Menu(374+n,OUI)
       ELSE
 BEGIN
   {Grise_Menu(id_reduc,OUI);}
   {Grise_Menu(id_edition,OUI);}
                 GRise_Menu(Imprim,OUI);
                 {Grise_Menu(Id_ImprimeF,OUI);}
 END;
 Grise_Menu(id_TexteA,OUI);
 Grise_Menu(id_angle_arc,OUI);
 IF fonc<>Reconstruire THEN Grise_Menu(Sauve,OUI);
 IF fonc<>Reconstruire THEN Grise_Menu(SauveSous,OUI);
 IF fonc<>Reconstruire THEN Grise_Menu(Charge,OUI);
 Grise_Menu(Efface_le,OUI);
 Grise_Menu(id_Efface_tout,OUI);
 Grise_Menu(Detruire,OUI);
 IF fonc<>Reconstruire THEN Grise_Menu(Id_Memorise,OUI);
 IF fonc<>Reconstruire THEN Grise_Menu(Id_Restitue,OUI);
 Grise_Menu(def_zone,OUI);
 Grise_Menu(long_segment,OUI);
 Grise_Menu(mes_angle,OUI);
 Grise_Menu(Aveclettres,OUI);
 Grise_Menu(Avecmasses,OUI);
 Grise_Menu(id_fond,OUI);
 Grise_menu(Id_deg1,OUI);
 Grise_menu(Id_mes1,OUI);
 Grise_menu(Id_mes2,OUI);
 Grise_menu(Id_mes3,OUI);
 Grise_Menu(Lier,OUI);
    Grise_menu(Id_bouge_vit,OUI);
    Grise_menu(R_A_Zero,OUI);
    Grise_menu(Configure,OUI);
    {Grise_menu(Aff_Longs,OUI);}
    {Grise_menu(Fine,OUI);}
    Grise_menu(Id_Enchaine,OUI);
    Grise_menu(Id_Trace,OUI);
 IF Def_Rect THEN GRise_Menu(Imp_Zone,OUI);

{Modif 017 Stef 06/07/94} { IF imbrication THEN Grise_menu(id_update,OUI);}

 IF imbrication THEN  GriseparPosition(OUI,0,5);

{Modif 017 Stef 06/07/94} END;

procedure RECT_PLEIN(DC:HDC;X,Y,Xp,Yp:INTEGER;Coul1,Coul2:TcolorRef); VAR {Lbrush : TlogBrush;}

      Brosse,Vbrosse  : Hbrush;
      Crayon,V_Crayon                   : HPen;

BEGIN

  crayon:= CreatePen(Ps_solid,1,coul2);
  V_Crayon := SelectObject(DC,crayon );
   Brosse:=CreateSolidBrush(Coul1);
   Vbrosse:=SelectObject(DC,Brosse);
   Rectangle(DC,X,Y,Xp,Yp);
   SelectObject(DC,Vbrosse);
   DeleteObject(Brosse);
   SelectObject(DC,V_crayon);
   DeleteObject(Crayon);

END;

procedure Kelle_Fonte(n:Integer); var

 ChooseRec: TChooseFont;
 Style    : array 0..100 of Char;
begin
 GetObject(fonten,sizeof(Tlogfont),@logfont);
 FillChar(ChooseRec, SizeOf(ChooseRec), #0);
 with ChooseRec do
 begin
   lStructSize:= SizeOf(TChooseFont);
   hwndOwner  := Wind0;
   lpLogFont  := @LogFont;
   Flags      := cf_ScreenFonts or cf_Effects or cf_InitToLogFontStruct;
   lpszStyle  := Style;
 end;
 IF NOT(ChooseFont(ChooseRec)) THEN Exit;
 if Fonten <> 0 then DeleteObject(Fonten);
 Fonten := CreateFontIndirect(LogFont);
END;

procedure Fonte_par_defaut(H,I,n:Integer); begin

 FillChar(LogFont, SizeOf(TLogFont), #0);
 with LogFont do
 begin
   lfHeight        := H;                             
   lfWeight        := FW_Normal;
   lfWidth         := 0;                                       
   lfItalic        := I;      {Non-zero value indicates italic   }
   lfUnderline     := 0;      {Non-zero value indicates underline}
   lfOutPrecision  := Out_Default_Precis;
   lfClipPrecision := Clip_Default_Precis;
   lfQuality       := Proof_Quality;
   lfPitchAndFamily:= Variable_Pitch;
   IF n=4 THEN StrCopy(@lfFaceName, 'MS sans serif')
          ELSE StrCopy(@lfFaceName, 'Times New Roman');
 end;
 if Fonten <> 0 then DeleteObject(Fonten);
 Fonten := CreateFontIndirect(LogFont);

end;

procedure debug(Fmt,debugstring: Pchar; var ARGLIST); var strdebug :ARRAY 0..128 of CHAR; begin

    (*$ifdef DEBUG_OLE*)
             wvsprintf(strdebug,fmt, ARGLIST);
             messagebox(0,strdebug,debugstring,mb_ok or mb_systemmodal);
    (*$endif*)

end;

function Rund(X:Real):INTEGER; {pour recaler avec scroller} BEGIN

IF X<>MIl THEN Rund:=RAound(X-Scroll_X)
          ELSE Rund:=Mil;

END;

function Rond(Y:Real):INTEGER; {pour recaler avec scroller} BEGIN

IF Y<>MIL THEN Rond:=RAound(Y-Scroll_Y)
   ELSE Rond:=Mil;

END;

procedure Dess_Gomme(DC : HDC); BEGIN

{setBkColor(DC,Blanc);}
SetROP2(DC,  R2_CopyPen);
Efface:=TRUE;

END;

procedure Dess_Xor(DC : HDC); BEGIN

SetRop2(DC, R2_NotXorPen);
Efface:=FALSE;  {est-ce vraiment nécessaire?}

END;

procedure Dess_Norm(DC : HDC); BEGIN

 SetROP2(DC, r2_CopyPen);
 EFFACE:=FALSE;

END;

Procedure DEDANS(VAR x:REAL;a,b:REAL); VAR Min,Max :REAL; BEGIN

IF a<b THEN BEGIN MIN:=a;Max:=b END
ELSE BEGIN MIN:=b;Max:=a END;
IF X<MIN THEN X:=MIN;
IF X>MAX THEN X:=MAX;

END;

procedure Recup_Biss(VAR A,B,C,D:REAL;An:REAL); VAR Af:INTEGER; BEGIN

  Af:=RAOUND(An);
  A:=(Af DIV 1000);
  B:=((Af-RAOUND(A)*1000) DIV 100)  ;
  C:=((Af-RAOUND(A)*1000-RAOUND(B)*100) DIV 10);
  D:= ;

END;

procedure Ecris_Reel(DC:HDC;r:Real;Virg,X,Y,Coul:longINT;Tal:INTEGER); VAR St:String7;

   St0: Array 0..6 of char;
   V_tal:INTEGER;

BEGIN

Str(r:7:virg,St);
StrPcopy(St0,St);
V_Tal:=SetTExtAlign(DC,Tal);
SetTextColor(Dc,coul);
TextOut(Dc,X,Y,St0,sizeof(St0));
SetTextAlign(DC,V_Tal);

END;

procedure Ecris_ReelTRans(DC:HDC;r:Real;Virg,X,Y,Coul:longINT;Tal:INTEGER); BEGIN

 IF Raffraichissons THEN SetBkMode(DC,transparent);
 Ecris_Reel(DC,r,Virg,X,Y,Coul,Tal);
 IF Raffraichissons THEN SetBkMode(DC,Opaque);

END;

Function Minimum(X,Y:REAL):REAL; BEGIN

IF X>Y THEN Minimum:=Y
ELSE Minimum:=X;

END;

Function Maximum(X,Y:REAL):REAL; BEGIN

IF X<Y THEN Maximum:=Y
ELSE Maximum:=X;

END;

function plusgrand(x1,x2,x3,x4:INTEGER):INTEGER; Var x:INTEGER; BEGIN

X:=ROUND(Maximum(x1,x2));
X:=ROUND(Maximum(x,x3));
PlusGrand:=ROUND(Maximum(x,x4));

END;

procedure Ma_TextOut(Dc:HDC;X,Y:INTEGER;Pch0:STRING;Lng:INTEGER); VAR pch1 : ARRAY0..20 OF CHAR; BEGIN

 SetBkMode(DC,Transparent);
 StrPcopy(Pch1,Pch0);
 TextOut(Dc,X,Y,Pch1,lng);
 SetBkMode(DC,Opaque);

END;

function la_couleur(n:INTEGER):TcolorRef; BEGIN

Case n of
 0: La_couleur:=BLANC;
 1: La_couleur:=BLANC;
 2: La_couleur:=BOUTEILLE;
 3: La_couleur:=GRIS;
 4: La_couleur:=VERT;
 5: La_couleur:=BLEU;
 6: La_couleur:=NOIR;
 7: La_couleur:=VIOLET;
 8: La_couleur:=ROUGE;
END;

END;

function dernier_blanc(DC : HDC; Texte : Pchar; long: WORD;VAR FIN:BOOLEAN;N_font:BYTE): WORD; VAR BUFF : CHAINEL;

   larg,n : WORD;

BEGIN

n:=0;
FIN:=FALSE;
{on avance jusqu'à la longueur long}
dec(n);
Repeat
     inc(n);
     StrLcopy(Buff,Texte,n);
     larg:=loWord(GetTextExtent_perso(DC,Buff,n+1,N_font));
until (larg>long) OR (n=strlen(Texte)) OR (texten=#13) ;
{puis on revient sur le blanc précédent}
IF (texten=#13) THEN BEGIN texten:=#32;texten+1:=#32;inc(n) END
ELSE
IF (n<strlen(Texte)) THEN  While (Texten<>#32) AND (Texten<>'=') AND (Texten<>'+')
                                  AND (Texten<>'-') AND (Texten<>'*') AND (N>0) DO DEC(n)
                     ELSE  FIN:=TRUE;  {faux car fin de chaîne}
IF n=0 THEN BEGIN n:=StrLen(Texte); FIN:=TRUE; END;
IF (not(FIN)) THEN INC(n);
dernier_blanc:=n;

END;

procedure My_DrawText(DC:HDC; Rect: Trect; Texte1:ChaineL;N_Font:BYTE); VAR Texte2 : ChaineL;

   larg,Haut,n :WORD;
   PCh0 : Pchar;
   FIN  : BOOLEAN;

BEGIN

{New(Ptxt);}
larg:=Abs(Rect.Right-Rect.left);
Haut:=HiWord(GetTextExtent_perso(DC,'A',1,N_font));
PCh0:=StrNew(Texte1);
 Repeat
       n:=dernier_BLANC (DC,PCh0,larg,FIN,N_font);
       StrLcopy (Texte2,PCh0,n);
       TextOut(DC,Rect.left,Rect.top,Texte2,StrLen(Texte2));
       Rect.top:=Rect.top+Round(Haut);
       PCh0:=PCh0+n;
    until FIN;
IF Strlen(Pch0)<>0 THEN StrDispose(PCh0);

END;

procedure Texte_Cadre(DC:HDC;X0,Y0,X1,Y1:INTEGER ;TexteF:ChaineL;Transpar:BOOLEAN;P:INTEGER;N_font:BYTE); VAR Gtext: LongInt;

   H,L    : Word;
   Rect : Trect;

BEGIN

{Le choix de la fonte vient de l'extérieur, par exemple de la procédure affiche}
SelectObject(Dc ,FonteN_font);
Gtext:=GetTextExtent_perso(DC,'A',1,n_font);
IF Transpar THEN SetBkMode(DC,Transparent)
     ELSE SetBkMode(DC,Transparent);
IF (P>0) OR (efface) THEN {il s'agit d'un cadre de texte avec couleur de fond non blanche}
   BEGIN
    IF efface THEN Rect_plein(DC,x0+1,y0+1,x1,y1,BLANC,BLANC)
              ELSE Rect_plein(DC,x0+1,y0+1,x1,y1,la_couleur(P),la_couleur(P));
    SetBkMode(DC,transparent);
   END;
H:=HiWord(Gtext);
L:=LoWord(Gtext);
Rect.left  :=ROUND(Minimum(X0,X1)+L/2);
Rect.Top   :=ROUND(Minimum(Y0,Y1)+H/4);
Rect.Right :=ROUND(Maximum(X1,X0));
Rect.Bottom:=ROUND(Maximum(Y1,Y0));
setTextAlign(DC,ta_left or ta_NoupdateCp);
IF N_font=4 THEN My_drawTExt(DC,Rect,TexteF,N_font) 
            ELSE DrawText(DC,TexteF,Strlen(TexteF),Rect,dt_wordBreak);

END;

procedure Aff_macro(St:Macro_char;n:BYTE); VAR Dc:HDC;

  Texte_Ai:CHAINEL;

BEGIN StrCopy(Texte_Ai,St); DC:=GEtDC(Wind0); {SelectObject(DC, Fonte7);} Rect_PLEIN(Dc,4,373+21*(n-1)+5,68,373+21*(n-1)+19,GRIS,GRIS);{efface l'ancien texte} Texte_Cadre(DC,1,373+21*(n-1),68+1,373+21*(n-1)+20,Texte_Ai,TRUE,0,7);{remet le nouveau} ReleaseDC(Wind0,DC); END;

Procedure Affiche(r:REAL;St:String;Pos:BYTE); VAR Coul,Coulf:TcolorRef;

   X          :INTEGER;
   Valeur    :BOOLEAN;
   Affi      : CHAINEL;
   DC_or     : HDC;
   Texte_Ai    : CHAINEL;

BEGIN

 DC_or:=GEtDC(Wind0);
 StrPcopy(Affi,St);
 Coulf:=BLANC;
 Case Pos OF
 1: BEGIN
      Coul:=BLEU; X:=327; Valeur:=TRUE;
    END;
 2: BEGIN
      Coul:=ROUGE; X:=347; Valeur:=TRUE;
    END;
 3: BEGIN
      Coul:=ROUGE ; X:=367; Valeur:=TRUE;
    END;
 4: BEGIN
      Coul:=NOIR;  X:=353;  Valeur:=FALSE; COULF:=GRIS;
    END;
 END;
      SetBkColor(Dc_Or,coulF);                    
      SetTextColor(Dc_Or,coul);
      IF POS=4 THEN {correspond au texte de l'aide en ligne}
BEGIN
        Rect_PLEIN(Dc_or,350,-1,ClientX-1,38,GRIS,GRIS);{efface l'ancien texte}
 Init_Texte(Texte_Ai);
 Strcopy(Texte_Ai,Affi);
 Texte_Cadre(DC_Or,353,-4,ClientX-5,38,Texte_Ai,TRUE,0,6);{remet le nouveau}
END
      ELSE
BEGIN {correspond à l'affichage des mesures et longueurs en bas à gauche}
 Init_Texte(Texte_Ai);
 Strcopy(Texte_Ai,Affi);
 Rectangle(DC_or,2,X,70,X+18);
 Texte_Cadre(DC_Or,2,X-3,70,X+18,Texte_Ai,FALSE,0,7);
END;
      IF (VALEUR) AND (St<>'') THEN {pour afficher une mesure sous forme d'un réel aligné à droite}
     Ecris_Reel(Dc_Or,r,3,66,X+2,0,Ta_right);
 ReleaseDC(Wind0,DC_or);

END;

Function Distance(x0,y0,x1,y1:REAL):REAL; VAR xa,ya:REAL; BEGIN

Xa:=(x1-x0);
Ya:=(y1-y0);
distance:=SQrt(Xa*Xa+Ya*Ya);

END;

Function RAOUND(X:REAL):INTEGER; BEGIN

IF ABS(X)>32000 THEN X:=Mil;
RAOUND:=ROUND(X);

END;

procedure VIDE_BLANC(VAR Ch0:STRING); VAR i:BYTE; BEGIN

 While pos(' ',Ch0)>0 DO
   DElete(Ch0,pos(' ',ch0),1);

END;

procedure COMPLETE(VAR St:STRING;n:BYTE);VAR k:BYTE; BEGIN WHILE LENGTH(St)<n DO ST:=ST+' '; END;

procedure m_vers_a(VAR st:STRING); VAR i:BYTE; BEGIN

 For i:=1 TO length(st) do if Sti='m' then Sti:='a';

END;

procedure a_vers_m(VAR st:STRING); VAR i:BYTE; BEGIN

 For i:=1 TO length(st) do
              if (Sti='a')
                     AND 
                          AND 
                                AND 
                                        THEN Sti:='m';

END;

procedure SANS_BLANCS(VAR St:STRING); VAR i:BYTE; BEGIN i:=LENGTH(St);

  WHILE i>0 DO BEGIN IF (Sti=' ') OR (Sti='*') OR (Sti='i') THEN DELETE(St,i,1); DEC(i) END;

END;

procedure TRAD_FONC(var c:string); var i,n:byte; begin

 for i:=1 to 8 do
begin
 n:=pos(trigoi,c);
  while n>0 do
   begin
     IF (i<8) THEN cn:=chr(179+i);{car i=8 n'est pas une fonction mais pi}
     IF (i=4) OR (i=8) THEN delete(c,n+1,1) { ln ou pi deux lettres seulement }
                ELSE delete(c,n+1,2);
     n:=pos(trigoi,c);
   end;
end;

end;

procedure tout_en_minuscules(VAR st:STRING); VAR i:BYTE; BEGIN

 FOR i:=1 TO LENGTH(St) DO
    IF (Sti>#64) AND (Sti<#91) THEN Sti:=Chr(Ord(Sti)+32);

END;

function verif_b(st:STRING):BOOLEAN; VAR i:BYTE;

   Fl:BOOLEAN;

BEGIN

 Fl:=FALSE;
 FOR i:=1 TO LENGTH(St) DO
    IF (Sti='b') AND 
          THEN Fl:=TRUE;
 Verif_b:=Fl;

END;

function yn(a:char;s:string):boolean; begin

IF POS(a,S)>0 THEN yn:=TRUE
              ELSE yn:=FALSE;

end;

procedure MULT_DANS_CONST(VAR St:STRING); VAR i :BYTE; BEGIN

  For i:=1 To LENGTH(St) DO IF Sti='i' THEN DELETE(St,i,1);
  for i:=1 to (LENGTH(St)-1) do
        if  and (Sti+1='p'))
               OR ) then insert('*',St,i+1);
  For i:=1 To LENGTH(St) DO
        If Sti='p' THEN
             BEGIN
               DELETE(St,i,1);
               INSERT('3.14159',St,i);
             END;
 St:=St+'&';

END;

procedure RAMASSE_NOMBRE(VAR St,S1,SIGNE:STRING); VAR n:BYTE; BEGIN

n:=1;S1:=;SIGNE:=;
WHILE (yn(Stn,ens5+'-'+'+')) DO
  BEGIN
    S1:=S1+Stn;
    INC(n);
  END;
  SIGNE:=Stn;
  ST:=COPY(St,n+1,length(St)-n);

END;

procedure OPPOSE(VAR C:STRING); VAR i,n,m:BYTE;S:STRING; BEGIN n:=0;m:=0; FOR i:=1 TO LENGTH(C) DO IF (Ci=' ') THEN DELETE(C,i,1); FOR i:=1 TO LENGTH(C) DO IF YN(Ci,ENS3) THEN INC(n); FOR i:=1 TO LENGTH(C) DO IF yn(Ci,ENS4) THEN INC(m); If (n>0) AND (m=0) THEN ERR:=1; S:='0'; IF (C1='-') OR (C1='+') THEN C:='0'+C; {l'ancien FOR i:=3 TO est remplacé par FOR i:=2 } FOR i:=2 TO LENGTH(c) DO IF

                 AND (NOT yn(Ci-1,ENS4+')'))
                          THEN BEGIN INSERT(S,C,i);INC(i) END;

END;

procedure change_carre(VAR St:STRING); VAR k : INTEGER; BEGIN

k:=pos('²',St);
WHILE k>0 DO
 BEGIN
  DELETE(St,k,1);
  INSERT('^2',St,k);
  k:=pos('²',St);
 END;

END;

procedure inverse_expo(VAR St : STRING); BEGIN END;

function VALEUR(st:STRING):REAL; VAR E: Expression;

   Term: String;
   Result: REal;

BEGIN

 IF (St='')   THEN EXIT;
 Change_carre(St);
 trans_ab(St);
 tout_en_minuscules(St);
 inverse_expo(St);
 Result := E.EvaluateTerm(St);
 VALEUR:=RESULT;

END;

procedure CHAINE_REEL(VAR st:STRING;B:BYTE); VAR n,numero,i:BYTE;

   err: INTEGER;
   S1:STRING;

BEGIN

change_carre(St);
n:=0;NUMERO:=0;
WHILE (n<Length(st)) DO
BEGIN
 WHILE (NOT(yn(stn,ens5))) AND (n<length(st)) DO inc(n);
 IF (yn(stn,ens5)) THEN
 BEGIN
   i:=1;S1:='';
   WHILE (yn(stn,ens5)) AND (n<=length(st)) DO
     BEGIN
       S1:=S1+Stn;
       INC(n);INC(i);
     END;
   INC(NUMERO);
   VAL(s1,paramnumero,B,err);
   DELETE(st,n-i+1,i-1);
   STR(numero,s1);
   INSERT(s1,st,n-i+1);
   {n:=n-i+2}
   n:=n-i+1+length(S1);
 END;
END;

END;

procedure remet_mult(var c:string); var i:byte; begin

  trad_fonc(c);
  i:=1;
  WHILE i<length(c) do
    BEGIN
     if (yn(ci,ens4+')'))
             and (yn(ci+1,ens4+ens0+'(')) then insert('*',c,i+1);
     INC(i);
    END;

end;

procedure entree; VAR a:CHAR;

   i,j,pf0,pf1,kf0:BYTE;
   STR,STR1,old_cf,old_cf1:STRING;

begin

 old_cf:=cf;
 old_cf1:=cf1;
 trans_ab(Cf);
 tout_en_minuscules(Cf);
 a_vers_m(Cf);
 VIDE_BLANC(Cf);
 tout_en_minuscules(Cf1);
 a_vers_m(Cf1);
 VIDE_BLANC(Cf1);
 Chf:=Cf;
 Chf1:=Cf1;
 STR:=Chf;STR1:=Chf1;ERR:=0;
 CHAINE_REEL(Chf,1);
 remet_mult(chf);
 OPPOSE(Chf);
 IF ERR=1 THEN BEGIN Erreur0:=1 ;EXIT; END;
 chf:=chf+'+0©zz';i:=1;j:=1;kf0:=1;pf0:=0;pf1:=0;
while chfi<>'©' do
 begin  a:=chfi;err:=0;
 if (a='^') then pf0:=pf1+3;
 if yn(a,ens0) then pf0:=pf1+2;
 if yn(a,ens1) then pf0:=pf1+1;
 if yn(a,ens2) then pf0:=pf1;
 if yn(a,ens3) then begin sfj:=a;nj:=pf0;j:=j+1 end;
 if (a ='(') then pf1:=pf1+4;
 if (a =')') then pf1:=pf1-4;
 if yn(a,ens4) then begin tfkf0:=a;kf0:=kf0+1 end;
 if yn(a,ens) then i:=i+1 else begin err:=1;chfi:='©' end;
end;
maxs:=j-2;maxt:=kf0-2;Chf:=STR;
IF (PARAM0=2) and (err=0) THEN BEGIN
 CHAINE_REEL(Chf1,2);
 remet_mult(chf1);
 OPPOSE(chf1);
 if yn('x',chf1) then begin err:=1;Erreur0:=1;exit end;
 chf1:=chf1+'+0©zz';i:=1;j:=1;kf0:=1;pf0:=0;pf1:=0;
while chf1i<>'©' do
 begin  a:=chf1i;err:=0;
 if (a='^') then pf0:=pf1+3;
 if yn(a,ens0) then pf0:=pf1+2;
 if yn(a,ens1) then pf0:=pf1+1;
 if yn(a,ens2) then pf0:=pf1;
 if yn(a,ens3) then begin sf1j:=a;n1j:=pf0;j:=j+1 end;
 if (a ='(') then pf1:=pf1+4;
 if (a =')') then pf1:=pf1-4;
 if yn(a,ens4) then begin tf1kf0:=a;kf0:=kf0+1 end;
 if yn(a,ens) then i:=i+1 else begin err:=1;chf1i:='©' end;
end;
maxs1:=j-2;maxt1:=kf0-2;Chf1:=STR1;
                   END;
  if Kf0=1 then err:=1;
If err=1 THEN Erreur0:=1;
cf:=old_cf;
cf1:=old_cf1;

end;

procedure tableaup; VAR i,j,pf0:BYTE; begin

for i:=1 to maxs do  begin  pf0:=i;
                        for j:=1 to i-1 do
                            if (nj>=ni) or yn(sfj,ens0) then pf0:=pf0-1;
                        ppi:=pf0;
                      end;

IF PARAM0=2 THEN

for i:=1 to maxs1 do  begin  pf0:=i;
                        for j:=1 to i-1 do
                            if (n1j>=n1i) or yn(sf1j,ens0) then pf0:=pf0-1;
                        pp1i:=pf0;
                      end;

end;

procedure danslordre; VAR i,b:BYTE;psf:CHAR;ppp:INTEGER; begin b:=1;

while (b=1) and (maxs>1) do
 begin   b:=0;
  for i:=1 to maxs-1 do
    if (ni<ni+1) then
      begin
       psf:=sfi;sfi:=sfi+1;sfi+1:=psf;
       ppp:=ppi;ppi:=ppi+1;ppi+1:=ppp;
       ppp:=ni;ni:=ni+1;ni+1:=ppp;   b:=1;
      end;
 end;
 b:=1;

IF PARAM0=2 THEN

while (b=1) and (maxs1>1) do
 begin   b:=0;
  for i:=1 to maxs1-1 do
    if (n1i<n1i+1) then
      begin
       psf:=sf1i;sf1i:=sf1i+1;sf1i+1:=psf;
       ppp:=pp1i;pp1i:=pp1i+1;pp1i+1:=ppp;
       ppp:=n1i;n1i:=n1i+1;n1i+1:=ppp;   b:=1;
      end;
   end;
end;

procedure tdanstb;

  VAR i:BYTE;
  z,kf0:INTEGER;

begin

err:=0;
for i:=1 to maxt do
                 begin  val(tfi,z,kf0);
                        case tfi of
                          'x':tbi:=xf;
                          't':tbi:=xf;
                          'm':tbi:=mf;
                          'b':tbi:=pf;
                          '0'..'9':tbi:=paramz,1;
                          'p':Tbi:=pi;
                          else err:=1;
                        end;
                 end;

IF PARAM0=2 THEN for i:=1 to maxt1 do

                    begin  val(tf1i,z,kf0);
                           case tf1i of
                              't':tb1i:=xf;
                              'm':tb1i:=mf;
                              'b':tb1i:=pf;
                              '0'..'9':tb1i:=paramz,2;
                              'p':Tb1i:=pi;
                            else err:=1;
                        end;
                 end;

end;

procedure decale; VAR j:BYTE; begin for j:=ppi+1 to maxt-1 do tbj:=tbj+1 end; procedure decal; VAR j:BYTE; begin for j:=pp1i+1 to maxt1-1 do tb1j:=tb1j+1 end;

function EXPO(a:real):REAL; BEGIN IF abs(a)<30 THEN EXPO:=EXP(a) ELSE FLAG:=FALSE; END;

function prod(n,m:real):real; begin if abs(m)+abs(n)<9999999 then prod:=n*m else prod:=9999999; end;

procedure calcul; begin flag:=true;{tb1:=maxy+5;}

for i:=1 to maxs do
 begin
  case sfi of
    '+': begin tbpp[i]:=tbpp[i]+tbpp[i+1];decale; end;
    '-': begin tbpp[i]:=tbpp[i]-tbpp[i+1];decale; end;
    '*': begin tbpp[i]:=prod(tbpp[i],tbpp[i+1]);decale; end;
    '/': begin if Abs(tbpp[i+1])>0.00001 THEN tbpp[i]:=tbpp[i]/tbpp[i+1]
                                           ELSE flag:=false;
               decale; end;
    '^': begin if tbpp[i]>0 then tbpp[i]:=expo(tbpp[i+1]*ln(tbpp[i]))
                              ELSE IF abs(tbpp[i])<0.001 THEN tbpp[i]:=0
                                                  ELSE IF Odd(RAOUND(tbpp[i+1]))
                                                           THEN tbpp[i]:=-expo(tbpp[i+1]*ln(-tbpp[i]))
                                                           ELSE tbpp[i]:=expo(tbpp[i+1]*ln(-tbpp[i]));
               decale;end;
    '´': tbpp[i]:=sin(tbpp[i]);
    'µ': tbpp[i]:=cos(tbpp[i]);
    '¹': tbpp[i]:=expo(tbpp[i]);
    'º': tbpp[i]:=arctan(tbpp[i]);
    '¸': if tbpp[i]>=0 then tbpp[i]:=sqrt(tbpp[i])
                         ELSE flag:=false;
    '¶': tbpp[i]:=abs(tbpp[i]);
    '·': if tbpp[i]>0 then tbpp[i]:=ln(tbpp[i])
                        else FLAG:=FALSE;
   end;
  end;

IF PARAM0=2 THEN

for i:=1 to maxs1 do
 begin
  case sf1i of
    '+': begin tb1pp1[i]:=tb1pp1[i]+tb1pp1[i+1];decal; end;
    '-': begin tb1pp1[i]:=tb1pp1[i]-tb1pp1[i+1];decal; end;
    '*': begin tb1pp1[i]:=prod(tb1pp1[i],tb1pp1[i+1]);decal; end;
    '/': begin if tb1pp1[i+1]<>0 THEN tb1pp1[i]:=tb1pp1[i]/tb1pp1[i+1]
                                 ELSE flag:=false;
               decal; end;
    '^': begin if tb1pp1[i]>0 then tb1pp1[i]:=expo(tb1pp1[i+1]*ln(tb1pp1[i]))
                              ELSE IF tb1pp1[i]=0 THEN tb1pp1[i]:=0
                                                  ELSE IF Odd(RAOUND(tb1pp1[i+1]))
                                                           THEN tb1pp1[i]:=-expo(tb1pp1[i+1]*ln(-tb1pp1[i]))
                                                           ELSE tb1pp1[i]:=expo(tb1pp1[i+1]*ln(-tb1pp1[i]));
               decal;end;
    '´': tb1pp1[i]:=sin(tb1pp1[i]);
    'µ': tb1pp1[i]:=cos(tb1pp1[i]);
    '¹': tb1pp1[i]:=expo(tb1pp1[i]);
    'º': tb1pp1[i]:=arctan(tb1pp1[i]);
    '¸': if tb1pp1[i]>=0 then tb1pp1[i]:=sqrt(tb1pp1[i])
                         ELSE flag:=false;
    '¶': tb1pp1[i]:=abs(tb1pp1[i]);
    '·': if tb1pp1[i]>0 then tb1pp1[i]:=ln(tb1pp1[i])
   else FLAG:=FALSE;
   end;
  end;
  if tb1>99999999 then tb1:=MaxY+5;
end;

procedure TRACE_FONC(DC:HDC;Color:TcolorREf); VAR Tvioc,PAS,MAXI,XX,YY:REAL;PLUS:INTEGER;

         DEP:BOOLEAN;

BEGIN

 IF (uniteX<=2) THEN EXIT;
 ENTREE;DEP:=TRUE;
 tableaup;
 danslordre;mf:=VALEUR(Cstm);pf:=VALEUR(Cstp);
 TVIOC:=VALEUR(MINO);MAXI:=VALEUR(MAXO);
IF PARAM0=2 THEN  {c'est une paramétrée }
 BEGIN
  PAS:=VALEUR(Mon_Pas);
  Xf:=TVIOC;
  WHILE Xf<MAXI DO
   BEGIN
       tdanstb;calcul;
       IF (Flag) THEN
  BEGIN
   XX:=XORIG+tb1*uniteX;
   YY:=YORIG-tb11*uniteY;
   IF (XX<=maxx*rasto) AND (XX>=-5)
      AND (YY<=maxy*rasto) AND (YY>=-5)
      THEN
       BEGIN
 IF DEP THEN BEGIN
    MOVETO(DC,RAOUND(XX),RAOUND(YY));
    SetPixel(DC,RAOUND(XX),RAOUND(YY),color);
    DEP:=FALSE;
         END
        ELSE LINETO(DC,RAOUND(XX),RAOUND(YY));
       END
       ELSE DEP:=TRUE;
   END
ELSE DEP:=TRUE;
Xf:=Xf+PAS;
   END;
 END
 ELSE IF PARAM0=1 THEN   {c'est une cartésienne }
 BEGIN
  Xf0:=Tvioc*UniteX;
  dep:=true;Pas:=VALEUR(Mon_Pas);{IF en_JAUNE THEN pas:=4;}
  WHILE Xf0<maxi*UniteX DO
   BEGIN
     Xf:=xf0/uniteX;
     tdanstb;
     calcul;
     Tb1:=YORIG-UniteY*Tb1;
     IF (Flag) AND (ABS(TVIOC-Tb1)<5*uniteY) THEN
          BEGIN
            IF DEP THEN
               BEGIN
   MOVETO(DC,RAOUND(Xf0+XORIG),RAOUND(tb1));
                 DEP:=FALSE
               END
            ELSE LINETO(DC,RAOUND(Xf0+XORIG),RAOUND(tb1))
           END
           ELSE DEP:=TRUE;
         Xf0:=Xf0+PAS;
         TVIOC:=TB1;
   END;
 END
 ELSE {pour les polaires}
 BEGIN
  PAS:=VALEUR(Mon_Pas);
  Xf:=TVIOC;
  WHILE Xf<MAXI DO
   BEGIN
       tdanstb;calcul;
       IF (Flag) THEN
  BEGIN
   XX:=XORIG+(tb1*cos(Xf))*uniteX;
   YY:=YORIG-(tb1*sin(Xf))*uniteY;
   IF (XX<=maxx*rasto) AND (XX>=-5)
      AND (YY<=maxy*rasto) AND (YY>=-5)
      THEN
       BEGIN
 IF DEP THEN BEGIN
    MOVETO(DC,RAOUND(XX),RAOUND(YY));
    SetPixel(DC,RAOUND(XX),RAOUND(YY),color);
    DEP:=FALSE;
         END
        ELSE LINETO(DC,RAOUND(XX),RAOUND(YY));
       END
       ELSE DEP:=TRUE;
   END
ELSE DEP:=TRUE;
Xf:=Xf+PAS;
   END;
 END;

END;

function Sur_Courbe_P(VAR X,Y:REAL):BOOLEAN; VAR Tvioc,PAS,MAXI :REAL;

   PLUS,XX,YY           :INTEGER;
   OK                   :BOOLEAN;

BEGIN

 PARAM0:=2;
 ENTREE;
 tableaup;
 danslordre;mf:=VALEUR(Cstm);pf:=VALEUR(Cstp);
 TVIOC:=VALEUR(MINO);MAXI:=VALEUR(MAXO);
 PAS:=0.04; { ou bien PAS:=VALEUR(Mon_Pas); plus lent}
 Xf:=TVIOC;
 OK:=FALSE;
  WHILE (Xf<MAXI) AND (NOT(OK)) DO
    BEGIN
      tdanstb;                                 
      calcul;
      IF FLAG THEN
BEGIN
 XX:=XORIG+RAOUND(tb1*uniteX);
 YY:=YORIG-RAOUND(tb11*uniteY);
 IF distance(X-Scroll_X,Y-Scroll_Y,XX,YY)<New_precis THEN OK:=TRUE;
END;
      Xf:=Xf+PAS;
    END;
 Sur_Courbe_P:=OK;
 PARAM0:=1;

END;

function Sur_Courbe_Pol(VAR X,Y:REAL):BOOLEAN; VAR Tvioc,PAS,MAXI :REAL;

   PLUS,XX,YY           :INTEGER;
   OK                   :BOOLEAN;

BEGIN

 PARAM0:=3;
 ENTREE;
 tableaup;
 danslordre;mf:=VALEUR(Cstm);pf:=VALEUR(Cstp);
 TVIOC:=VALEUR(MINO);MAXI:=VALEUR(MAXO);
 PAS:=0.04; 
 Xf:=TVIOC;
 OK:=FALSE;
  WHILE (Xf<MAXI) AND (NOT(OK)) DO
    BEGIN
      tdanstb;                                 
      calcul;
      IF FLAG THEN
BEGIN
 XX:=XORIG+RAOUND(tb1*cos(Xf)*uniteX);
 YY:=YORIG-RAOUND(tb1*sin(Xf)*uniteY);
 IF distance(X-Scroll_X,Y-Scroll_Y,XX,YY)<New_precis THEN OK:=TRUE;
END;
      Xf:=Xf+PAS;
    END;
 Sur_Courbe_POL:=OK;
 PARAM0:=1;

END;

function suis_je_droite(St:String;VAR X,Y:REAL):BOOLEAN; VAR V1_X,V2_X,V1_Y,V2_Y,V3_X,V3_Y:REAL; BEGIN

 suis_je_droite:=FALSE;
 Recupere_Chf1(St);
 ENTREE;
 tableaup;
 danslordre;mf:=VALEUR(Cstm);pf:=VALEUR(Cstp);
 Xf:=X;    tdanstb; calcul; V1_X:=X;   V1_Y:=Tb1 ;
 Xf:=X+5;  tdanstb; calcul; V2_X:=X+5; V2_Y:=Tb1 ;
 Xf:=X+10; tdanstb; calcul; V3_X:=X+10;V3_Y:=Tb1 ;
 V1_X:=V1_X-V2_X;V2_X:=V2_X-V3_X; {abscisses des deux vecteurs}
 V1_Y:=V1_Y-V2_Y;V2_Y:=V2_Y-V3_Y; {ordonnées des deux vecteurs}
 IF (ABS(V1_X*V2_Y-V1_Y*V2_X)<0.01) THEN
   BEGIN X:=V1_X;Y:=V1_Y; suis_je_droite:=TRUE; END;

END;

Procedure Cale_Sur_Courbe(St:String;VAR X,Y:REAL); BEGIN

 Recupere_Chf1(St);
 ENTREE;
 tableaup;
 danslordre;mf:=VALEUR(Cstm);pf:=VALEUR(Cstp);
 Xf:=(X-Xorig-Scroll_X)/UniteX;
 IF (Xf<Valeur(MINO)) THEN BEGIN Xf:=Valeur(MINO);X:=Xf*uniteX+Xorig+Scroll_X END;
 IF (Xf>Valeur(MAXO)) THEN BEGIN Xf:=Valeur(MAXO);X:=Xf*uniteX+Xorig+Scroll_X END;
 tdanstb;
 calcul;
 IF (Flag) AND (Xf<=Valeur(MAXO))
    AND (Xf>=Valeur(MINO))  THEN Y:=YORIG-UniteY*Tb1+Scroll_Y
       ELSE BEGIN X:=VieuxTbX;Y:=VieuxTbY END;
 VieuxTbX:=X;
 VieuxTbY:=Y;

END;

Procedure asymptotes(VAR MINI,MAXI:REAL;Xp:REAL); VAR DEP:BOOLEAN;Yfi:REAL; BEGIN

 tdanstb;calcul;Yfi:=Tb1;
 DEP:=TRUE; {cherchons suivant les asymptotes à déterminer l'intervalle TVIOC;MAXI}
 While (DEP) DO 
 BEGIN
   While (Xf<MAXI) AND (Flag) AND (Abs(Yfi-Tb1)<4) DO
    BEGIN
     Yfi:=Tb1; {on fait la série de calculs pour savoir si asymptotes}
     tdanstb;
     Calcul;
     Xf:=Xf+0.1;
    END;
   Flag:=TRUE; 
   IF Xf>=MAXI THEN Dep:=FALSE
               ELSE IF Xp<Xf THEN BEGIN MAXI:=Xf-0.1;DEP:=FALSE END
                             ELSE BEGIN MINI:=Xf;Yfi:=Tb1 END;
 END;

END;

procedure calculons_Y(St:String;a,b,X:REAL;VAR Y:REAL); BEGIN

 Cf:=St;mf:=a;pf:=b;Xf:=X;
 ENTREE;tableaup;danslordre;tdanstb;calcul; Y:=Tb1;

END;

function IntersC(St1,St2:String;VAR X,Y:REAL):BOOLEAN; VAR V_Cf1,V_Cf2 : String;

   a1,b1,a2,b2 : REAL;
   Min1,Min2,Max1,Max2,minA,maxA :REAL;
   Y1,Y2,V_Y1,V_Y2,delta0,Delta1,Delta2,lePas,precision:REAL;
   div_zero:BOOLEAN;
   N : LongINT;

BEGIN

 LePas:=0.1;
 precision:=0.00001;
 param0:=1;
 IF mesure_precis=2 THEN precision:=precision/100;
 IF mesure_precis=3 THEN precision:=precision/100000;
 Recupere_Chf1(St1);V_Cf1:=Cf;a1:=VALEUR(Cstm);b1:=Valeur(Cstp);Min1:=VALEUR(MINO);Max1:=VALEUR(Maxo);
 {lisons les données des deux équations de courbes st1 et st2}
 Recupere_Chf1(St2);V_Cf2:=Cf;a2:=VALEUR(Cstm);b2:=Valeur(Cstp);Min2:=VALEUR(MINO);Max2:=VALEUR(Maxo);
 {déterminons l'intervalle minimum}
 Min1:=Maximum(Min2,Min1);Max1:=Minimum(Max2,Max1);
 IF min1>max1 THEN BEGIN IntersC:=FALSE; exit END; {pas d'intersection}
 IF X=-Mil THEN X:=Min1 {au premier appel on prend Min1 puis on ne touche plus à X}
           ELSE X:=X+0.15; {on fait avancer x pour ne pas retomber sur la derniere inters}
 Calculons_Y(V_cf1,a1,b1,X,Y1);  {courbe 1,on sort Y1}
 Calculons_Y(V_cf2,a2,b2,X,Y2);  {courbe 2,on sort Y2}
 V_Y1:=Y1;
 V_Y2:=Y2;
 IF FLAG THEN Delta0:=Y2-Y1  {calculons le premier delta et avencons}
         ELSE Delta0:=100;
 Delta1:=Delta0;
 while (Abs(delta0)>precision) AND (X<Max1) DO
  BEGIN
    Delta2:=Delta0;
    While (delta0*delta1>0) AND (X<Max1) DO {si intervalle Y de même signe on avance}
      BEGIN
        X:=X+Lepas;
        Calculons_Y(V_cf1,a1,b1,X,Y1);  {courbe 1,on sort Y1}
        div_zero:=NOT(Flag);
        Calculons_Y(V_cf2,a2,b2,X,Y2);  {courbe 2,on sort Y2}
        IF NOT(div_zero) THEN div_zero:=NOT(Flag);
        IF div_zero then delta0:=100 ELSE Delta0:=Y2-Y1;
        IF (abs(V_y1-y1)>10) OR (Abs(V_y2-y2)>10) OR (Div_zero) THEN  Delta1:=Delta0;
        {on vient de traverser l'asymptote, on ne change pas de sens}
         V_Y1:=Y1;
         V_Y2:=Y2;
      END;
      delta1:=delta0;
    Lepas:=-Lepas/2; {on coupe en deux et repart dans l'autre sens}
  END;
 IF (X<Max1) THEN BEGIN Y:=(Y1+Y2)/2;IntersC:=TRUE END {Nouveau X}
             ELSE IntersC:=FALSE; {on est rendu au bout}

END;

Function nombre_Derive(St:String;VAR X:Real):Real; VAR epsi,Yf,Yfe,Xf0:REAL; BEGIN

 epsi:=0.00001;
 Recupere_Chf1(St);
 ENTREE;
 tableaup;
 danslordre;mf:=VALEUR(Cstm);pf:=VALEUR(Cstp);
 Xf:=(X-Xorig-Scroll_X)/UniteX; 
 IF Xf>Valeur(MAXO) THEN Xf:=Valeur(MAXO)-epsi;
 IF Xf<Valeur(MINO) THEN Xf:=Valeur(MINO)-epsi;
 Xf0:=Xf;
 tdanstb;
 calcul;
 Yf:=Tb1*ratio;
 Xf:=Xf0+epsi;
 tdanstb;
 calcul;
 Yfe:=Tb1*ratio;
 IF (Flag)   THEN Nombre_Derive:=(Yf-Yfe)/Epsi
      ELSE BEGIN Nombre_Derive:=Mil;Xf:=Mil END;
 X:=Xf;

END;

procedure derive(DC:HDC;Color:TcolorREf;St:String); VAR Tvioc,PAS,MAXI,XX,YY:REAL;PLUS:INTEGER;

         DEP:BOOLEAN;
   epsi,Yf,Yfe,Xff0:REAL;

BEGIN

 IF (uniteX<=2) THEN EXIT;
 epsi:=0.00001;
 Recupere_Chf1(St);
 ENTREE;DEP:=TRUE;
 tableaup;
 danslordre;mf:=VALEUR(Cstm);pf:=VALEUR(Cstp);
 TVIOC:=VALEUR(MINO);MAXI:=VALEUR(MAXO);
  Xf0:=Tvioc*UniteX;
  dep:=true;Pas:=VALEUR(Mon_Pas);{IF en_JAUNE THEN pas:=4;}
  WHILE Xf0<maxi*UniteX DO
   BEGIN
     Xf:=xf0/uniteX;Xff0:=Xf;
     tdanstb;
     calcul;
     Yf:=TB1;
     Xf:=Xff0+epsi;tdanstb;calcul;
     Yfe:=TB1;
     TB1:=(Yfe-Yf)/Epsi;
     Tb1:=YORIG-UniteY*Tb1;
     IF (Flag) AND (ABS(TVIOC-Tb1)<5*uniteY) THEN
          BEGIN
            IF DEP THEN
               BEGIN
   MOVETO(DC,RAOUND(Xf0+XORIG),RAOUND(tb1));
                 DEP:=FALSE
               END
            ELSE LINETO(DC,RAOUND(Xf0+XORIG),RAOUND(tb1))
           END
           ELSE DEP:=TRUE;
         Xf0:=Xf0+PAS;
         TVIOC:=TB1;
   END;

END;

function nombre_primitif(X0,X1,n:Real):Real; VAR epsi,Yf,Yfe:Real; BEGIN

     Xf:=X0;Yf:=0;
     epsi:=(X1-X0)/n;{intervalle X0;X1 découpé en n parties}
     tdanstb;calcul;Yfe:=Tb1;{on calcule f(xf)}
     Xf:=Xf+epsi;              {on avance}
     While Abs(Xf+epsi-X1)>0.0001 DO
        BEGIN
         tdanstb; calcul;
         Yf:=Yf+TB1;
         Xf:=Xf+epsi;
        END;{jusqu'au dernier escalier cad Xf=epsi}
     Xf:=X1;tdanstb;calcul;{on calcule f(0)}
     nombre_primitif:=(TB1/2+Yf+yfe/2)*Epsi;{on sort la formule}

END;

function nombre_primaire(St:STRING;VAR X:Real;Xp:Real):REAL; VAR X0,MAXI,Tvioc,Yfi:REAL; DEP:BOOLEAN; BEGIN

 Recupere_Chf1(St);
 ENTREE;
 tableaup;
 danslordre;MAXI:=Valeur(MAXO);TVIOC:=Valeur(MINO);
 Xf:=Tvioc;
 Asymptotes(TVIOC,MAXI,Xp);{on récupère l'intervalle de travail TVIOC;MAXI}
 X0:=(X-Scroll_X-Xorig)/uniteX;
 IF X0<TVIOC THEN X0:=TVIOC;
 IF X0>MAXI  THEN X0:=MAXI;
 nombre_primaire:=nombre_primitif(X0,Xp,100);
 X:=X0;

END;

procedure Trace_primit(DC:HDC;Xdep,Xfin,pas,Xp:REAL); VAR V_Y,Y,Yfi:REAL;

   DEP:BOOLEAN;

BEGIN

 Yfi:=0;DEP:=TRUE; Xf:=Xdep;{yfi pour mémoriser le précedent y}
 V_Y:=YORIG-UniteY*(Yfi-nombre_primitif(Xf,Xp,10));{récupérer le premier V_Y}
 WHILE Xdep<>Xfin+pas DO
   BEGIN
     IF Abs(Xdep-Xfin)<abs(pas) THEN Xdep:=Xfin;
     Xf:=Xdep;{un nb primitif est la somme des précédent (Yfi) plus le sien}
     Y:=Yfi-nombre_primitif(Xf,Xp,10);
     Xp:=Xdep-0.1*pas;Yfi:=Y;{on décale pour l'intervalle suivant}
     Y:=YORIG-UniteY*Y;
     IF (Flag) AND (ABS(V_Y-Y)<2*uniteY) AND (Xdep*UniteX+Xorig<ClientX)
               AND (Xdep*UniteX+Xorig>0) AND (Y<ClientY) AND (Y>0) THEN
          BEGIN
            IF DEP THEN
               BEGIN
   MOVETO(DC,RAOUND(Xdep*UniteX+XORIG),RAOUND(Y));
                 DEP:=FALSE
               END
            ELSE LINETO(DC,RAOUND(Xdep*UniteX+XORIG),RAOUND(Y));
           END
           ELSE DEP:=TRUE;
         Xdep:=Xdep+PAS;
         V_Y:=Y;
   END;

END;

procedure integrale(DC:HDC;Color:TcolorREf;St,Nm:String); VAR Tvioc,PAS,MAXI,Yfi,Xp:REAL;

         PLUS:INTEGER;
         DEP : BOOLEAN;

BEGIN

 IF (uniteX<=2) THEN EXIT;
 Recupere_Chf1(St);
 ENTREE;Xp:=Valeur(Nm);
 tableaup;
 danslordre;mf:=VALEUR(Cstm);pf:=VALEUR(Cstp);
 TVIOC:=VALEUR(MINO);MAXI:=VALEUR(MAXO);
 Xf:=TVIOC;tdanstb;calcul;Yfi:=Tb1;
 Asymptotes(TVIOC,MAXI,Xp);{on récupère l'intervalle de travail TVIOC;MAXI}
 Pas:=-VALEUR(Mon_Pas)/UniteX;
 IF xp>Tvioc THEN Trace_primit(DC,Xp,Tvioc,pas,Xp); {on trace de min à Xprimitive }
  Pas:=VALEUR(Mon_Pas)/UniteX;
 IF Xp<=maxi THEN Trace_primit(DC,Xp,maxi,pas,Xp);{puis de xprimitive à max}

END;

function Sur_Courbe_F(VAR X,Y:REAL):BOOLEAN; VAR Xmin,Xmax:REAL; BEGIN

 ENTREE;
 tableaup;
 danslordre;mf:=VALEUR(Cstm);pf:=VALEUR(Cstp);
 Xf:=(X-Xorig-Scroll_X)/UniteX;
 tdanstb;
 calcul;
 Tb1:=YORIG-UniteY*Tb1;
 Xmin:=Valeur(Mino)*uniteX+Xorig+Scroll_X;
 Xmax:=Valeur(Maxo)*uniteX+Xorig+Scroll_X;
 IF (Flag) AND (X>=Xmin) AND (X<=Xmax) AND (ABS(Tb1-Y+Scroll_Y)<New_precis+4) THEN
  BEGIN
    Sur_Courbe_F:=TRUE;
    Y:=ROUND(Tb1)+Scroll_Y;
    {X:=X+Scroll_X;}
  END
                ELSE Sur_Courbe_F:=FALSE;

END;

procedure Recupere_POs(N:INTEGER); BEGIN

IF N>=100 THEN N:=N-100; {cas des points effaces}
IF N>=50  THEN N:=N-50;  {pour éclairer les objets effacés quand même}
Pos_Y:=(N MOD 10)-1 ; Pos_X:=(N DIV 10)-1

END;

procedure Recupere_Chf1(St:STRING); VAR I:INTEGER; BEGIN

I:=1;   cf:='';
While Sti<>'#' do BEGIN Cf:=Cf+Sti;inc(i) END;
INC(i);   cf1:='';
While Sti<>'#' do BEGIN Cf1:=Cf1+Sti;inc(i) END;
INC(i); CsTm:='';
While Sti<>'#' do BEGIN CStm:=Cstm+Sti;inc(i) END;
INC(i); Cstp:='';
While Sti<>'#' do BEGIN Cstp:=Cstp+Sti;inc(i) END;
INC(i); Mino:='';
While Sti<>'#' do BEGIN Mino:=Mino+Sti;inc(i) END;
INC(i); Maxo:='';
While Sti<>'#' do BEGIN Maxo:=Maxo+Sti;inc(i) END;
INC(i); Mon_Pas:='';
While Sti<>'#' do BEGIN Mon_Pas:=Mon_Pas+Sti;inc(i) END;

END;

function nouveau_nom(st1,st2:string):String; VAR k:BYTE; BEGIN

while pos('x',st1)<>0 do
 BEGIN
  k:=pos('x',st1);delete(St1,k,1);
  insert('¥',st1,k);
 END;
while pos('¥',st1)<>0 do
 BEGIN
  k:=pos('¥',st1);delete(St1,k,1);
  insert(st2,st1,k);
 END;

nouveau_nom:=St1; END;

function Cette_Courbe(St:STRING;VAR X,Y:REAL;An:INTEGER):BOOLEAN; BEGIN

Recupere_Chf1(St);
IF An=1 THEN Cette_Courbe:=Sur_courbe_F(X,Y)
        ELSE IF An=2 THEN Cette_Courbe:=Sur_Courbe_P(X,Y)
                     ELSE Cette_Courbe:=Sur_Courbe_Pol(X,Y);

END;

procedure Rempli_Buff_Affine; BEGIN

 m_VErs_a(cf);STRpCopy(T_F.E_f,Cf);
 STRpCopy(T_F.E_a,Cstm);
 STRpCopy(T_F.E_b,Cstp);
 STRpCopy(T_F.E_mi,Mino);
 STRpCopy(T_F.E_ma,Maxo);
 STRpCopy(T_F.E_pas,Mon_pas);

END;

procedure Rempli_Buff_macro(Ny:BYTE); VAR st1,st2:STRING; BEGIN

 IF ny=1 THEN BEGIN STRCopy(T_macro.E_name,Nmacro1);StrCopy(T_macro.E_file,nom_macro1) END;
 IF ny=2 THEN BEGIN STRCopy(T_macro.E_name,Nmacro2);StrCopy(T_macro.E_file,nom_macro2) END;
 IF ny=3 THEN BEGIN STRCopy(T_macro.E_name,Nmacro3);StrCopy(T_macro.E_file,nom_macro3) END;

END;

procedure Rempli_Buff_Polaire; BEGIN

 m_VErs_a(cf);STRpCopy(T_Pol.E_f,Cf);
 STRpCopy(T_Pol.E_a,Cstm);
 STRpCopy(T_Pol.E_b,Cstp);
 STRpCopy(T_Pol.E_mi,Mino);
 STRpCopy(T_Pol.E_ma,Maxo);
 STRpCopy(T_Pol.E_pas,Mon_pas);

END;

procedure Rempli_Buff_Param; BEGIN

 m_Vers_a(Cf) ; STRpCopy(T_M.E_x,Cf);
 m_Vers_a(cf1); STRpCopy(T_M.E_y,Cf1);
 STRpCopy(T_M.E_a,Cstm);
 STRpCopy(T_M.E_b,Cstp);
 STRpCopy(T_M.E_mi,Mino);
 STRpCopy(T_M.E_ma,Maxo);
 STRpCopy(T_M.E_pas,Mon_pas);

END;

procedure Ajoute_St(St:STRING;n:INTEGER); VAR Texte0:ChaineL; BEGIN

IF n=1 THEN StrCopy(T_Txth.texte1,'');
init_Texte(Texte0);
StrPCopy(Texte0,St);
IF (strlen(T_Txth.texte1)+length(St))<4998 THEN
   BEGIN
     StrCat(T_Txth.texte1,Texte0);
     StrCat(T_Txth.Texte1,#13);
     StrCat(T_Txth.texte1,#10);
   END;

END;

procedure Imprime_histo; VAR n,k:INTEGER;

   St:STRING;
   Sth:ARRAY0..255 OF CHAR;

BEGIN

IF PrnStart('Geom') THEN
 BEGIN
  n:=0;
  While T_Txth.Texte1n<>#0 DO
   BEGIN
     Sth0:=#0;
     St:='';
     While (T_Txth.Texte1n<>#10) AND (T_Txth.Texte1n<>#0) DO
BEGIN St:=St+T_Txth.Texte1n; INC(n); END;
     k:=pos(#10,st);IF K>0 THEN Delete(St,k,1);
     k:=pos(#13,st);IF K>0 THEN Delete(St,k,1);
     StrPcopy(Sth,St);
     PrnLine(Sth);
     INC(n);
   END;
  PrnStop;
 END;

END;

procedure Histo_edit; var

 Text1: PEdit;
 Dialog: dialogH;

begin

 remet_capture;
 Imprim_histo:=2;
 dialog:=New(dialogH,init(Par,'DIAL_HISTO'));
 New(Text1,InitResource(Dialog, id_texte1, 5000));
 Dialog^.TransferBuffer := @T_Txth;
 Application^.ExecDialog(Dialog);
 IF Imprim_histo=1 THEN imprime_histo;
 T_Txth.texte10:=#0;

end;

function Editor:BOOLEAN; var

 Text1: PEdit;
 Dialog: dialogT;
 Sortie : INTEGER;
 TexteM : ChaineL;

begin

Repeat
 Sortie_menu:=0;
 Init_Texte(TexteM);
 StrCopy(TExteM,T_Txt.Texte1);
 dialog:=New(dialogT,init(Par,'DIAL_TEXTES'));
 New(Text1,InitResource(Dialog, id_texte1, 400));
 Dialog^.TransferBuffer := @T_Txt;
 Sortie:=Application^.ExecDialog(Dialog);
 IF Sortie=Id_OK THEN
 BEGIN
  StrCopy(TEXTEA,T_Txt.Texte1);
  editor:=TRUE;
 END;
 IF Sortie=Id_annule THEN
 BEGIN
  StrCopy(TEXTEA,TexteM);
  editor:=FALSE;
 END;
UNTIL (Sortie=Id_OK) OR (Sortie=Id_Annule);

end;

procedure Quelle_Fn_Affine; var

 F,fa,fb,fmi,fma,fpas: PEdit;
 Dialog: Pdialog;
 Sortie,i : INTEGER;

begin

PARAM0:=1; {c'est une affine}
V_Cf1:='';
Repeat
 Erreur0:=0;
 dialog:=New(Pdialog,init(Par,'DIAL_AFF'));
 New(F,InitResource(Dialog, id_Affine, 81));
 New(Fa,InitResource(Dialog, id_a, 13));
 New(Fb,InitResource(Dialog, id_b, 13));
 New(Fmi,InitResource(Dialog, id_minx, 13));
 New(Fma,InitResource(Dialog, id_miny, 13));
 New(Fpas,InitResource(Dialog, id_pas, 13));
 Dialog^.TransferBuffer := @T_f;
 Sortie:=Application^.ExecDialog(Dialog);
 IF Sortie=Id_OK THEN
 BEGIN
  Cf :=StrPas(T_f.E_f);
  Cstm:=StrPas(T_f.E_a);
  Cstp:=StrPas(T_f.E_b);
  Mino:=StrPas(T_f.E_mi);
  Maxo:=StrPas(T_f.E_ma);
  Mon_Pas:=StrPas(T_f.E_pas);
  IF Cf<>'' THEN ENTREE;
  Chf:=Cf+'#'+Cf1+'#'+Cstm+'#'+Cstp+'#'+mino+'#'+maxo+'#'+Mon_Pas+'#';
  V_Cf:=Cf; V_Cstm:=Cstm; V_Cstp:=Cstp;
  V_Chf:=Chf;
 END;
UNTIL 
      OR (Sortie=Id_Annule);
IF Sortie=Id_Ok THEN
BEGIN  A_Fonc:=Fonc; Fonc:=Courbe_Aff; END;

end;

function Supprime_ton:BOOLEAN; VAR Dialog : Pdialog;

    NN :INTEGER;
    Old_DC:HDC;

BEGIN

 old_DC:=MonDC;
 Remet_Capture;
 dialog:=New(Pdialog,init(Par,'DIAL_Supp'));
 NN:=Application^.ExecDialog(Dialog);
 IF NN=Id_OK THEN Supprime_ton:=TRUE
      ELSE Supprime_ton:=FALSE;
 MonDc:=Old_DC;

END;

procedure Quelle_macro(n:BYTE); var

 f_name,f_file : PEdit;
 Dialog  : Pdialog;
 Sortie  : INTEGER;

begin

rempli_buff_macro(n);
Repeat
 dialog:=New(Pdialog,init(Par,'DIAL_MACRO'));
 New(F_file,InitResource(Dialog, 789, 200+1));
 New(F_name,InitResource(Dialog, 790, 15));
 Dialog^.TransferBuffer := @T_Macro;
 Sortie:=Application^.ExecDialog(Dialog);
 IF Sortie=Id_OK THEN
 BEGIN
  IF n=1 THEN BEGIN StrCopy(Nmacro1,T_macro.E_name); StrCopy(Nom_macro1,T_macro.E_file); END;
  IF n=2 THEN BEGIN StrCopy(Nmacro2,T_macro.E_name); StrCopy(Nom_macro2,T_macro.E_file); END;
  IF n=3 THEN BEGIN StrCopy(Nmacro3,T_macro.E_name); StrCopy(Nom_macro3,T_macro.E_file); END;
 END;
UNTIL  (Sortie=Id_Ok) OR (Sortie=Id_Annule);

end;

procedure decompose_nom(Nm : STRING); VAR St : STRING;

   k : INTEGER;

BEGIN

St_MonX:='';
k:=pos('£',Nm);
IF k>0 THEN {ne décompose que les noms qui en ont besoin : les points_X_Y }
 BEGIN 
   IF K>0 THEN St_Nom:=Copy(Nm,1,k-1) ELSE St_Nom:='';
   IF K>0 THEN DELETE(Nm,1,k);
   k:=pos('£',Nm);
   IF K>0 THEN St_MonX:=Copy(Nm,1,k-1) ELSE St_MonX:='';
   IF K>0 THEN DELETE(Nm,1,k);
   k:=pos('£',Nm);
   IF K>0 THEN St_MonY:=Copy(Nm,1,k-1) ELSE St_MonY:='';
   IF K>0 THEN DELETE(Nm,1,k);
   k:=pos('£',Nm);
   IF K>0 THEN St_MonZ:=Copy(Nm,1,k-1) ELSE St_MonZ:='';
 END
ELSE St_Nom:=Nm;

END;

procedure fait_nom(VAR Nm : STRING); BEGIN

IF St_MonX<>'' THEN Nm:=Nm+'£'+St_MonX+'£'+St_MonY+'£'+St_MonZ;

END;

procedure Extrait(Nm : STRING; VAR X,Y : REAL); VAR St,St0 : STRING;

   k: INTEGER;

BEGIN

St0:=Nm;
k:=pos('£',st0);
IF K>0 THEN DELETE(St0,1,k); {virer le nom au début}
St:='';k:=1;
WHILE (St0k<>'£') AND (k<length(St0)) DO BEGIN St:=St+St0k; INC(k) END;
X:=VALEUR(St)*uniteX+Xorig+Scroll_X; DELETE(St0,1,k);
St:='';k:=1;
WHILE (St0k<>'£') AND (k<length(St0)) DO BEGIN St:=St+St0k; INC(k) END;
Y:=-VALEUR(St)*uniteY+Yorig+Scroll_Y; DELETE(St0,1,k);

END;

procedure Quelle_XY(n:BYTE); var

 fmi,fma,fmb : PEdit;
 Dialog  : Pdialog;
 Sortie  : INTEGER;
 err     : REAL;
 St: STRING;

begin

IF n=30 THEN
 BEGIN
   Str(MonX:0:3,St);StrPcopy(T_XYZ.E_X,St);
   Str(MonY:0:3,St);StrPcopy(T_XYZ.E_Y,St);
   Str(MonZ:0:3,St);StrPcopy(T_XYZ.E_Z,St);
 END
ELSE {coordonnes classiques}
 BEGIN
  StrPcopy(T_XYZ.E_X,St_MonX);
  StrPcopy(T_XYZ.E_Y,St_MonY);
  StrPcopy(T_XYZ.E_Z,St_MonZ);
 END;
Repeat
 Erreur0:=0;
 IF n=1 THEN dialog:=New(Pdialog,init(Par,'DIAL_XY'));
 IF n=rectang   THEN dialog:=New(Pdialog,init(Par,'DIAL_RECT'));
 IF n=TriangleR THEN dialog:=New(Pdialog,init(Par,'DIAL_PYTA'));
 IF n=losange   THEN dialog:=New(Pdialog,init(Par,'DIAL_LOSA'));
 IF n=TriangleI THEN dialog:=New(Pdialog,init(Par,'DIAL_ISOC'));
 IF n=parallelo THEN dialog:=New(Pdialog,init(Par,'DIAL_PARA'));
 New(Fmi,InitResource(Dialog, id_x, 33));
 New(Fma,InitResource(Dialog, id_y, 33));
 IF n=parallelo THEN New(Fmb,InitResource(Dialog, id_z, 33));
 Dialog^.TransferBuffer := @T_XYZ; {longueur, largeur, angle}
 Sortie:=Application^.ExecDialog(Dialog);
 IF Sortie=Id_OK THEN
 BEGIN
   Chf1:=StrPas(T_XYZ.E_X)+'£'+StrPas(T_XYZ.E_Y)+'£'+StrPas(T_XYZ.E_Z);
   MonX:=VALEUR(StrPas(T_XYZ.E_X));IF (monx<0) AND (n<>1) THEN Sortie:=12;
   MonY:=VALEUR(StrPas(T_XYZ.E_Y));IF (mony<0) AND (n<>1) THEN Sortie:=12;
   MonZ:=VALEUR(StrPas(T_XYz.E_Z));{IF monz<0 THEN Sortie:=12;}
 END ELSE Chf1:='';
UNTIL  (Sortie=Id_Ok) OR (Sortie=Id_Annule);
IF Sortie=Id_Ok THEN MonEsc:=FALSE
  ELSE MonEsc:=TRUE;

end;

procedure Dialogue_imprime; var

 Dialog  : dialogI;
 Sortie  : INTEGER;
 err     : REAL;
 St: STRING;

begin

 Str(MonX:0:0,St);
 St:=St+'%';
 StrPcopy(T_XYZ.E_X,St);
 imp_fond:=FALSE;
 cadre_page:=10;
Repeat
 dialog:=New(dialogI,init(Par,'DIAL_IMPRIME'));
 New(Dialog^.Fmi,InitResource(Dialog, id_x, 13));
 Dialog^.TransferBuffer := @T_XYZ; {longueur, largeur, angle}
 Sortie:=Application^.ExecDialog(Dialog);
UNTIL  (Sortie=Id_Ok);

end; procedure Dialogue_presente(k:INTEGER); var

  Gwnd: Pwindow;
  Temps0 : longINT;
  {File_image: array0..fsPathName of Char;}

begin

 StRootCopy(File_image,'\Geom96.bmp');
 LoadBit(File_image);
IF Himage>0 THEN
BEGIN
 Temps0:=GetTickCount+k*400;
 GWnd := New(PEWindow, Init(Nil,'',0,0));
 Application^.MakeWindow(GWnd);
 updateWindow(WindO);
 While GettickCount<Temps0 Do;
 GWnd^.done;
END;
 filenamebit0:=#0;
 Himage:=0;

end;

procedure Quelle_Fn_Param; var

 Fx,Fy,fa,fb,fmi,fma,fpas: PEdit;
 Dialog: Pdialog;
 Sortie :INTEGER;

begin

PARAM0:=2; {c'est une parametree}
Repeat
 Erreur0:=0;
 dialog:=New(Pdialog,init(Par,'DIAL_PARAM'));
 New(Fx,InitResource(Dialog, id_ParamX, 41));
 New(Fy,InitResource(Dialog, id_ParamY, 41));
 New(Fa,InitResource(Dialog, id_a, 13));
 New(Fb,InitResource(Dialog, id_b, 13));
 New(Fmi,InitResource(Dialog, id_mint, 13));
 New(Fma,InitResource(Dialog, id_maxt, 13));
 New(Fpas,InitResource(Dialog, id_pas, 13));
 Dialog^.TransferBuffer := @T_M;
 SORTIE:=Application^.ExecDialog(Dialog);
 IF Sortie=Id_Ok THEN
 BEGIN
  Cf  :=StrPas(T_M.E_x);
  Cf1 :=StrPas(T_M.E_y);
  Cstm:=StrPas(T_M.E_a);
  Cstp:=StrPas(T_M.E_b);
  Mino:=StrPas(T_M.E_mi);
  Maxo:=StrPas(T_M.E_ma);
  Mon_pas:=StrPas(T_M.E_pas);
  IF (Cf<>) AND (cf1<>)  THEN ENTREE;
  Chf:=Cf+'#'+cf1+'#'+Cstm+'#'+Cstp+'#'+Mino+'#'+maxo+'#'+mon_pas+'#';
  V_Cf:=Cf;V_Cf1:=cf1;V_Cstm:=Cstm;V_Cstp:=Cstp;
  V_Chf:=Chf;
 END;
UNTIL ((V_Cf<>) AND (V_cf1<>)
                AND (Erreur0<>1) AND (Valeur(Mon_Pas)>0))
                        OR (Sortie=Id_Annule);
IF Sortie=Id_Ok THEN
   BEGIN  A_Fonc:=Fonc; Fonc:=Courbe_Aff; END;

end; procedure Quelle_Fn_Polaire; var

 F,fa,fb,fmi,fma,fpas: PEdit;
 Dialog: Pdialog;
 Sortie,i : INTEGER;

begin

PARAM0:=3; {ce n'est pas une affine}
Repeat
 Erreur0:=0;
 dialog:=New(Pdialog,init(Par,'DIAL_POL'));
 New(F,InitResource(Dialog, id_affine,81));
 New(Fa,InitResource(Dialog, id_a, 13));
 New(Fb,InitResource(Dialog, id_b, 13));
 New(Fmi,InitResource(Dialog, id_minx, 13));
 New(Fma,InitResource(Dialog, id_miny, 13));
 New(Fpas,InitResource(Dialog, id_pas, 13));
 Dialog^.TransferBuffer := @T_Pol;
 Sortie:=Application^.ExecDialog(Dialog);
 IF Sortie=Id_OK THEN
 BEGIN
  Cf  :=StrPas(T_Pol.E_f);
  Cf1 :='';
  Cstm:=StrPas(T_Pol.E_a);
  Cstp:=StrPas(T_Pol.E_b);
  Mino:=StrPas(T_Pol.E_mi);
  Maxo:=StrPas(T_Pol.E_ma);
  Mon_pas:=StrPas(T_Pol.E_pas);
  IF (Cf<>'')  THEN ENTREE;
  Chf:=Cf+'#'+Cf1+'#'+Cstm+'#'+Cstp+'#'+Mino+'#'+maxo+'#'+mon_pas+'#';
  V_Cf:=Cf;V_Cstm:=Cstm;V_Cstp:=Cstp;
  V_Chf:=Chf;
 END;
UNTIL 
      OR (Sortie=Id_Annule);
IF Sortie=Id_Ok THEN
BEGIN  A_Fonc:=Fonc; Fonc:=Courbe_Aff; END;

end;

END.

Ajouter un commentaire

Le code HTML est affiché comme du texte et les adresses web sont automatiquement transformées.

La discussion continue ailleurs

URL de rétrolien : http://lepinejean.livehost.fr/index.php?trackback/4

Fil des commentaires de ce billet

Page top