Aller à la recherche

samedi 9 septembre 2017 09:52

Programmation récursive

Quand on parle de la programmation en Pascal on parle de programmation structurée. Une programmation qui fonction avec des objets et des variables pré-déclarée. Il est clair que le langage pascal est tout à fait idéal pour une travail en équipé avec des petits modules qui sont programmés par différents développeurs et qui doivent être assemblés pour fonctionner ensemble. C'est une programmation exigent mais qui a le grand mérite de générer des programmes très faciles à modifier et non pas des usine à gaz dans lesquels la moindre modification risque de tout planter.
Mais il existe d'autres langages qui sont dédiés à la programmation récursive et c'est la cas par exemple de la tortue logo qui a été utilisée dans les classes de primaire part toute une génération d'élèves qui se sont appliqués à bien écrire des programmes du genre repete 6 {av 100 td 144} . C'est tout à fait étonnant car cette tortue logo qui se promenait sur le sol de la classe en dessinant des carrés ou des étoiles est remplacée par de petits aspirateurs robots qui font le nettoyage de la salle en appliquant aussi un langage tout à fait récursif !
Un parallélisme très sympathique qui permet à la génération des élèves de la tortue logo de s'équiper d'aspirateur robot !
e.ziclean_tornade_pets_v2_-_vue_dessus.jpg Ci-dessus en photo un aspirateur robot pas trop cher qui fonctionne de façon très autonome suivant un langage récursif tout à fait optimisé.

Traceur de courbes

Ci-dessous le code source d'une fonction de traceur de courbe issue de l'atelier de géométrie qui se trouve être désormais en licence libre. Cette fonction a été développée sous TPW15 mais peut être facilement adaptée pour être utilisée en pascal voire en C. On verra par exemple la procédure fonction qui est la fonction principale de cette unité ainsi que son algorithme de départ. Ce genre d'unité peut être modifiée et recompilée avec la plateforme delphi. Il faut considérer que le langage pascal n'est pas du tout un langage récursif à la base et cependant a été utilisé dans la programmation des tous premiers robots domestiques .

Le développement réel d'une application demande deux choses très précises : 

1* Un algorithme très précis 

2* l'assemblage d'unités pour la réalisation du programme final

D'autres éléments de programations sur le site des ordinateurs ...

Cet assemblage est important et il faut que les unités soient parfaitement bien définies au départ pour pouvoir s'assembler comme des petites briques de légo quoi ! On dit que les entrées et les sorties sont parfaitement respectées pour l’emboîtement final.

Quand à l'algorithme de base il peut être fait d'un seul bloc mais aussi de petites unités comme le programme lui-même. Un des algorithmes les plus complexes et les plus aboutis du moment est certainement celui qu'utilise google pour classer les sites. En fait celui qui va valoriser ou pénaliser le référencement de votre site. On peut imaginer qu'un tel algorithme doit être constitué d'un ensemble de modules assez complexes et assez impressionnants. Avec un module qui va évaluer le contenu de votre site et son autorité, un autre qui va évaluer les liens organiques vers votre site etc. Un bel algorithme et sans doute un modèle du genre.

Ci-dessous l'unité du fonctions de ce programme. Les variables, comme toujours en pascal sont déclarées en début d'unité et permettent donc un emboîtement plus facile à réaliser.

Unit fonctions;

(*$DEFINE VERSION_FR*)

interface uses Strings,WinTypes, WinDos, WinProcs, WObjects,

           StdDlgs,V_courbe,outils2,TypKonst,outils1,server;

type

 PHWindow = ^THWindow;
 THWindow = object(TWindow)
   premier : BOOLEAN;
   constructor Init(AParent: PWindowsObject; ATitle: PChar;X0,Y0:INTEGER);
   Destructor  Done; Virtual;
   procedure Horloge(var Msg: TMessage); virtual wm_First + wm_Timer;
   procedure ToucheUp(VAR Msg:Tmessage);virtual Wm_first+Wm_KeyUp;
   procedure SetUpWindow; Virtual;

END;

type

 POWindow = ^TOWindow; {pour faire une fenêtre d'outils}
 TOWindow = object(TWindow)
   constructor Init(AParent: PWindowsObject; ATitle: PChar;X0,Y0:INTEGER);
   Destructor  Done; Virtual;
   procedure WMLButtonDown(var Msg: TMessage); virtual wm_First + wm_LButtonDown;
   procedure SetUpWindow; Virtual;

END;

VAR magneto,comptor,memo_comptor,n_fois,Xoutil,Youtil: INTEGER;

   flag_trace,flag_bouge,flag_deplace,flag_lettres,flag_XOR:BOOLEAN;

procedure Kase_Fonc(Marquable:BOOLEAN;DC:HDC); procedure Trace_Sauve_Pt(DC:HDC;x,y:REAL;Teta,E,Fnc:INTEGER;C:TcolorRef;Mark,Mk:INTEGER); procedure Sauve_Figure(P1,P2,P3,Teta,G,Mk:INTEGER;Mass:REAL); procedure Sauve_Vector(P1,P2,Teta,G:INTEGER;Mass:REAL;Epaisseur:INTEGER); procedure cherche(Pt,A:BYTE); function Segment_Marque:INTEGER; function Cherche_Segment(No,Ni:REAL):INTEGER; function Cherche_Aire(Index:REAL):BOOLEAN; function Aumoins_Unlieu(VAR Depuis:INTEGER):BOOLEAN; function Collage(x,y:INTEGER):BOOLEAN; procedure faire_le_script; procedure Recale_OLE(No:INTEGER); procedure Change_Couleur(DC:HDC); Procedure Vire_Bloc(DC:HDC); function corrige_quadri(VAR n:INTEGER;Force:BOOLEAN):BOOLEAN; function Objet_lie(N:INTEGER):INTEGER; function nombre_dobjets:INTEGER; procedure Reqtangle(Dc:HDC;X1,Y1,X2,Y2,Gr,P,E:INTEGER;pt1:REAL); Function eclaire_bloc(Num:INTEGER):BOOLEAN; procedure transforme(VAR Stn : STRING; r1 : REAL); {--}

    implementation

{--} uses geom_app,globales; {--}

procedure transforme(VAR Stn : STRING; r1 : REAL); VAR pg : PDgraph;

   st0,st1 : STRING;
   k0,k,compt,err : INTEGER;
   Tk : ARRAY1..5 OF INTEGER;
   rx,ry,rk : REAL;
   r2 : longint;

BEGIN {pour modifier l'equation d'une courbe par translation}

  r2:=round(r1);
  k := r2 DIV 1000;
  Pg :=points^.at(k); Stn:=Pg^.nm;
  k:=  r2 MOD 1000;
  k0:=pos('#',Stn); Pg:=Points^.at(k);
  IF (V_collect) THEN ry:=-pg^.No_2^.v_y/uniteY ELSE ry:=-pg^.No_2^.y/uniteY;
  str(ry:4:2,St0);IF St01<>'-' THEN St0:='+'+St0;
  INSERT(St0,StN,k0);
  IF (V_collect) THEN rx:=-pg^.No_2^.v_X/uniteX ELSE rx:=-pg^.No_2^.X/uniteX;
  str(rx:4:2,St0);IF St01<>'-' THEN St0:='+'+St0;
  st0:='(x'+st0+')';
  k:=length(Stn);
  While k>0 do
    BEGIN
     IF Stnk='x' THEN
      BEGIN
       delete(Stn,k,1);
       INSERT(St0,Stn,k);
      END;
     DEC(k);
    END;
 k:=length(Stn)-1;compt:=0;
  While k>0 do
    BEGIN
     IF Stnk='#' THEN
     BEGIN
     INC(compt);tkcompt:=k; 
     IF (compt=2) OR (compt=3) THEN
      BEGIN
       St0:=Copy(Stn,k+1,tkcompt-1-k-1);
       rk:=VALEUR(St0);
       rk:=rk-rx;
       Str(rk:4:2,St0);
       delete(Stn,k+1,tkcompt-1-k-1);
       INSERT(St0,Stn,k+1);
      END;
     END;
     DEC(k);
    END;

END;

Function Suis_je_descendant(fils,pere:INTEGER):BOOLEAN; BEGIN

 pg:=Nil;
 ptequa:=Nil;
 ptequa:=points^.at(pere);
 pg    :=points^.at(fils);
 Whilepg^.pt1<>-1DOBEGINfils:=fils-1;pg:=points^.at(fils); END;
 fils:=fils+1;{début de bloc +1}
 pg:=points^.at(fils);
 While (pg^.pt1<>pere) AND (pg^.pt2<>pere) AND (pg^.pt1<>-1)
                       AND (fils<points^.count-1) DO
 BEGIN fils:=fils+1; pg:=points^.at(fils); END;
 IF (pg^.pt1=-1) OR (fils=points^.count-1) THEN suis_je_descendant:=FALSE
        ELSE suis_je_descendant:=TRUE;

END;

procedure Met_objet_jaune(Num:INTEGER); BEGIN

pg:=Nil;pg:=points^.at(num);
 Whilepg^.pt1<>-1DOBEGINnum:=num-1;pg:=points^.at(num); END;
num:=num+1;pg:=Points^.at(Num);
 While (pg^.pt1<>-1) AND (num<points^.count) DO
   BEGIN
     pg:=points^.at(num);
     IF pg^.mark<100 THEN pg^.mark:=pg^.mark+100;
     IF Pg^.pos>=100 THEN Pg^.pos:=Pg^.pos-50;
     num:=num+1;
   END;

END;

function eclaire_blok(Num:INTEGER):BYTE; VAR N:INTEGER;

   combien:BYTE;

BEGIN

pg:=Nil;combien:=0;
 Met_objet_Jaune(Num); 
 FOR N:=num TO points^.count-1 DO
  BEGIN
    pg:=points^.at(N);
    IF (pg^.pt1>0)  THEN
      IF suis_je_descendant(N,Num) THEN BEGIN Met_objet_Jaune(N);INC(combien) END;
  END;
  eclaire_blok:=Combien;

END;

function eclaire_blok0:BOOLEAN; VAR N :INTEGER;

  pg0,pg1,pg2:PDpoint;<br>BEGIN<BR> eclaire_blok0:=FALSE;<BR> pg0:=Nil;pg1:=Nil;pg2:=Nil;
 FOR N:=7 TO points^.count-1 DO
  BEGIN
   pg0:=points^.at(N);
   IF )
                   AND (pg0^.pt1<>-1) AND (pg0^.mark<100) THEN
     BEGIN
      pg1:=points^.at(Round(pg0^.pt1));
      IF pg1^.mark>=100 THEN BEGIN Met_objet_jaune(N);Eclaire_Blok0:=TRUE END;
      pg1:=points^.at(Round(pg0^.pt2));
      IF pg1^.mark>=100 THEN BEGIN Met_objet_jaune(N);Eclaire_Blok0:=TRUE END;
     END;
  END;
  FOR N:=7 TO points^.count-1 DO {points liés aux objets jaunes}
      BEGIN
         pg0:=Points^.At(N);
    IF (pg0^.Gr=Point_M)  AND (pg0^.mark<100)
     THEN
              BEGIN
 pg1:=Points^.at(Round(pg0^.pt1)); {sur quelle droite est le point}
 IF pg1^.mark>=100 THEN BEGIN Met_objet_jaune(N);Eclaire_Blok0:=TRUE END;
 IF Pg0^.P=3 THEN  {ou sur quellessss droitesss}
                 BEGIN
     pg1:=Points^.at(Round(pg0^.pt2));
     IF pg1^.mark>=100 THEN BEGIN Met_objet_jaune(N);Eclaire_Blok0:=TRUE END;
   END;
      END;
     IF (pg0^.gr=Barycentre) AND (pg0^.mark<100) THEN
       BEGIN
  pg1:=points^.at(Round(pg0^.pt1));{premier vecteur du barycentre}
  pg2:=points^.at(Round(pg1^.pt1));
  IF pg2^.mark>=100 THEN BEGIN Met_objet_Jaune(N);Eclaire_Blok0:=TRUE END;  
  pg2:=points^.at(Round(pg1^.pt2));
  IF pg2^.mark>=100 THEN BEGIN Met_objet_Jaune(N);Eclaire_Blok0:=TRUE END;  
  pg2:=points^.at(Round(pg1^.pt3));
  IF pg2^.mark>=100 THEN BEGIN Met_objet_Jaune(N);Eclaire_Blok0:=TRUE END;
   pg1:=points^.at(Round(pg0^.pt2));{second vecteur du barycentre}
  pg2:=points^.at(Round(pg1^.pt1));
  IF pg2^.mark>=100 THEN BEGIN Met_objet_Jaune(N);Eclaire_Blok0:=TRUE END;  
  pg2:=points^.at(Round(pg1^.pt2));
  IF pg2^.mark>=100 THEN BEGIN Met_objet_Jaune(N);Eclaire_Blok0:=TRUE END;  
       END;
      END;

END;

function eclaire_bloc(Num:INTEGER):BOOLEAN; Var N:BYTE;

  VAR pg1,pg0:PDpoint;

BEGIN

 pg1:=Nil;pg0:=Nil;
  pg1:=points^.at(num);
  N:=eclaire_blok(num); {ressort avec 0 si un seul objet éclairé}
  While eclaire_blok0 DO INC(N);
  {si N=0 on a un seul objet éclairé et on peut donc détruire sans confirmation}
  IF N=0 THEN eclaire_bloc:=FALSE
         ELSE eclaire_bloc:=TRUE;

END; {procédure remodelée JL le 10/7/94} procedure Reqtangle(Dc:HDC;X1,Y1,X2,Y2,Gr,P,E:INTEGER;pt1:REAL); VAR Mp30:PDpoint;

   Old_option:BYTE;
   K,N:INTEGER;

BEGIN

old_option:=option_point;
IF lieu THEN option_point:=2; {modif JL 6/7/94 }
IF Imprime_TOUT THEN
 BEGIN
   K:=Raound(Rasto/2);
   IF (Gr=Point_M) THEN
    BEGIN
      Mp30:=Points^.at(Round(pt1));
      IF Mp30^.gr=Quadrill THEN option_point:=2
    END;
   IF (Option_point<>2)
     AND (((Gr>8) AND (Gr<21) OR (Gr=Point_X_Y) OR (gr=Inters) )
                OR ) OR (option_point=3))  THEN
    BEGIN
     lyne(DC,X1-2*k,ROUND((Y1+Y2)/2),X2+2*k,ROUND((Y1+Y2)/2),FALSE);
     lyne(DC,ROUND((X1+X2)/2),Y1-2*k,ROUND((X1+X2)/2),Y2+2*k,FALSE);
     Setpixel(DC,X1-2*k-1,ROUND((Y1+Y2)/2),BLANC);
     Setpixel(DC,X2+2*k+1,ROUND((Y1+Y2)/2),BLANC);
     Setpixel(DC,ROUND((x1+x2)/2),Y1-2*k-1,BLANC);
     Setpixel(DC,ROUND((x1+x2)/2),Y2+2*k+1,BLANC);
    END
   ELSE IF (Gr<>Point_M) OR (liberation) OR (option_point=2) THEN
    BEGIN
     N:=-k;
     While (X1+N)<(X2-N) DO
      BEGIN
 Rectangle(DC,X1+N,Y1+N,X2-N,Y2-N);
 INC(N);
      END;
    END
   ELSE Rektangle(DC,X1-k,Y1-k,X2+k,Y2+k);
  END
ELSE
BEGIN
 IF (Gr=Point_M) THEN
    BEGIN
      Mp30:=Points^.at(Round(pt1));
      IF (Mp30^.gr=Quadrill) and (option_point<>3) THEN option_point:=2
    END;
 IF (Efface) AND  THEN
          BEGIN
     Rektangle(DC,X1,Y1,X2,Y2);
     Rektangle(DC,X1+1,Y1+1,X2-1,Y2-1);
     Rektangle(DC,X1-1,Y1-1,X2+1,Y2+1);
     Rektangle(DC,X1-2,Y1-2,X2+2,Y2+2);
   END;
 IF (Option_point<>2)
     AND (((Gr>8) AND (Gr<21) OR (Gr=Point_X_Y) OR (gr=Inters) )
      OR ) OR (option_point=3))  THEN
   BEGIN
    lyne(DC,X1-2,ROUND((Y1+Y2)/2),X2+2,ROUND((Y1+Y2)/2),FALSE);
    lyne(DC,ROUND((X1+X2)/2),Y1-2,ROUND((X1+X2)/2),Y2+2,FALSE);
    Setpixel(DC,X1-3,ROUND((Y1+Y2)/2),BLANC);
    Setpixel(DC,X2+3,ROUND((Y1+Y2)/2),BLANC);
    Setpixel(DC,ROUND((x1+x2)/2),Y1-3,BLANC);
    Setpixel(DC,ROUND((x1+x2)/2),Y2+3,BLANC);
   END
 ELSE IF (Gr<>Point_M) OR (liberation) OR (option_point=2) THEN
   BEGIN
     IF (E=2) AND (NOT(Lieu)) AND (Gr<>Pinceau) THEN  Rectangle(DC,X1,Y1,X2,Y2);
     IF (NOT(lieu)) THEN Rectangle(DC,X1+1,Y1+1,X2,Y2);
     Rectangle(DC,X1+1,Y1+1,X2-1,Y2-1);
   END
 ELSE Rektangle(DC,X1-(E-1),Y1-(E-1),X2-(2-E),Y2-(2-E));
END;
option_point:=Old_option;
lieu:=FALSE

END; function Objet_lie(N:INTEGER):INTEGER; VAR I,Colle:INTEGER; BEGIN

  colle:=0;
  Mpt3:=Points^.At(N);  {objet à détruire}
  IF Mpt3^.gr<>Quadrill THEN
  BEGIN 
   While Mpt3^.pt1<>-1 DO                  {jusqu'au dernier}
    BEGIN
     IF (Mpt3^.pt3<>-2) THEN {n'examine que seg droite cercle}
       FOR I:=0 TO N-1 DO
         BEGIN
    Mpt4:=Points^.At(I);
       IF (Mpt4^.Gr=Point_M)  {point lié}
      AND 
    OR (Mpt4^.pt1=N))
         THEN Colle:=17;
  END;
     N:=N-1;             {et les autres}
     IF (Mpt3^.pos>=100) AND (Mpt3^.gr<>Mark_seg)
    AND (Mpt3^.gr<>Nul_Angle) AND (Mpt3^.Gr<>Aire)
                                                   AND (mpt3^.Gr<>AireQ) THEN colle:=77;
     Mpt3:=Points^.At(N);
    END;
  END ELSE Colle:=222;
  Objet_lie:=Colle;
{la fonction renvoie le code d'erreur ou zéro}

END; function corrige_quadri(VAR n:INTEGER;Force:BOOLEAN):BOOLEAN; VAR mp30: PDpoint;

   k:Integer;
   i:BYTE;

BEGIN Corrige_quadri:=FALSE; {etat_objet pour l'historique d'un objet}

IF (n<>-1) AND ( ( (NOT(enfonce)) AND )
                or (force))  THEN
  BEGIN
   Mp30:=Points^.at(n);
   IF (Mp30^.gr=segment) AND (Quadrisort_fonc(Mp30^.masse)) THEN
   BEGIN
    Corrige_quadri:=TRUE;
   k:=Sort_No(Mp30^.masse);n:=k;{se placer en haut : k}
    i:=0;
    Repeat
     k:=k+1;inc(i);
     Mp30:=points^.at(k);
    until (Mp30^.gr=segment) AND (quadrisort_fonc(Mp30^.masse));
   Q1:=i;i:=0;
    Repeat
     k:=k+1;inc(i);
     Mp30:=points^.at(k);
    until (Mp30^.gr=segment) AND quadrisort_fonc(Mp30^.masse);
   Q2:=Q1+i;i:=0;
    IF Triangsort_fonc(mp30^.masse) THEN Q3:=Q2
    ELSE
     BEGIN 
      Repeat
       k:=k+1;inc(i);
       Mp30:=points^.at(k);
      until (Mp30^.gr=segment) AND quadrisort_fonc(Mp30^.masse);
      Q3:=Q2+i;
     END;
   END;
   {le No du premier objet du quadri est contenu dans masse}
  END;

END; Procedure Vire_Bloc(DC:HDC); VAR un_objet:BOOLEAN; BEGIN

   IF mpt1^.E=888 THEN
    BEGIN
     dess_gomme(DC);
     mpt1^.draw(DC);
     detruire_ole(No);Recale_OLE(No);
     dess_norm(DC);
    END
   ELSE
   IF (No<>-1) AND (No>6) THEN
     BEGIN
  Un_objet:=NOT(Eclaire_bloc(No));
  courbe_modif:=TRUE;
  active_la(DC);
  TRaceTout(DC,FALSE);
  IF (Un_objet) OR (Supprime_Ton) THEN
    BEGIN
            Emplir_ete_trace(1);
     TRaceTout(DC,TRUE);
     Detruire_Bloc;
    Vno:=-1;Vni:=-1;
            {active_la ne doit pas repasser sur des objets qui n'existent plus Vno et Vni}
    END
  ELSE Enleve_Jaune(DC);
  TRaceTout(DC,FALSE);
  courbe_modif:=FALSE;
     END;
   No_collect:=points^.count;

END; procedure Change_Couleur(DC:HDC); VAR pg :PDpoint;

   N :INTEGER;
   Viel_Aff:BOOLEAN;

BEGIN

    IF No<>-1 THEN
         BEGIN
           N:=No;
           pg:=points^.at(N);
           IF N<7 THEN pg^.C:=Color {éléments du quadrillage}
                  ELSE
             BEGIN
               While (pg^.pt1<>-1) AND (N<points^.Count-1) DO
                                                   BEGINN:=N+1;pg:=points^.at(N) END;
                       {d'abord se placer sur le vector -1 du bloc suivant ou fin de coll}
               IF N<points^.count-1 THEN N:=N-1;{si non fin de coll remonter de 1}
               pg:=points^.at(N); 
               While (pg^.pt1<>-1) DO {c'est le pointeur de début de bloc}
               BEGIN {on change la couleur de tout le bloc}
                 Pg^.C:=Color;
                 N:=N-1;
                 Pg:=points^.at(N);
               END;
             END;
       Viel_Aff:=Courbe_modif;Courbe_modif:=TRUE;
 En_jaune:=TRUE;{permet de remémoriser les anciennes pos}
        Mpt1^.Draw(DC);En_jaune:=FALSE;
Dessin_change:=TRUE;Courbe_modif:=Viel_Aff;
        TraceTout(DC,FALSE);
END;
    On_Arete:=TRUE;
    BoutonDown:=FALSE;

END;

procedure FaisBarre; var

 MemDC,DC: HDC;

begin

   Dc:=GEtDC(WindO);
   MemDC := CreateCompatibleDC(DC);
   SelectObject(MemDC,Barre4);
   BitBlt(DC,1 ,1,219,42, MemDC, 0, 0,SrcCopy);
   ReleaseDC(WindO,DC);
   DeleteDC(MemDC);
   comptor:=0;

end;

procedure on_inverse(Rect:Trect); VAR DC: HDC; BEGIN

  DC:=GetDC(WindO);
  InvertREct(DC,Rect);
  ReleaseDC(WindO,DC);

END;

procedure active_donc(Xi:INTEGER); VAr Rect : Trect;

    {DC:HDC;}

BEGIN {quelle case de la barre magneto active-t-on ?}

 Rect.top:=2;Rect.bottom:=2+40;
  IF magneto=3 THEN magneto:=1; {pour désactiver la bonne case}
  Rect.left:=(magneto-1)*52+10 ;Rect.right:=Rect.left+42;
  IF (magneto<>0) THEN On_inverse(rect);
  IF (xi<52) AND (Xi>10) THEN BEGIN Rect.Left:=10; Magneto:=1; END;
  IF (xi<104) AND(Xi>62)THENBEGINRect.Left:=62;Magneto:=2 END;
  IF (xi<156) AND(Xi>114)THENBEGINRect.Left:=10;Magneto:=3;faisbarre END;
  IF (xi<208) AND (Xi>166) THEN  magneto:=4;
  Rect.right:=Rect.left+42;
  KillTimer(WindA,0);
  On_inverse(Rect);
  IF magneto=1 THEN setTimer(WindA,0,10,nil);
  IF magneto=2 THEN killTimer(WindA,0);
  IF magneto=3 THEN BEGIN setTimer(WindA,0,10,nil);comptor:=0 END;
  IF magneto=4 THEN setTimer(WindA,0,10,nil);

END;

procedure deplace_sur_objet(Nm:String;X,Y:INTEGER); VAR n:INTEGER;

  St:STRING;

BEGIN

for n:=0 TO points^.count-1 DO
 BEGIN
  ptequa:=points^.at(n);
  st:=ptequa^.nm;
  vire_mu(st);
  vide_blanc(st);
  IF (ptequa^.pt3=-2) AND (ptequa^.gr=point_M) AND (pos(Nm,st)>0) THEN
    BEGIN
     ptequa^.pt2:=ptequa^.pt2+Y/100;
    END;
 END;

END;

procedure deplace(Nm:String;X,Y:INTEGER); VAR n:INTEGER;

  St:STRING;

BEGIN

for n:=0 TO points^.count-1 DO
 BEGIN
  ptequa:=points^.at(n);
  st:=ptequa^.nm;
  vire_mu(st);
  vide_blanc(st);
  IF (ptequa^.pt3=-2) AND (pos(Nm,st)>0) AND (Length(St)=Length(Nm)) THEN
    BEGIN
     ptequa^.pt1:=ptequa^.pt1+X;
     ptequa^.pt2:=ptequa^.pt2+Y;
    END;
 END;

END; procedure deplaceTexte(st:String;X,Y:INTEGER); VAR n,k,x1:INTEGER; BEGIN {on veut déplacer le x1ième texte de x et Y}

Val(St,x1,k); {récupérons dabord dans x1 le numéro d'ordre du texte à déplacer}
k:=0;
for n:=7 TO points^.count-1 DO
 BEGIN
  ptequa:=points^.at(n);
  st:=ptequa^.nm;
  IF (pos(St,'~@|')>0) THEN inc(k);
  IF (x1-1)*2+1=k THEN {on est sur le x1ième texte de la figure et on déplace}
    BEGIN
     ptequa^.pt1:=ptequa^.pt1+X;
     ptequa^.pt2:=ptequa^.pt2+Y;
    END;
 END;

END;

procedure valeurs(St:String;VAR X,Y:INTEGER); VAR n,err:INTEGER;

   Sto:STRING;

BEGIN

n:=pos(',',St);
sto:=copy(St,1,n-1);
IF n=0 THEN X:=mil ELSE Val(Sto,X,err);
sto:=copy(St,n+1,length(St)-n);
Val(Sto,Y,err);

END;

function fonction(VAR st:string;VAR X,Y:INTEGER):BYTE; VAR err:WORD;

   Sti:String;

BEGIN

X:=0;
fonction:=0; {si reste à 0 alors erreur de syntaxe}
if pos('*',St)>0 THEN {c'est une ligne pour la barre de titre}
  BEGIN delete(St,pos('*',st),1);fonction:=6;exit END;
vide_blanc(St);
majuscules(St);
if pos('CHARGER',St)>0 THEN
  BEGIN delete(St,1,7);StrPcopy(filename,st);fonction:=1 END;
if pos('FENETRE',St)>0 THEN fonction:=111; {inutile mais ne provoque pas d'avert}
if pos('SECONDES',St)>0 THEN
  BEGIN delete(St,1,8);VAL(St,X,err);fonction:=2 END;
if pos('PRECISION',St)>0 THEN
  BEGIN delete(St,1,9);VAL(St,X,err);fonction:=12 END;
if pos('PAUSE',St)>0 THEN
  BEGIN delete(St,1,5);fonction:=7 END;
if pos('TRACEACTIVE',St)>0 THEN fonction:=9;
if pos('TRACENONACTIVE',St)>0 THEN fonction:=10;
if pos('AVECLETTRE',St)>0 THEN fonction:=13;
if pos('SANSLETTRE',St)>0 THEN fonction:=14;
if (pos('RAFFRAICHI',St)>0) OR (pos('RAFRAICHI',St)>0) THEN fonction:=18;
if (pos('NETTOYER',St)>0) OR (pos('NETOYER',St)>0) THEN fonction:=19;
if pos('TRANSPARENT',St)>0 THEN fonction:=15;
if pos('OPAQUE',St)>0  THEN fonction:=16;
if pos('COULEUR',St)>0 THEN
  BEGIN
  delete(st,1,7);Sti:=St;fonction:=11;
  END; {fin de touche}
if pos('TOUCHE',St)>0 THEN
  BEGIN
   delete(st,1,6);
   IF st='F2' THEN fonction:=3;
   IF st='F3' THEN fonction:=4;
  END; {fin de touche}
if pos('REPETER',St)>0 THEN
  BEGIN
   memo_comptor:=comptor;   {mémorisons la position pour faire remonter le pointeur...}
   Delete(St,1,7);
   VAL(st,n_fois,err);
   fonction:=111; {éviter le message avert}
  END;
if pos('FIN',St)>0 THEN     {...dès que l'on rencontre le mot fin}
  BEGIN
   DEC(n_fois);
   IF n_fois>=0 THEN comptor:=memo_comptor;
   fonction:=111; {éviter le message avert}
  END;
if pos('DEPLACER',st)>0 THEN
  BEGIN
  if pos('DEPLACERTEXTE',St)>0 THEN
    BEGIN
     delete(St,1,13);
     sti:='';
     {récupérons dabord le numéro de texte dans sti} 
     While (pos(':',St)<>1) AND (St<>'') DO BEGIN Sti:=Sti+St1;Delete(St,1,1) END;
     Delete(St,1,1); {et virons le point-virgule}
     VALEURS(St,X,Y); {pour récupérer le déplacement}
     IF st='' THEN fonction:=0 {une erreur il manque les : }
              ELSE fonction:=17;
    END
  else
    BEGIN
     delete(St,1,8);
     Sti:=St1;
     delete(St,1,1);
     VALEURS(St,X,Y);
     IF X=mil THEN fonction:=8 {on se déplace sur un objet}
              ELSE fonction:=5;
    END;
  END;
 St:=Sti;

END;

function la_couleur(St:STRING):TcolorRef; BEGIN

IF St='ROUGE' THEN   la_couleur:=ROUGE;
IF St='BLEU'  THEN   la_couleur:=BLEU;
IF St='VERT'  THEN   la_couleur:=VERT;
IF St='VIOLET'THEN   la_couleur:=VIOLET;
IF St='GRIS'  THEN   la_couleur:=GRIS;
IF St='NOIR'  THEN   la_couleur:=NOIR;

END;

procedure THwindow.Horloge(Var Msg:Tmessage); VAR n :INTEGER;

  X,Y:INTEGER;
  DC:HDC;
  St:STRING;
  Name: array0..212 of Char;
  Txt : ChaineC;

BEGIN {suivant les événements cet procédure est branchée à l'aide de setTimer}

IF magneto=4 THEN BEGIN killTimer(WindA,0);Done;exit END;
{KillTimer(WindA,0);}  {vire les timer de la pile}
IF comptor<textes_ciel^.count then setTimer(WindA,0,1,nil); {on rebranche}
{total détermine le nombre de passage et vient le la procédure quelle_longueur}
 IF comptor<textes_ciel^.count THEN
 BEGIN 
  DC:=GetDC(WindA);
 ptequa:=textes_ciel^.at(comptor);St:=ptequa^.nm;
  case fonction(St,X,Y) of
   0: BEGIN {erreur de syntaxe}
         INC(comptor);{permet de tomber sur le bon numéro de ligne}
         Str(comptor,St);St:=' à la ligne '+St;
         StrPcopy(Txt,'ERREUR DE SYNTAXE'+#13#10+St);
         ReleaseDC(WindA,DC);
         {ReleaseCapture;}
         killTimer(WindA,0);
         My_messageBox(Txt,1);
         {MessageBox(Hwindow,name,
         'ERREUR DE SYNTAXE', mb_OK or mb_Iconquestion);}
         comptor:=Textes_ciel^.count;
         done;
         exit;
      END;
   1: BEGIN
        {invalidateRect(WindA,Nil,TRUE);
        updateWindow(WindA);}
        SendMessage(WindA,Wm_first+Wm_EraseBkgnd,DC,0);
        killTimer(WindA,0); {indispensable en cas de plantage au chargment}
        IF PG_wind^.loadFile THEN
          BEGIN
           avec_lettre:=flag_lettres;
           Trace_Une_Fois(DC);{car tracetout n'itialise pas les V_x la première fois}
           {faisOrdre(DC,FALSE);}
           setTimer(WindA,0,2,nil);
          END;
      END;
   2: SetTimer(windA,0,X*100,nil);
   3: montre_le_suivant(DC);
   4: cache_le_suivant(DC);
  17: BEGIN
       DeplaceTexte(st,X,Y);
       faisordre(DC,FALSE); {permet d'effacer les objets déplacés}
       IF NOT(flag_Xor) THEN traceTout(DC,FALSE); {et de les retracer}
      END;
   5: BEGIN
       Deplace(St,X,Y);
       faisordre(DC,FALSE); {permet d'effacer les objets déplacés}
       IF NOT(flag_Xor) THEN traceTout(DC,FALSE); {et de les retracer}
      END;
   8: BEGIN {on est sur un objet}
       Deplace_sur_objet(St,X,Y);
       faisordre(DC,FALSE); {permet d'effacer les objets déplacés}
       IF NOT(flag_Xor) THEN traceTout(DC,FALSE); {et de les retracer}
      END;
    6:BEGIN {barre de titre}
       StrPcopy(Name,St);
       setcaption(Name);
      END;
    7: Active_donc(70); {se met en pause}
    18: TraceTout(DC,FALSE); {raffraichir}
    19: BEGIN {Nettoyer}
         SendMessage(WindA,Wm_first+Wm_EraseBkgnd,DC,0);
         emplir_ete_trace(1);
         tracetout(DC,TRUE);
         emplir_ete_trace(1);
         TraceTout(DC,FALSE);
         TracePoint(DC,FALSE);
        END;
    9: BEGIN
         Trace_Active:=TRUE;
         Je_bouge:=TRUE;
         deplace_xor:=TRUE;
       END;
    10:BEGIN
        Trace_Active:=FALSE;
        Je_bouge:=flag_bouge;
        deplace_xor:=flag_deplace;
       END;
    11:Color:=la_couleur(St);
    12: IF (X>0) AND (X<4) THEN mesure_precis:=X;
    13: flag_lettres:=TRUE;
    14: flag_lettres:=FALSE;
    15: flag_XOR:=TRUE;
    16: flag_XOR:=FALSE;
  END; {of case}
  ReleaseDC(WindA,DC);
 END {fin de if compteur<textes_ciel^.count}
 ELSE BEGIN faisbarre;KillTimer(WindA,0);magneto:=0; END; {désactive la lecture}
 
 inc(comptor);

END;

procedure TOWindow.WMLButtonDown(var Msg: TMessage); VAR Xi,Yi: INTEGER;

       {DC:HDC;}
       point:Tpoint;

begin

{DC:=GetDC(Hwindow);}
Xi:=RAOUND(Msg.LparamLO);point.X:=Xi;
Yi:=RAOUND(Msg.LparamHI);point.Y:=Yi;
ClientToScreen(Hwindow,Point);
IF (WindowFromPoint(Point)=HWindow) THEN active_donc(xi);
{ReleaseDC(Hwindow,DC);}

end;

Procedure THWindow.ToucheUp(VAR Msg:Tmessage); {VAR DC:HDC;} begin

  {DC:=GetDC(Hwindow);}
     if Msg.WParam = vk_F1 then active_donc(20);
     if Msg.WParam = vk_F2 then active_donc(70);
     if Msg.WParam = vk_F3 then active_donc(120);
     if Msg.WParam = vk_F4 then active_donc(170);
     DefWndProc(Msg);
  {releaseDC(Hwindow,DC);}

END;

constructor TOWindow.Init(AParent: PWindowsObject; ATitle: PChar;X0,Y0:INTEGER);

BEGIN
 {Par:=Aparent;}
 TWindow.Init(Aparent,Atitle);
 Attr.X:=Round(Xoutil+1);
 Attr.Y:=Round(Youtil);
 Attr.W:=Round(219);
 Attr.H:=Round(41);
 Attr.Style := Ws_visible or Ws_popup;
 magneto:=0;

end;

DEstructor TOwindow.Done; BEGIN

 Tobject.Done;
 TWindow.Done;

END;

{procedure TOWindow.Paint(PaintDC: HDC; var PaintInfo: TPaintStruct); BEGIN

  faisBarre;

END;}

constructor THWindow.Init(AParent: PWindowsObject; ATitle: PChar;X0,Y0:INTEGER); VAR St:STRING;

   Sx,Sy:INTEGER;
BEGIN
 Sx:=GetSystemMetrics(Sm_CXScreen);{largeur de l'écran }
 Sy:=GetSystemMetrics(Sm_CYScreen);{hauteur de l'écran }
 V_par:=Par; 
 Par:=Aparent;
 TWindow.Init(Aparent,Atitle);
 Ptequa:=textes_ciel^.at(0);
 St:=Ptequa^.Nm;
 Majuscules(St);
 Vide_blanc(St);
 if pos('FENETRE',St)=1 THEN
  BEGIN {recalcule les coordonnées fenêtre}
    delete(St,1,7);
    valeurs(St,X0,Y0);
    Xoutil:=Round((Sx-X0)/2);{centrer dans l'écran en X}
    Youtil:=Round((Sy-Y0)/2);{ et en Y}
  END
ELSEBEGINXoutil:=0;Youtil:=0; END;{ou fenêtre maxi_écran}
 Attr.X:=Xoutil; {Xo et yo sont utilisées pour caler le magnéto en haut à gauche de l'écran}
 Attr.Y:=Youtil;
 Attr.W:=Round(X0);
 Attr.H:=Round(Y0);
 Attr.Style := Ws_caption or Ws_Visible or Ws_Border;
 IF Xoutil=0 THEN Attr.Style:=Attr.Style or Ws_maximize;
 Youtil:=Youtil+Round(Y0)-41;

end;

procedure THWindow.SetUpWindow; VAR Gwnd :Pwindow; BEGIN

Twindow.SetUpWindow;
premier:=TRUE;
WindA:=Hwindow;
Old_wind:=Wind;
Wind:=WindA;
flag_trace:=Trace_Active;
flag_bouge:=Je_bouge;
flag_deplace:=Deplace_Xor;
flag_lettres:=FALSE;
flag_Xor:=FALSE;
Strcopy(FileScript,Filename); {pour restituer l'ancien}
   GetWindowsDirectory(FileNameCiel,79);
  {on sauvegarde la figure actuelle avant de récupérer le fichier }
   StrCat(FileNameciel,'\geom.sav');
   StrCopy(Filename,FilenameCiel);
  PG_wind^.saveFile;
  PG_wind^.faisName(FileScript); {récupère le nom de fichier actif}
  GWnd := New(POWindow, Init(@Self,'',0,0));
  Application^.MakeWindow(GWnd);
{Dans_cadre:=FALSE;}
  faisBarre;
  SetFocus(Hwindow);

END;

procedure TOWindow.SetUpWindow; BEGIN

  Twindow.SetUpWindow;
  Windo:=Hwindow;
  setCapture(Hwindow);

END;

procedure Recharger; BEGIN

 SendMessage(Wind,Wm_first+Wm_paint,0,0); {juste pour redessiner la fenêtre de Wind}
 on_scripte:=FALSE;
 StrCopy(Filename,Filenameciel);{récupère le fichier actif}
 PG_wind^.loadFile;
 FilenameCiel0:=#0;
 StrCopy(Filename,Filescript);{récupère le fichier actif}
 PG_wind^.faisName(Filename); {récupère le nom de fichier actif}

END;

DEstructor THwindow.Done; BEGIN

 par:=V_par;
 IF GetCapture=WindO THEN releaseCapture;
 KillTimer(windA,0);
 Tobject.Done;
 TWindow.Done;
 WindA:=0;
 Wind:=Old_Wind;
 Trace_Active:=flag_trace;
 Je_bouge:=flag_bouge;
 Deplace_Xor:=flag_deplace;
 Dispose(Textes_ciel,done);
 recharger;
 {remet_points;}

END;

procedure faire_le_script; VAR stchar:array0..212 of Char;

   st : String;
   GWnd: PWindow;
BEGIN
 Ptequa:=textes_ciel^.at(0);
 St:=Ptequa^.Nm;Majuscules(St);
 IF pos('FENETRE',St)>0 THEN comptor:=1
                        ELSE comptor:=0;
 ptequa:=textes_ciel^.at(comptor);
 st:=Ptequa^.Nm;                        
 if pos('*',St)>0 THEN delete(St,1,1) ELSE St:='IMAGICIEL';
 StrPcopy(StChar,St);
 GWnd := New(PHWindow, Init(Nil,Stchar,0,0));
 Application^.MakeWindow(GWnd);
END;

function Collage(X,Y:INTEGER):BOOLEAN; BEGIN

coller_ole(X-scroll_X,Y-Scroll_Y);
collage:=TRUE;

end;

function Est_ce_Image(DC:HDC;n,c,Teta,fonc,mk:INTEGER):INTEGER; VAR j:INTEGER; BEGIN

J:=Image_De(n,c,Teta,fonc);
IF j=-1 THEN BEGIN Trace_Sauve_Pt(DC,n,c,Teta,Epaiss,fonc,color,0,mk);
                   Est_ce_IMAGE:=points^.count-1; END
  ELSE Est_ce_Image:=j;

END;

Function Fais_Delta_Bissect(N,Xo,Yo,Xoo,Yoo:INTEGER):INTEGER; VAR K0,K1,L0,L1,X,Y :REAL;

   Mpt30 : PDpoint;

BEGIN {plus facile d'enregistrer 2 et 0 que 1 et -1}

 Mpt30:=Points^.At(N);
 X:=Mpt30^.X;
 Y:=Mpt30^.Y;
 IF (Xo-X)>0  THEN K0:=2
   ELSE K0:=0;
 IF (Yo-Y)>0  THEN K1:=2
                 ELSE K1:=0;
 IF (Xoo-X)>0 THEN L0:=2
   ELSE L0:=0;
 IF (Yoo-Y)>0 THEN L1:=2
   ELSE L1:=0;
 Fais_Delta_Bissect:=RAOUND(k0*1000+K1*100+L0*10+L1);

END;

procedure Sauve_Figure(P1,P2,P3,Teta,G,Mk:INTEGER;Mass:REAL); VAR St : STRING2;

   fn,No,Pt_till : INTEGER;
   N     : LongInt;

BEGIN

 pt_till:=pointill;
 IF Def_TExte THEN
  BEGIN
    St:='TA';
    Textes^.Insert(New(PDtexte,Init(TexteA,0)));
    P3:=Textes^.count-1;
                  {sortie_menu=0 ou 2 récupéré dans editor dans V_courbes}
                  pt_till:=sortie_menu;
  END
       ELSE IF (Def_rect) THEN St:='RE' ELSE St:='FI';
 IF (Fonc=Rectang)   AND (G=Droite) THEN St:='NO';{pour cacher la droite support du rectangle}
 IF (Fonc=TriangleR) AND (G=Droite) THEN St:='NO';{pour cacher la droite support du rectangle}
 IF (Fonc=losange)   AND (G=Cercle) THEN St:='NO';{pour cacher le cercle support du losange}
 IF (Fonc=TriangleI) AND (G=Cercle) THEN St:='NO';{pour cacher le cercle support du losange}
 fig.init(P1,P2,P3,Teta,Epaiss,pt_till,color,St,0,G,Mk,Mass);
 Points^.Insert(New(PDFigures,Init(P1,P2,P3,Teta,epaiss,pt_till,color,St,0,G,Mk,Mass)));
 No_Collect:=Points^.count;

END;

procedure Sauve_Vector(P1,P2,Teta,G:INTEGER;Mass:REAL;Epaisseur:INTEGER); VAR R4:INTEGER; BEGIN

 {Epaisseur sert à pointer sur l'objet antécédent dans une transformation}
 IF Fonc=Sym_Axiale THEN Mass:=-Mass;
 IF G=Mark_angle THEN R4:=R0 ELSE R4:=0;
 Vect.init(P1,P2,R4,Teta,Epaisseur,pointill,color,'N1',0,G,0,Mass);
 Points^.Insert(New(PDVector ,
     Init(P1,P2,R4,Teta,epaisseur,pointill,color,'N1',0,G,0,Mass)));
 No_Collect:=Points^.count;

END;

function Segment_Marque:INTEGER;

VAR N,Num: INTEGER;
    Mpt:PDpoint;
    Sortie:BOOLEAN;

{pour vecteur et cercle de rayon ou norme constante} BEGIN

 Num:=0;
 mpt:=Nil;
 FOR N:=0 TO points^.count-1 DO
  BEGIN
   Sortie:=FALSE;
   Mpt:=Points^.At(N);
   IF (Mpt^.mark=1) AND (Mpt^.Gr=Vecteur) THEN Sortie:=TRUE;
   IF (Mpt^.mark=1) AND (Mpt^.Gr=Segment) AND (fonc=cercle) THEN Sortie:=TRUE;
   IF (Sortie) THEN IF (Num>0) THEN Num:=Points^.count
                               ELSE Num:=N;
  END;
 IF Num=0 THEN Num:=Points^.count;
 Segment_Marque:=Num;
 {Si on sort avec points^.count -> on n'a rien trouvé }

end;

function nombre_dobjets:INTEGER; VAR n,compteur: INTEGER;

   Mp:PDpoint;

BEGIN

compteur:=0;
For n:=7 TO points^.count-1 DO
  BEGIN
   Mp:=Points^.at(n);
   IF mp^.pt1=-1 THEN INC(Compteur)
  END;
nombre_dobjets:=Compteur;

END;

Function Fais_Nom_plan:Nom; VAR Mp : PDpoint;

   n,i:INTEGER;
   St: String3;

BEGIN

  n:=1;
  For i:=1 TO points^.count-1 DO
    BEGIN
     Mp:=points^.at(i);
     IF Mp^.gr=pinceau THEN n:=n+1;
    END; {combien de demi_plans ? }
  Str(n,St);
  Fais_nom_plan:='µ(P'+St+')';

END;

Function Fais_Nom(N:INTEGER):Nom; VAR Ch:CHAR;

   Mpt:PDpoint;
   Erreur: BOOLEAN;
   I,J:INTEGER;
 Procedure Suivant;
  BEGIN
   IF nm01='µ' THEN Ch:=nm03 ELSE Ch:=nm02;
   IF ORD(Ch)<121 THEN Ch:=CHR(Ord(Ch)+1) ELSE Ch:='+';
   IF Ch=':' THEN Ch:='a';
   IF Ch='#' THEN Ch:='0';
   IF Ch='(' THEN Ch:='"';
   IF Ch='!' THEN Ch:=;
   IF Nm01='µ' THEN Nm0:=Nm01+Nm02+Ch
                 ELSE Nm0:=Nm01+Ch;
 END;
 function Caract_Table(N:INTEGER):CHAR;
 VAR Nn:INTEGER;
 BEGIN
     Erreur:=FALSE;
     Nn:=N +64;
     IF Nn>90 THEN Nn:=Nn+6;
     IF Nn>122 THEN Erreur:=TRUE;
     IF erreur THEN Caract_Table:='*'
 ELSE Caract_Table:=CHr(Nn);
 END;
 function Existe_T_il(P:PDgraph):BOOLEAN; far;
  BEGIN
   IF Nm01='µ' THEN j:=2 ELSE j:=1;
   IF P^.nM1='µ' THEN i:=2 ELSE i:=1;
   IF (P^.nMi=Nm0j)
      AND (P^.nMi+1=Nm0j+1) THEN Existe_t_il:=TRUE
    ELSE Existe_t_il:=FALSE;
  END;

BEGIN

IF TransForm Fonc THEN
 BEGIN
   Mpt:=Points^.At(N);
   nm0:=Mpt^.Nm;
  IF nm0<>'' THEN {vide pour pt virtuel mediat ou bissect}
  REPEAT
   Suivant;
   Pg:=Points^.FirstThat(@Existe_T_il);
  UNTIL (Pg=Nil) OR (Nm02='+');
   Mpt:=Nil;
 END
ELSE
BEGIN
 Compt_Nom:=0;
 REPEAT
  Inc(Compt_Nom);
  nm0:=Caract_Table(Compt_Nom)+' ';
  Pg:=Points^.FirstThat(@Existe_t_il);
 UNTIL (Pg=Nil) OR (Erreur);
END;
  IF (avec_lettre) AND (Nm01<>'µ') THEN Nm0:='µ'+Nm0;
  IF Ch_clav='~' THEN Fais_Nom:=nm0
   ELSE BEGIN Fais_Nom:='µ'+Ch_clav+' ';Ch_clav:='~' END;

END;

procedure Trace_Sauve_Pt(DC:HDC;x,y:REAL;Teta,E,Fnc:INTEGER;C:TcolorRef;Mark,Mk:INTEGER); VAR pose:INTEGER;

   Nvect:INTEGER;
   Masse,Masse0:REal;

BEGIN

 pose:=12;pg:=Nil;
  dessin_change:=true;
  IF fonc<>Pinceau THEN nm0:=Fais_Nom(ROUND(x))
                   ELSE nm0:=Fais_Nom_plan;
  IF (fnc=mark_seg) THEN {Mzg permet de ne pas afficher le nom du point}
        BEGIN
        Teta:=Long_Seg;pose:=12;
         If NOT(Avec_degres) THEN Teta:=-Teta;
         Mark:=Pointill;
         nm0:='Mzg';
        END;
  IF fnc=Point_X_Y THEN nm0:=nm0+'£'+chf1;
  IF (fnc=aire) OR (fonc= aireQ)THENBEGINpose:=12;nm0:='Mzg';END;
  IF Def_Texte THEN
 IF (BoutonDown) THEN BEGIN nm0:='~@|'; END
   ELSE BEGIN nm0:='~@';  END;
  IF (fonc= Bissectrice)THENBEGINnm0:='';Fnc:=Point_M END;
  IF (fonc=Mediatrice)  OR (Def_Rect) THEN nm0:='';
  IF (fonc= Pinceau) AND(BoutonDown)THENBEGINnm0:='';Mark:=Pointill END;
  IF (Fnc=primitive) THEN nm0:=Xprimit;
  IF (avec_masse) OR (E=888) THEN masse0:=1 ELSE masse0:=2001;
 {nom='' permet de fabriquer un point non visible}
   Pt.init(x,y,-2,Teta,E,Mark,C,nm0,pose,fnc,Mk,masse0);
   Points^.Insert(New(PDpoint, Init(x,y,-2,Teta,E,Mark,C,nm0,pose,fnc,Mk,masse0)));
  {toutes les masses par defaut seront à 2000}
  Pt.DRAW(DC);
  {un vecteur ou un cercle de norme donnée}
  IF  AND (BoutonDown) THEN
    BEGIN
      Nvect:=segment_marque;
      IF Nvect<points^.count THEN
BEGIN
 {on fabrique un point translaté avec le vecteur Nvect}
        IF fonc=cercle THEN masse:=ratio ELSE masse:=1;
 nm0:=Fais_Nom(Points^.count-1);
 Points^.Insert(New(PDpoint,
      Init(Points^.count-1,Nvect,-2,Teta,E,Mark,C,nm0,pose,translat,Mk,2001)));
 pg:=Points^.at(points^.count-1);Pg^.DRAW(DC);
 Pg:=Points^.at(Nvect);{points sur objet marqué pour récupérer son vect dans pt2}
 Sauve_Figure(points^.count-2,ROUND(Pg^.pt2),points^.count-1,0,fonc,0,masse);
 On_Arete:=TRUE;
END;
    END;
    No_Collect:=Points^.count;

END;

function passe_par_le_point(k:INTEGER;VAR ni:INTEGER):BOOLEAN; VAR n,Xo_V,Yo_V,V_Ni:INTEGER;

   Mpt7,Mpt8:Pdpoint;

BEGIN

Xo_V:=Xo;Yo_V:=Yo;V_Ni:=ni;
Mpt8:=points^.at(k); {pointe sur la parallèle que l'on vient de faire}
For n:=7 TO points^.count-1 DO
 BEGIN
   Mpt7:=points^.at(n);
   IF (Mpt7^.pt3=-2) THEN {ne passe en revue que les points}
    BEGIN
    Xo:=ROUND(MPt7^.X);Yo:=ROUND(Mpt7^.Y); {Xo et Yo pour la méthode est_ce_moi}
     IF (mpt7^.pos<100) AND (Mpt8^.est_ce_moi(0)) AND (n<>V_ni) THEN ni:=n;
    END;
 END;
 IF ni<>V_ni THEN passe_par_le_point:=TRUE ELSE passe_par_le_point:=FALSE;
Xo:=Xo_V;Yo:=Yo_V;

END;

function Cherche_pt_commun(No,Ni:INTEGER;DC:HDC):INTEGER; VAR N:REAL; BEGIN {utile pour la bissectrice}

 Mpt2:=Points^.At(Ni);
 Mpt3:=Points^.At(No);
 N:=-1;
 IF No<>Ni THEN
 BEGIN
  IF (Mpt2^.pt1=Mpt3^.pt1) OR (Mpt2^.pt1=Mpt3^.pt3) THEN N:=Mpt2^.pt1;
  IF (Mpt2^.pt3=Mpt3^.pt1) OR (Mpt2^.pt3=Mpt3^.pt3) THEN N:=Mpt2^.pt3;
  IF (N=-1) OR (N=0) THEN
   BEGIN
    {on cherche si l'intersection existe}
    Pt.init(No,Ni,-2,0,Epaiss,3,Color,'',12,Point_M,0,2001);
    IF Pt.X=Mil THEN N:=-1 {elle n'existe pas}
    ELSE
     BEGIN
      {fabrique un point d'intersection fictif}
      Trace_Sauve_Pt(DC,No,Ni,0,Epaiss,fonc,Color,3,0);
      N:=Points^.count-1;
    END;
   END;
 END;
 Cherche_pt_commun:=ROUND(N);

END;

function Aumoins_Unlieu(VAR Depuis:INTEGER):BOOLEAN;

function OnTrouve0(P: PDgraph):BOOLEAN; far;
   BEGIN
     OnTrouve0:=FALSE;
     IF (P^.Gr=LIEU_POINT) THEN OnTrouve0:=TRUE
   END;

BEGIN

While (Depuis<points^.count) AND NOT (Ontrouve0(points^.at(Depuis))) do inc(Depuis);
IF Depuis<points^.count THEN Mpt4:=points^.at(Depuis) ELSE Mpt4:=Nil;
IF Mpt4=Nil THEN Aumoins_Unlieu:=FALSE ELSE Aumoins_Unlieu:=TRUE;
inc(Depuis);

END;

function trois_equi(X,Y,Z,A,B,C:INTEGER):BOOLEAN; BEGIN

IF  OR 
 or OR 
 or OR  THEN trois_equi:=TRUE
                                                              ELSE trois_equi:=FALSE;

END; function Cherche_Aire(Index:REAL):BOOLEAN;

function OnTrouve0(P: PDgraph):BOOLEAN; far;
   BEGIN
     OnTrouve0:=FALSE;
     IF (P^.Gr=AIRE) AND (P^.pt1=Index) THEN OnTrouve0:=TRUE
   END;

BEGIN

Mpt4:=Points^.FirstThat(@Ontrouve0);
IF Mpt4<>Nil THEN Cherche_Aire:=TRUE ELSE Cherche_Aire:=FALSE;

END;

function quatre_equi(X,Y,Z,T,A,B,C,D:INTEGER):BOOLEAN; BEGIN

IF  AND
    AND
    AND
     THEN quatre_equi:=TRUE
                                       ELSE quatre_equi:=FALSE;

END;

function Cherche_AireQ(No,Ni:INTEGER):BOOLEAN; VAR A,B,C,D:INTEGER;

function OnTrouve1(P: PDgraph):BOOLEAN; far;
   BEGIN
     OnTrouve1:=FALSE;
     IF (P^.gr=AIREQ) THEN
      BEGIN
          ptequa:=points^.at(Round(P^.pt1)); {un côté}
          pg:=points^.at(Round(P^.pt2));     {et l'autre}
        IF quatre_equi(Round(Ptequa^.pt1),Round(Ptequa^.pt3),ROUND(Pg^.pt1),Round(Pg^.pt3),A,B,C,D)
                                             THEN OnTrouve1:=TRUE;
      END;
   END;

BEGIN

ptequa:=points^.at(Ni); {un côté}
pg:=points^.at(No); {et l'autre}
A:=ROUND(ptequa^.pt1);B:=ROUND(ptequa^.pt3);    {et les bouts}
C:=ROUND(pg^.pt1);    D:=ROUND(pg^.pt3);    {et les bouts}
Mpt4:=Points^.FirstThat(@Ontrouve1);
IF Mpt4<>Nil THEN Cherche_AireQ:=TRUE ELSE Cherche_AireQ:=FALSE;

END;

function Cherche_AireT(No,Ni:INTEGER):BOOLEAN; VAR A,B,C:INTEGER;

function OnTrouve1(P: PDgraph):BOOLEAN; far;
   BEGIN
     OnTrouve1:=FALSE;
     IF (P^.gr=AIRE) THEN
      BEGIN
          ptequa:=points^.at(Round(P^.pt2)); {la base}
          {ptequa:=points^.at(Round(Ptequa^.pt2));}
        IF Trois_equi(Round(Ptequa^.pt1),Round(Ptequa^.pt3),ROUND(P^.pt1),A,B,C)
                                             THEN OnTrouve1:=TRUE;
      END;
   END;

BEGIN

ptequa:=points^.at(Ni); {Ni pointe sur la  base et No sur le sommet}
{ptequa:=points^.at(Round(Ptequa^.pt2)); vecteur de la base}
B:=ROUND(ptequa^.pt1);C:=ROUND(ptequa^.pt3);A:=No;    {et les bouts}
Mpt4:=Points^.FirstThat(@Ontrouve1);
IF Mpt4<>Nil THEN Cherche_AireT:=TRUE ELSE Cherche_AireT:=FALSE;

END;

function Cherche_Segment(No,Ni:REAL):INTEGER;

function OnTrouve0(P: PDgraph):BOOLEAN; far;
   BEGIN
     OnTrouve0:=FALSE;
     IF (P^.Gr=Mark_seg) OR (P^.Gr=Nul_Angle) THEN
 IF        
 OR  THEN OnTrouve0:=TRUE
   END;

BEGIN

Mpt4:=Points^.FirstThat(@Ontrouve0);
Cherche_Segment:=Points^.Indexof(Mpt4);

END;

procedure Recale_OLE(No:INTEGER); VAR n : INTEGER; BEGIN

FOR n:=7 TO points^.count-1 DO
 BEGIN
  Mpt4:=Points^.At(n);
  IF (Mpt4^.E=888) AND (n>No) THEN Mpt4^.mark:=Mpt4^.mark-1;
 END;

END;

function Cherche_Angle(No,Ni,R:INTEGER):INTEGER;

function OnTrouve0(P: PDgraph):BOOLEAN; far;
   BEGIN
     OnTrouve0:=FALSE;
     IF (P^.Gr=Mark_angle) OR (P^.Gr=Nul_Angle) THEN
 IFTHEN OnTrouve0:=TRUE;
   END;

BEGIN

Mpt4:=Points^.FirstThat(@Ontrouve0);
Cherche_Angle:=Points^.Indexof(Mpt4);

END;

procedure cherche(Pt, A:BYTE); {mioussov} VAR mp30:PDpoint;

   pg0 :PDgraph;  
   n,n0:INTEGER;
   Sortie:BOOLEAN;

function Oncherche:INTEGER;

  BEGIN
            SORTIE:=FALSE;
            WHILE (NOT(SORTIE)) AND (n<points^.count) DO
               BEGIN
                  mp30:=Points^.At(n);
                  {point_actif est le No du point déplacé avec la main ou bouge_vecteur sinon -1}
                  IF (n<>point_Actif) AND (Mp30^.Est_ce_moi(pt)) THEN SORTIE:=TRUE;
                  INC(n);
               END;
            IF SORTIE THEN Oncherche:=n-1 ELSE Oncherche:=-1;
  END;

BEGIN

   {kont est incréménté par appui sur la touche control}
   {on arrive avec A=7 de la procedure change_etat_point pour libérer ou lier un point}
    NNo:=-1;NNi:=-1;
      IF (point_actif<>-1) AND (A<>7) THEN
         BEGIN {les points déplacés sur un objet n'allument rien. A=7 dans change_etat_point}
           mp30:=points^.at(point_actif);
           IF (mp30^.gr=point_M) OR (mp30^.nm='~@|') THEN exit;
         END;
     IF (Delta2=Mil+10) AND (Kont=6) THEN Kont:=1;
     n:=Kont+1;{on commence ainsi à kont dans la collection}
     pt:=1; {les points en priorité}
    NNo:=OnCherche;Delta1:=delta; {n n'est par réinitialisé}
     pt:=3; {pour obliger à chercher des figures à partir d'ici}
     n:=Kont+1;
     IF (NNo=-1)  THEN {ou les figures si pas de points }
       BEGINNNo:=OnCherche;Delta1:=Delta; END;
     n0:=n;
     IF(NNo<>-1)THENBEGINNNi:=OnCherche;Delta2:=Delta;END;{figures toujours}
     IF(NNo<>-1)AND(NNi=-1)THENBEGINpt:=1;n:=n0;NNi:=OnCherche END;{ou points}
     IF (NNo<6) AND (NNi=6) AND (Kont=-1) THEN {pb avec axes et quadrillage}
       BEGINNNo:=NNi;Delta1:=Delta2;Mch1:=Mch2;Delta2:=Mil+10;NNi:=-1 END;
     IF (NNo<6) AND (NNi=6) AND (Kont=1) THEN NNi:=-1;{même pb d'ou le Delta2=mil}
   {if faut d'abord voir si on n'est pas sur un quadrilatère et récupérer q1,q2,q3}
   {qui contiennent les décalages propres pour se placer sur les côtés du quadri}
   IF NNo<>-1 THEN BEGIN corrige_quadri(NNo,FALSE);Mch1:=points^.at(NNo) END;
   IF NNi<>-1 THEN BEGIN corrige_quadri(NNi,FALSE);Mch2:=points^.at(NNi) END;
   IF (NNo<>-1) AND (NNi<>-1) AND (NNo<>NNi) THEN
     BEGIN {donne la priorité au quadrillage}
 IF (Mch1^.Gr=Quadrill) AND (NNo<>0) THEN NNi:=-1;
        IF  AND (Ratio<>1) THEN NNi:=-1;
     END;
   IF (Fonc=Select) AND (point_actif=-1) AND (NNo=6) THEN NNo:=-1; {ne select pas le quadrill}
        {ne pas activer un objet si un de ses bouts est le point_actif}
   IF (A<>17) AND (NNo<>-1) AND (Mch1^.pt3<>-2)
              AND ( (Mch1^.pt1=point_actif) OR (Mch1^.pt3=point_actif) ) THEN NNo:=-1;
   IF (A<>17) AND (NNi<>-1) AND (Mch2^.pt3<>-2)
              AND ( (Mch2^.pt1=point_actif) OR (Mch2^.pt3=point_actif) ) THEN NNi:=-1;
 {ne pas afficher ensemble deux objets suraffichés sauf avec le quadrill NNo=6
  sauf cercle et segment qui envoie pg^.X=mil mais gr1-gr2>2}
        {A=17 pour contextuels qui doivent sortir le suivant même si suraffichés}
   IF (A<>17) AND (NNo<>-1) AND (NNi<>-1) AND (NNo<>NNi)  THEN
   BEGIN
  IF (Mch1^.pt3<>-2) AND (Mch2^.pt3<>-2) THEN
          pg0:=New(PDpoint,INIT(NNo,NNI,-2,0,Epaiss,3,color,'',12,point_M,0,2001))
      ELSE pg0:=Nil;
  IF (pg0<>Nil) AND (pg0^.X=MIL) THEN NNi:=-1;{intersection non définie}
  IF (Mch2^.pt3=-2) OR (Mch1^.pt3=-2) or (fonc=gomme) THEN NNi:=-1; {ajout JL 10/7/94}
  IF (pg0<>Nil) THEN dispose(pg0,done);
   END;
    IF NNo=-1 THEN Mch1:=Nil;
    IF NNi=-1 THEN Mch2:=Nil;

END;

procedure Annule_entree(n:INTEGER); BEGIN

points^.AtFree(points^.count-1); {libere debut de bloc inutile}
No_collect:=Points^.count;
AVERT(n);

END;

procedure Kase_Fonc(Marquable:BOOLEAN;DC:HDC); VAR n1,n2,nk,Mkr,Gr0,

   Teta0,Teta1,poly,index,eta: INTEGER;
  Mass,x,y : REAL;
      MPt7 : Pdpoint;
       Vieux_flag:BOOLEAN;

procedure Aire_de_base; BEGIN

  Dess_Gomme(DC); Mpt4^.Draw(DC);Dess_norm(DC);
  index:=points^.indexof(Mpt4);
  vire_element(index);  {deviennent inutilisables : l'aire}
  vire_element(index-1); {et le début de bloc}
  points^.AtFree(points^.count-1); {libere debut de bloc inutile}
  No_collect:=points^.count;

END;

procedure segment_de_base; BEGIN

 Sauve_Vector(Ni,No,0,fonc,0,No);
 mass:=Points^.count*100+fonc;{permet de mémoriser dans la masse
        de chaque segment le premier segment  de la forme complexe
        et dans Ang la fonction quadri: parallelo ou carre ect.}  
 Sauve_Figure(Ni,points^.count-1,No,0,segment,0,mass);{segment de base du quadri}
 Fig.Trace(DC,-1,0,segment);{effacer avant de réafficher}
 Dess_Norm(DC);Fig.Draw(DC); {pour réafficher le bon!}

END; procedure translation_finale(k:BYTE); BEGIN {k=2 pour parallelo et carré qui contiennent deux objets de moins que les autres}

 Sauve_Vector(Points^.Count-1,Ni,0,fonc,0,No);
 Sauve_Figure(points^.count-2,points^.count-1,Ni,0,segment,0,mass);
 Fig.Draw(DC);
        {on translate du vecteur points^.count-4 d'origine points^.count-4}
 Trace_Sauve_Pt(DC,points^.count-3,points^.count-6+k,0,Epaiss,Translat,color,0,0);
 Sauve_Vector(Points^.Count-4,Points^.Count-1,0,fonc,0,No);
 Sauve_Figure(points^.count-5,points^.count-1,Points^.count-2,0,segment,0,mass);
 Fig.Draw(DC);
 Sauve_Vector(No,points^.count-3,0,fonc,0,No);
 Sauve_Figure(No,points^.count-1,points^.count-4,0,segment,0,mass);
        {Fig.Draw(DC);}
 emplir_Ete_Trace(1);
END;
procedure finale_triangle;
BEGIN
  Sauve_Vector(Ni,points^.count-1,0,fonc,0,No);
  Sauve_Figure(Ni,points^.count-1,points^.count-2,0,segment,0,mass);
  fig.draw(DC);
  Sauve_Vector(No,points^.count-3,0,fonc,0,No);
  Sauve_Figure(No,points^.count-1,points^.count-4,0,segment,0,mass);
END;

BEGIN

    CASE fonc OF
     Bissectrice:
      BEGIN
       Nj:=Cherche_pt_commun(No,Ni,DC);
IF Nj=-1 THEN BEGIN Annule_entree(46); Exit END;
Teta1:=0;
       {on commence par forcer Ni à être plus grand que No}
IFNo>NiTHENBEGINTeta1:=No;No:=Ni;Ni:=Teta1; END;
IF Teta1=0 THEN Teta :=Fais_Delta_Bissect(Nj,Xoo,Yoo,Xo,Yo)
           ELSE Teta :=Fais_Delta_Bissect(Nj,Xo,Yo,Xoo,Yoo);
Teta0:=Teta;
IF M_Angle THEN
BEGIN  { pour mettre une marque ou la retirer -}
        {vect.init pour récupérer le R0 dans fais_XA}
 Vect.init(No,Ni,0,Teta,Epaiss,pointill,color,'a',0,mark_angle,0,0);
 Nk:=Cherche_Angle(No,Ni,R0);
 IF Nk<>-1 THEN
        BEGIN
  Emplir_ete_Trace(1);
  TRACEtout(Dc,TRUE);
         IF Mpt4^.Gr=Mark_Angle THEN n1:=Nul_Angle
    ELSE n1:=Mark_Angle;
         Mpt4^.Gr:=n1; 
  Mpt3:=Points^.At(Nk+1);
  Mpt3^.Gr:=n1;      Mpt3^.c:=Color;
  Mpt3^.p:=Pointill; Mpt3^.E:=Epaiss;
  IF Avec_Degres THEN Mpt3^.masse:= Ray_ang
   ELSE Mpt3^.masse:=-Ray_ang;
  points^.AtFree(points^.count-1); {libere debut de bloc inutile}
         No_collect:=points^.count;
  Exit;
 END;
 n1:= MarK_Angle;n2:=n1;Mass:=Ray_Ang;
 IF NOT(Avec_degres) THEN Mass:=-Mass;
END
ELSE BEGIN n1:= bissectrice;n2:=droite;Mass:=1; END;
 Vect.init(No,Ni,0,Teta0,Epaiss,pointill,color,'a',0,n1,0,0);
 Sauve_Vector(No,Ni,Teta,n1,0,No);
 Sauve_figure(Nj,Points^.count-1,Nj,0,n2,0,Mass);
      END;
   Pinceau: 
      BEGIN
        Trace_Sauve_Pt(Dc,Xo,Yo,Points^.count-1,Epaiss,pinceau,color,0,0);
       force_Xor:=TRUE;Deplace_Xor:=FALSE;
      END;
    TriangleE:
      BEGIN
        segment_de_base;
 Trace_Sauve_Pt(DC,No,Ni,-600,Epaiss,rotat,color,0,0);
        finale_triangle;
      END;
    TriangleI:
      BEGIN
        segment_de_base;
  Sauve_Vector(Ni,No,0,cercle,360,Ni);  {vecteur pour le rayon du cercle}
 Sauve_Figure(Ni,points^.count-1,No,0,cercle,0,1); {cercle de centre Ni par No}
        Trace_Sauve_Pt(DC,Points^.count-1,500,0,Epaiss,Point_M,Color,0,0);
        finale_triangle;
      END;
    TriangleR:
      BEGIN
        segment_de_base;
 Sauve_Vector(points^.count-1,Ni,0,perpend,0,Ni);
 Sauve_Figure(Ni,points^.count-1,Ni,0,droite,0,0); {droite perpendiculaire par Ni}
        Trace_Sauve_Pt(DC,Points^.count-1,-1.5,0,Epaiss,Point_M,Color,0,0);
        finale_triangle;
      END;
    losange:
      BEGIN
        segment_de_base;
 Sauve_Vector(Ni,No,0,cercle,360,Ni);  {vecteur pour le rayon du cercle}
 Sauve_Figure(Ni,points^.count-1,No,0,cercle,0,1); {cercle de centre Ni par No}
        Trace_Sauve_Pt(DC,Points^.count-1,600,0,Epaiss,Point_M,Color,0,0);
        {puis on place le point sur le cercle}
        Translation_finale(0);
    END;
    rectang:
      BEGIN
        segment_de_base;
 Sauve_Vector(points^.count-1,Ni,0,perpend,0,Ni);
 Sauve_Figure(Ni,points^.count-1,Ni,0,droite,0,0); {droite perpendiculaire par Ni}
        Trace_Sauve_Pt(DC,Points^.count-1,-1.5,0,Epaiss,Point_M,Color,0,0);
        {puis on place le point sur la droite}
        Translation_finale(0);
     END;
    carre:
      BEGIN
        Segment_de_base;
        {Sauve_vector(0,0,0,0,0,0);Sauve_vector(0,0,0,0,0,0);
        on fabrique deux objets inutiles pour s'aligner sur les autres quadri}
 Trace_Sauve_Pt(DC,No,Ni,-900,Epaiss,rotat,color,0,0);
        {on fait l'image dans la rotation d'angle 90 centre No de Ni}
        Translation_finale(2);
     END;
    parallelo:
      BEGIN
        segment_de_base;
       x:=xo;y:=yo;
        TOURNE_R(x,y,Dist(Xo-xoo,Yo-yoo),Angle(xo-xoo,yo-yoo)+600,1);
        {on fait tourner de 120° et on multiplie ensuite par 1.6, donc}
        {on évite le rectangle et le losange}
 Trace_Sauve_Pt(DC,xo+1.6*(x-xo),yo+1.6*(y-yo),0,Epaiss,0,color,0,0);
        Translation_finale(2);
     END;
    Sigma_Vect:
      BEGIN
 Trace_Sauve_Pt(DC,xo,yo,0,Epaiss,0,color,0,0);
        Sauve_Vector(No,Ni,0,fonc,0,No);
 Trace_Sauve_Pt(DC,Points^.Count-2,Points^.Count-1,
                                           0,Epaiss,fonc,color,0,0);
 Sauve_figure(Points^.Count-3,Points^.count-2,
                               Points^.count-1,0,Vecteur,0,1);
        Bouge_Vecteur:=TRUE;
  No:=Points^.Count-4; Mpt1:=Points^.At(No);
        Ni:=No;point_actif:=No;
 emplir_Ete_Trace(0);
     END;
     Prod_Vect:
      BEGIN
 Trace_Sauve_Pt(DC,xo,yo,0,Epaiss,0,color,0,0);
 Sauve_Vector(No,No,0,fonc,coeff_vect,No);
 Trace_Sauve_Pt(DC,Points^.Count-2,Points^.Count-1,
        0,Epaiss,fonc,color,0,0);
 Sauve_figure(Points^.Count-3,Points^.count-2,
   Points^.count-1,0,Vecteur,0,1);
 Bouge_Vecteur:=TRUE;
   No:=Points^.Count-4; Mpt1:=Points^.At(No);
  Ni:=No;point_actif:=No;
 emplir_Ete_Trace(0);
     END;
     Sym_Centrale,Sym_Axiale,Translat,Rotat,projection,Homotetie:
      BEGIN
       Index:= Points^.IndexOf(Mpt1);mass:=Mpt1^.masse;
       IF corrige_quadri(Index,TRUE) THEN poly:=8 ELSE poly:=1;
       {Poly=8 indique un quadrilatère}
       While poly>0 DO
       BEGIN
            IF poly=8 THEN Mpt1:=points^.at(Index);
            IF poly=6 THEN Mpt1:=points^.at(Index+Q1);
            IF poly=4 THEN Mpt1:=points^.at(Index+Q2);
            IF poly=2 THEN Mpt1:=points^.at(Index+Q3);
             IF mpt1^.mark=1 THEN mpt1^.mark:=0;{ici pour les objets quadri}
            {on refabrique la masse des segment pour pouvoir récupérer le premier du quadri}
     IF (fonc=Projection) AND (Mpt1^.Gr=Cercle)
    THEN BEGIN Gr0:=Nul_Angle; annule_entree(18) END
    ELSE Gr0:=Mpt1^.GR;
     IF marquable THEN mkr:=1 ELSE Mkr:=0;  {on est en construction enchainées}
     IF Fonc=Rotat THEN Teta:=Rot_Ang ELSE Teta:=0;
     IF Fonc=Homotetie THEN Teta:=ROUND(Delta_homot*100);
     IF Fonc=Projection THEN Teta:=N_proj;
            IF (Mpt1^.gr=courbe_aff) THEN IF (fonc<>translat) THEN Avert(114) ELSE
             BEGIN
              IF (Mpt1<>Nil) AND (Mpt2<>Nil) AND (Mpt2^.gr=vecteur) THEN eta:=Mpt1^.ang ELSE eta:=0;
              IF eta=1 THEN {tranlaté d'une courbe dans pt3 on met No, la courbe et Ni, le vecteur}
               BEGIN
         fig.init(0,5,No*1000+Ni,eta,Epaiss,pointill,color,Mpt1^.nm,0,courbe_aff,0,1);
         Points^.Insert(New(PDFigures,Init(0,5,No*1000+Ni,eta,epaiss,pointill,color,Mpt1^.nm,0,courbe_aff,0,1)));
                courbe_modif:=TRUE;
                Tracetout(DC,FALSE);
                No_collect:=Points^.count;
                courbe_modif:=FALSE;
                Exit;
               END;
             END
            ELSE
     IF (Mpt1^.pt3=-2)  THEN N2:=est_Ce_Image(DC,No,Ni,Teta,fonc,mkr)
          ELSE
         BEGIN
                 {la fonction est_ce_image permet d'envisager deux cas:}
                 {si ce point existe déjà on en récupère l'indice en sortie}
                 {sinon on créé un nouveau point et on renvoie son indice}
          N2:=est_Ce_Image(DC,Points^.IndexOf(Mpt1^.No_1),Ni,Teta,fonc,0);
          N1:=est_Ce_Image(DC,Points^.IndexOf(Mpt1^.No_3),Ni,Teta,Fonc,0);
           Sauve_Vector(Points^.IndexOf(Mpt1^.No_2),Ni,Teta,fonc,Mpt1^.No_2^.Masse,No);
                 IF (poly=8) AND (Mpt1^.gr=segment) AND (QuadriSort_fonc(Mpt1^.masse)) THEN
                       mass:=points^.count*100+sort_fonc(Mpt1^.masse);
                 {la première fois on mémorise le premier segment du bloc quadri}
                 {poly=8 n'impliquant que les quadris bien sur!!!}
           Sauve_figure(N2,Points^.count-1,N1,Teta,Gr0,mkr,mass);
                END;
       poly:=poly-2;
       IF (poly=2) AND (Q2=Q3) THEN poly:=0; {on saute poly=2 pour les triangles si q2=q3}
       END;
IF NOT(Marquable) THEN TRaceTout(Dc,FALSE);
      END;
     gof:
      BEGIN
       IF (No=-1) OR (Ni=-1) OR (Mpt1^.gr<>Courbe_aff) OR (Mpt2^.gr<>Courbe_Aff) THEN Annule_Entree(108)
       ELSE
        BEGIN
         {c'est en fait une courbe dont le nom (no+ni) est fait dans fais_xa}
         {-18 sur pt3 pour repérer que c'est un gof quand nécessaire}
  fig.init(No,Ni,-18,1,Epaiss,pointill,color,'rien',0,courbe_aff,0,1);
  Points^.Insert(New(PDFigures,
       Init(No,Ni,-18,1,
   epaiss,pointill,color,'rien',0,courbe_aff,0,1)));
        Vieux_flag:=Courbe_modif;courbe_modif:=TRUE;
         Fig.Draw(DC);
         Courbe_modif:=Vieux_flag;
         No_collect:=points^.count;
        END;
      END;
     Lieu_point:
      BEGIN
       IF (No=-1) OR (Ni=-1) OR (Mpt1^.pt3<>-2) OR (Mpt2^.pt3<>-2)
           OR (Mpt2^.gr<>point_M) OR (Mpt2^.P=3)  THEN  Annule_entree(97)
                         ELSE Trace_sauve_pt(DC,No,Ni,0,Epaiss,Lieu_point,color,0,0);
      END;
     Inters:
      BEGIN
       IF (No=-1) OR (Ni=-1) OR (Mpt1^.gr<>Courbe_Aff) OR (Mpt2^.gr<>courbe_Aff)
                         THEN  annule_entree(108)
                         ELSE
        BEGIN
           { Points^.Insert(New(PDVector ,Init(No,Ni,0,0,0,0,0,'N1',0,Inters,0,0)));}
     Sauve_Vector(No,Ni,0,Inters,0,No); {fais_xa est bloqué dans init}
          FOR n1:=1 TO  10 DO  {fabrique 10 cases pour recevoir les inters éventuelles}
             Points^.Insert(New(PDpoint,Init(0,0,-2,0,Epaiss,1,color,'',12,inters,0,2001)));
          No_collect:=Points^.count;
        END;
      END;
    { AireQ:
       BEGIN
        IF cherche_aireQ(No,Ni) 
         THEN  Aire_de_base
         ELSE Trace_Sauve_Pt(DC,No,Ni,0,Epaiss,fonc,color,0,0);
       END;}
     Aire,AireQ:  {pour quadri et triangles}
      BEGIN
       index:=sort_No(Mpt1^.masse);
       IF (Mpt1^.pt3<>-2) AND (corrige_quadri(index,TRUE)) THEN
         BEGIN
           IF cherche_aire(index) {récupère aussi le pointeur Mpt4}
              THEN aire_de_base
              ELSE Trace_Sauve_Pt(DC,index,index+q2,0,Epaiss,Aire,color,0,0);
                  {index pour récupérer A et index+q1 pour récupérer C}
         END
       ELSE
        IF fonc=AireQ THEN
         BEGIN
            IF cherche_aireQ(No,Ni)
               THEN  Aire_de_base
               ELSE Trace_Sauve_Pt(DC,No,Ni,0,Epaiss,fonc,color,0,0);
         END
        ELSE
         BEGIN
            IF cherche_aireT(No,Ni) {récupère aussi le pointeur Mpt4}
             THEN Aire_de_base
             ELSE Trace_Sauve_Pt(DC,No,Ni,0,Epaiss,fonc,color,0,0);
         END;
      END;
     Milieu:
      BEGIN
IF L_segment THEN
BEGIN
 IF (Mpt1^.Gr=Segment) OR (Mpt1^.gr=Vecteur)
                            THEN Nj:=Cherche_Segment(Mpt1^.pt1,Mpt1^.pt3)
                     ELSE Nj:=Cherche_Segment(No,Ni);
        IF Nj<>-1 THEN
  BEGIN
   Emplir_Ete_Trace(1);
   TRACEtout(Dc,TRUE);
   IF Mpt4^.Gr=Mark_Seg  THEN n1:=Nul_Angle
                                ELSE n1:=Mark_Seg;
   Mpt4^.Gr:=n1; Mpt4^.C:=Color;
  Mpt4^.P:=Pointill;Mpt4^.E:=Epaiss;
   IF Avec_Degres THEN Mpt4^.Ang:=Long_Seg
          ELSE Mpt4^.Ang:=-Long_Seg;
   TRACEtout(Dc,FALSE);
   points^.AtFree(points^.count-1); {libere debut de bloc inutile}
          No_collect:=Points^.count;
   Exit;
         END;
       END;
IF L_Segment THEN BEGIN n1:=Mark_Seg ; n2:=Pointill END
      ELSE BEGIN n1:=Milieu   ; n2:=0        END;
IF (Mpt1^.Gr=Segment) OR (Mpt1^.gr=Vecteur) AND (L_Segment) THEN
   BEGIN
     No:=ROUND(Mpt1^.pt1);
            Ni:=Mpt1^.pt3;
   END;
IF (No<>Ni) OR (Mpt1^.gr=Segment) or (Mpt1^.gr=vecteur)
                 THEN Trace_Sauve_Pt(DC,No,Ni,0,Epaiss,n1,color,0,0)
   ELSE points^.AtFree(points^.count-1); {libere debut de bloc inutile}
       No_collect:=points^.count;
      END;
     Perpend,parall:
      BEGIN
       {Nj pointe sur le point invisible posé sur la courbe}
       IF (No<>-1) AND (Mpt1^.gr=Courbe_Aff) THEN Sauve_Vector(No,Nj,0,fonc,0,No)
                                      ELSE Sauve_Vector(No,Ni,0,fonc,0,No);
       Sauve_Figure(Ni,points^.count-1,Ni,0,droite,0,1);
       Fig.Trace(DC,-1,0,fonc);{effacer avant de réafficher}
        {(Ni=points^.count-3) lorsque l'on vient de créer un point libre}
      IF (Ni=points^.count-3) AND (passe_par_le_point(points^.count-1,Ni))  THEN
        BEGIN
   points^.AtFree(points^.count-1); {libere debut de bloc inutile}
          points^.AtFree(points^.count-1); {libere la figure}
          Mpt2:=points^.at(Points^.count-1);{se placer sur le point libre créé}
          Dess_gomme(DC);Mpt2^.Draw(DC);Dess_norm(DC);{pour l'effacer} 
          points^.AtFree(points^.count-1); {et le détruire}
   Sauve_Vector(No,Ni,0,fonc,0,No);
          Sauve_Figure(Ni,points^.count-1,Ni,0,droite,0,1);
        END;
      END;
     ELSE  {cercle,segment et droites}
 BEGIN
   IF fonc=Cercle THEN Mass:=Angle_Arc ELSE mass:=0;
          {grosse modif ici : fonc en lieu de 0}
          Sauve_Vector(No,Ni,0,fonc,mass,No);
          If Fonc=Cercle THEN Mass:=Ratio ELSE Mass:=0;
   Sauve_Figure(No,points^.count-1,Ni,0,fonc,0,mass);
          IF NOT(Def_REct) THEN Fig.Trace(DC,-1,0,fonc);
        END
     END;

END; END.

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.

Unité Geom-app

L'unité Geom_app contient une partie des outils qui permettent de manipuler les objets géométriques. Ce sont les symétries les translations, etc. Rappelons que toutes ces procédures sont téléchargeables sur le site des ateliers de géométrie en licence libre. Qui sont exploitées en classe pour expliquer l'égalité des angles sur le rebond sur les bandes d'un billard

unit Geom_app;

Interface (*$DEFINE VERSION_FR *)

uses Strings, WinTypes, WinProcs,Uannul, WinDos, WObjects,

      StdDlgs,ole,oletypes,V_courbe,server,TypKonst;

TYPE

 PApropos = ^TApropos;
 TApropos = object(TDlgWindow)
      constructor init(AParent: PWindowsObject);
destructor  Done;       virtual;
 end;

Type

 TDeviceMode = procedure(HWindow: HWnd; Module: THandle;
   DeviceName, OutputName: PChar);
 TExtDeviceMode =
   function(HWindow: HWnd; HDriver: THandle; DevModeOutput: PDevMode;
     DeviceName, OutputName: PChar; DevModeInput: PDevMode;
     Profile: PChar; Mode: Word): Integer;

type

 PGeomapplication = ^TgeomApplication;
 TGeomApplication = object(TApplication)
   Server       : POleServerObj;
   cfNative     : TOleClipFormat;
   cfOwnerLink  : TOleClipFormat;
   cfObjectLink : TOleClipFormat;
   procedure InitInstance; virtual;
   procedure CreateServer; virtual;
   procedure Wait(var WaitFlag: Boolean); virtual;
   function  RegisterClipboardFormats: Boolean; virtual;
   Procedure Error(ErrorCode: Integer); virtual;
 end;

type

 PGeomWindow = ^TGeomWindow;
 TGeomWindow = object(TWindow)
   Xi,Yi,V_Xcur,V_Ycur        : WORD;
   DlgApropos :PApropos;
   {Démo version}

{ DlgDemo :PDemo;}

   {Démo version}
   constructor Init(AParent: PWindowsObject; ATitle: PChar);
   destructor Done; virtual;
   procedure Fichier_Primaire(VAR Msg: Tmessage);Virtual wm_first+wm_MbuttonUp;
   procedure WmSize (Var Msg: Tmessage); virtual wm_first+wm_size;
   procedure GETWindowClass(Var AWndClass:Twndclass); virtual;
   procedure Paint(PaintDC: HDC; var PaintInfo: TPaintStruct); virtual;
   procedure DefCommandproc(var Msg: TMessage); virtual;
   function  CanClose:BOOLEAN; virtual;
   procedure ShapeChange(ENTREE:BOOLEAN); virtual;
   function  SaveChangesPrompt: TFileIoStatus; virtual;
   procedure WMLButtonDown(var Msg: TMessage); virtual wm_First + wm_LButtonDown;
   procedure WMRButtonDown(var Msg: TMessage); virtual wm_First + wm_RButtonDown;
   {procedure WMmousemove(var Msg: TMessage); virtual wm_First + wm_MouseMove;}
   procedure FaisBarre;
   procedure FaisName(NewName : Pchar);
   {Modif 004 Stef 06/07/94}
   procedure CMFileUpdate(var Msg: TMessage);virtual cm_First + id_UpdateVEC;
   procedure CMFileUpdateFond(var Msg: TMessage);virtual cm_First + id_UpdateBIT;
   procedure AvecMessageDerreur(Var Msg: Tmessage);virtual cm_first + id_Messagederreur;
   {Modif 004 Stef 06/07/94}
   procedure Wmcreate (Var Msg:Tmessage);virtual wm_First+Wm_Create;
   procedure Quitter(var Msg: TMessage); virtual cm_First + id_Quitte;
   procedure FileNew(var Msg: TMessage); virtual cm_First + Efface_le;
   procedure FileOpen(var Msg: TMessage);virtual cm_First + Charge;
   procedure FileSave(var Msg: TMessage);virtual cm_First + sauve;
   procedure Importe(var Msg: TMessage);virtual cm_First + id_Importe;
   procedure Imagiciel(var Msg: TMessage);virtual cm_First + id_Imagiciel;
   procedure MemoriseF(var Msg: TMessage);virtual cm_First + id_memorise;
   procedure Restitue(var Msg: TMessage);virtual cm_First + id_restitue;
   procedure Restitue_les_points(var Msg: TMessage);virtual Wm_First + Wm_Clear;
   procedure FileSaveAs(var Msg: TMessage);virtual cm_First + sauvesous;
   procedure Imprimer(var Msg: TMessage);virtual cm_First + Imprim;
   {procedure ImprimerF(var Msg: TMessage);virtual cm_First + Id_ImprimeF;}
   procedure Imprimer_Zone(var Msg: TMessage);virtual cm_First + Imp_Zone;
   {procedure Imprimer_ZoneF(var Msg: TMessage);virtual cm_First + Imp_ZoneF;}
   procedure configurer(var Msg: TMessage);virtual cm_First + Configure;
   procedure Av_lettres(Var Msg: Tmessage);virtual cm_first + avecLettres;
   procedure Raffraich(Var Msg: Tmessage);virtual cm_first + id_Raff;
   {procedure Reduite(Var Msg: Tmessage);virtual cm_first + id_reduc;}
   procedure Av_Masses(Var Msg: Tmessage);virtual cm_first + avecMasses;
   procedure Av_Fond(Var Msg: Tmessage);virtual cm_first + id_fond;
   {procedure Aff_long(Var Msg: Tmessage);virtual cm_first + Aff_Longs;}
   procedure tangenteC(Var Msg: Tmessage);virtual cm_first + id_tangente;
   {procedure Aff_Coord(Var Msg: Tmessage);virtual cm_first + Aff_coords;}
   procedure Aff_CoordsP(Var Msg: Tmessage);virtual cm_first + Aff_coordP;
   procedure detruit(Var Msg: Tmessage);virtual cm_first + detruire;
   procedure Nettoie(VAr Msg: Tmessage);virtual cm_first+ R_a_Zero;
   procedure Remet_Objects(VAr Msg: Tmessage);virtual cm_first+Remet_Obj;
   procedure Remet_Dernier(VAr Msg: Tmessage);virtual cm_first+id_dernier;
   {procedure Finesse(Var Msg: Tmessage);virtual cm_first + Fine;}
   procedure Lie(Var Msg: Tmessage);virtual cm_first + lier;
   procedure EtatPoint(Var Msg: Tmessage);virtual cm_first + id_etat_point; {modif JL 6/7/94}
   procedure MasseBary(Var Msg: Tmessage);virtual cm_first + id_masse; {modif JL 6/7/94}
   procedure Inters_Courbes(Var Msg: Tmessage);virtual cm_first + id_inters; {modif JL 6/7/94}
   procedure LieuPoint(Var Msg: Tmessage);virtual cm_first + id_lieu_point; {modif JL 6/7/94}
   procedure Pas_Lieu(Var Msg: Tmessage);virtual cm_first + id_pas_point; {modif JL 6/7/94}
   procedure EtatCoul(Var Msg: Tmessage);virtual cm_first + id_couleur; {ajout JL 10/7/94}
   procedure Coef_Homot(Var Msg: Tmessage);virtual cm_first + Rap_Homot;
   procedure Ang_Rot(Var Msg: Tmessage);virtual cm_first + Angle_Rot;
  { procedure Bary_Masse(Var Msg: Tmessage);virtual cm_first + Id_Bary;}
   procedure Coeff_vecto(Var Msg: Tmessage);virtual cm_first + id_coeff_vect;
   procedure Angle_D(Var Msg: Tmessage);virtual cm_first + id_Angle_Arc;
   procedure Unite_X(Var Msg: Tmessage);virtual cm_first + id_Unitex;
   procedure Unite_Y(Var Msg: Tmessage);virtual cm_first + id_Unitey;
   procedure Approche(Var Msg: Tmessage);virtual cm_first + id_approche;
   procedure Normale(Var Msg: Tmessage);virtual cm_first + id_normale;
   procedure Eloigne(Var Msg: Tmessage);virtual cm_first + id_eloigne;
   procedure Axe_Proj(Var Msg: Tmessage);virtual cm_first + Direct_Proj;
   procedure L_Seg(Var Msg: Tmessage);virtual cm_first + long_Segment;
   procedure Deg1(Var Msg: Tmessage);virtual cm_first + id_deg1;
   procedure Mes1(Var Msg: Tmessage);virtual cm_first + id_mes1;
   procedure Mes2(Var Msg: Tmessage);virtual cm_first + id_mes2;
   procedure Mes3(Var Msg: Tmessage);virtual cm_first + id_mes3;
   procedure M_Ang(Var Msg: Tmessage);virtual cm_first + Mes_Angle;
   procedure M_MAng(Var Msg: Tmessage);virtual cm_first + id_Mangle;
   procedure M_RAng(Var Msg: Tmessage);virtual cm_first + id_Rangle;
   procedure M_Aire(Var Msg: Tmessage);virtual cm_first + cm_Aire;
   procedure M_AireQ(Var Msg: Tmessage);virtual cm_first + cm_AireQ;
   procedure M_Seg(Var Msg: Tmessage);virtual cm_first + id_Lseg;
   procedure M_RSeg(Var Msg: Tmessage);virtual cm_first + id_Rseg;
   procedure Par_Defaut(Var Msg: Tmessage);virtual cm_first + Param_Defaut;
   procedure Pol_Defaut(Var Msg: Tmessage);virtual cm_first + Id_POL_defaut;
   procedure Quelle_Zone(Var Msg: Tmessage);virtual cm_first + Def_Zone;
   procedure Copie_Zone(Var Msg: Tmessage);virtual cm_first + Zone;
   procedure On_Colle(Var Msg: Tmessage);virtual cm_first + id_coller;
   procedure vire_Corbeille(Var Msg: Tmessage);virtual cm_first +vide_Corb;
   procedure Trame(Var Msg: Tmessage);virtual cm_first + id_trame;
   procedure Axes(Var Msg: Tmessage);virtual cm_first + id_Axes;
   procedure graduations(Var Msg: Tmessage);virtual cm_first + id_graduat;
   procedure Cachees(Var Msg: Tmessage);virtual cm_first + id_cachees;
   procedure derivons(Var Msg: Tmessage);virtual cm_first + id_derivee;
   procedure integrons(Var Msg: Tmessage);virtual cm_first + id_primitive;
   procedure composons(Var Msg: Tmessage);virtual cm_first + id_composee;
   procedure nulle_en_zero(Var Msg: Tmessage);virtual cm_first + id_nulle_en;
   procedure Quelle_Affine(Var Msg: Tmessage);virtual cm_first + Courbe_Affi;
   procedure Quelle_Polaire(Var Msg: Tmessage);virtual cm_first + Courbe_Pol;
   procedure Quelle_Param(Var Msg: Tmessage);virtual cm_first + Courbe_param;
   procedure Macro_N(No:BYTE);virtual;
   procedure Trace_Activee(Var Msg: Tmessage);virtual cm_first + id_Trace;
   procedure Const_enchainee(Var Msg: Tmessage);virtual cm_first + id_Enchaine;
   procedure Anal_Dir(Var Msg: Tmessage);virtual cm_first + id_anal_dir;
   procedure Anal_Tri(Var Msg: Tmessage);virtual cm_first + id_anal_Tri;
   procedure Anal_Qua(Var Msg: Tmessage);virtual cm_first + id_anal_qua;
   procedure Anal_Etat(Var Msg: Tmessage);virtual cm_first + id_Etat;
   procedure Anal_Histo(Var Msg: Tmessage);virtual cm_first + id_HistoG;
   procedure Histo_tri(Var Msg: Tmessage);virtual cm_first + id_Histo_tri;
   procedure PointXY(Var Msg: Tmessage);virtual cm_first + id_PtXY;
   procedure EquationAff(Var Msg: Tmessage);virtual cm_first + id_AxplusB;
   procedure InTexteA(Var Msg: Tmessage);virtual cm_first + id_TexteA;
   procedure APROPOS(VAR Msg:Tmessage);virtual cm_first+id_Help5;
   procedure HelpM(Help_Val:INTEGER);virtual;
   procedure Bouge_deb(Var Msg: Tmessage);virtual cm_first + id_bouge_deb;
   procedure Bouge_fin(Var Msg: Tmessage);virtual cm_first + id_bouge_fin;
   procedure Bouge_exe(Var Msg: Tmessage);virtual cm_first + id_bouge_exe;
   procedure Bouge_cont(Var Msg: Tmessage);virtual cm_first + id_bouge_cont;
   procedure Bouge_vit(Var Msg: Tmessage);virtual cm_first + id_bouge_vit;
   procedure Bouge_Det(Var Msg: Tmessage);virtual cm_first + id_bouge_det;
   procedure ToucheUp(VAR Msg:Tmessage);virtual Wm_first+Wm_KeyUp;
   procedure ToucheDown(VAR Msg:Tmessage);virtual Wm_first+Wm_KeyDown;
   procedure ToucheSysDown(VAR Msg:Tmessage);virtual Wm_first+Wm_SysKeyDown;
   procedure ToucheSysUp(VAR Msg:Tmessage);virtual Wm_first+Wm_SysKeyUp;
   procedure ToucheM(VAR Msg:Tmessage);virtual Wm_first+WM_ENTERIDLE;
   procedure Avert(n,I:INTEGER);
   procedure Zoom(n:BYTE);
   procedure SaveFile;
   function  LoadFile:BOOLEAN;virtual cm_first+cm_load; 
   procedure change_Menu(att:INTEGER;St_or:STRING;Phi:Real;a,b,x:BYTE);
   procedure Macro(N:BYTE);
   procedure Init_Menu_Param;
   procedure FaitMarques_Options;
   procedure Load_OPTIONS;
   {modif du 06/05/94}
   procedure Efface_tout_et_recommence(var Msg: TMessage); virtual cm_First + id_Efface_tout;
 end;

{procedure Aff_Texte(Txt:PCHAR);} {function _LFileSize(F : integer) : longint;} function le_script:BOOLEAN; function Ouvre_aide(n: WORD;VAR cas:INTEGER):STRING; procedure Sortie_imbrication;

VAR

 ExtDeviceMode: TExtDeviceMode;
 Nom_Client      : ARRAY0..128 OF CHAR;
 DlgApropos : PAPROPOS;
 PG_Wind  :PGeomWindow;

{--}

 Implementation

{--}

Uses Outils2,outils1,globales;

{test} procedure TgeomWindow.APROPOS(Var Msg : Tmessage); BEGIN

    DlgAPROPOS := PAPROPOS(Application^.ExecDialog(New(PAPROPOS, init(@Self))));

END;

constructor TApropos.init(AParent: PWindowsObject); {=================================================} begin

 TDlgWindow.init(AParent, 'DLG_APROPOS');

end;

destructor TApropos.Done; begin

    TDlgWindow.Done;

end; {test} {Demo Version} {constructor TDemo.init(AParent: PWindowsObject); begin

 TDlgWindow.init(AParent, 'DLG_DEMO');

end;

destructor TDemo.Done; begin

    TDlgWindow.Done;

end;} {Demo Version}

procedure TGeomApplication.CreateServer; var

{ N        : LongINT;}   
 Strng    : PChar;
 Embedded : Boolean;
 Path     : PChar;
 ServerObj: POleServerObj;
 St1 : String;

begin {Modif 015 Stef 06/07/94}

{ Grise_menu(id_update,TRUE);}
GriseparPosition(TRUE,0,7);

{Modif 015 Stef 06/07/94}

 Strng    := CmdLine;
 Embedded := False;
 Path     := nil;
 if Strng <> nil then
 begin
   while (Strng^ = ' ') and (Strng^ <> #0) do
     inc(Strng);
   if (Strng^ = '-') or (Strng^ = '/') then
   begin
     Embedded := (StrLIComp(@Strng1, Embedding,9) = 0);
     while (Strng^ <> ' ') and (Strng^ <> #0) do
       inc(Strng);
   end;
   while (Strng^ = ' ') and (Strng^ <> #0) do
     inc(Strng);
   if Strng^ <> #0 then
     Path := Strng;
 end
 else
 begin
   Embedded := False;
   Imbrication:=FALSE;
   Path     := nil;
 end;
   St1:=Strpas(StrnG);
   IF pos('Fic_3D',St1)>0 THEN
          BEGIN  {en prévision des passages avec l'atelier 3D}
             Imbrication:=TRUE;
             GriseparPosition(FALSE,0,7);
          END;
 if (Embedded) then
   BEGIN
   CmdShow := sw_Hide;
   Imbrication:=TRUE;

{Modif 016 Stef 06/07/94} { Grise_menu(id_update,FALSE);}

GriseparPosition(FALSE,0,7);

{Modif 016 Stef 06/07/94}

   END;
 if Path <> nil then
  BEGIN   
   New(ServerObj, InitFromFile(@Self, Path));
   StrCopy(filename,Path);
  END
 else
   New(ServerObj, Init(@Self, Embedded));

end;

function TGeomApplication.RegisterClipboardFormats: Boolean; begin

 cfNative    := RegisterClipboardFormat('Native');
 cfOwnerLink := RegisterClipboardFormat('OWnerLink');
 cfObjectLink:= RegisterClipboardFormat('ObjectLink');
 RegisterClipboardFormats :=    (cfNative     <> 0)
                            and (cfOwnerLink  <> 0)
       and (cfObjectLink <> 0);

end;

procedure TGeomApplication.InitInstance; begin

 MainWindow := New(PGeomWindow, Init(nil, DemoTitle));
 MainWindow := MakeWindow(MainWindow);
 if (not TOleServerObj_InitVTbl(HInstance) or
     not TOleDocument_InitVTbl(HInstance) or
     not TGeomOle_InitVTbl(HInstance) )
 then
   Status := olInitVTblError
 else
   if not RegisterClipboardFormats then
     Status := olRegClipError
   else
     CreateServer;
 if MainWindow <> nil then
   MainWindow^.Show(CmdShow)
 else
   Status := em_InvalidMainWindow;

end;

procedure TGeomApplication.Error(ErrorCode: Integer); var

 Strng : PChar;

begin

 Strng := nil;
 if (ErrorCode = olRegClipError) then
 (*$ifndef VERSION_ESP *)
     Strng := 'Erreur Fatale: ne peut enregistrer les formats du presse-papiers ' +
     'Native, OwnerLink et ObjectLink.'
 (*$else *)
         Strng := 'Error fatal: no puede grabar los formatos del pisapapeles' +
'Native, OwnerLink y ObjectLink.'
 (*$endif *)
 else 
   if (ErrorCode = olInitVTBLError) then
     (*$ifndef VERSION_ESP *)

{Trad} Strng := 'Erreur Fatale: impossible de créer la table virtuelle' +

     ' pour les éléments du Serveur OLE';
     (*$else *)
             Strng := 'Error fatal: imposible crear la tabla virtual' +
     ' para los elementos del Servidor OLE';
     (*$endif *)
 if Strng <> nil then
 begin
   MessageBox(0, Strng, DemoTitle, mb_OK or mb_IconStop);
   PostAppMessage(GetCurrentTask, wm_Quit, 0, 0);
 end
 else
   TApplication.Error(ErrorCode);

end;

procedure TGeomApplication.Wait(var WaitFlag: Boolean); var

 Msg         :  TMsg;
 MoreMessages:  Bool;

begin

 MoreMessages := False;
 while not WaitFlag do
 begin
   OleUnblockServer(Server^.ServerHdl, MoreMessages);
   if not MoreMessages then
   begin
     { If there are no more messages in the OLE queue, go to system queue
     }
     if (GetMessage(Msg, 0, 0, 0)) then
     begin
       TranslateMessage(Msg);
       DispatchMessage (Msg);
     end;
   end;
 end;

end;

procedure TGeomWindow.ShapeChange(ENTREE:BOOLEAN); var

 TheFile  : TBufStream;
 DocPtr   : POleDocument;
 ObjectPtr: PGeomOle;
 Msg      : Tmsg;
 Msg0     : Tmessage;
 N        : LongInt;

begin

 DocPtr   := PGeomApplication(Application)^.Server^.Document;
 ObjectPtr:= DocPtr^.OleObject;
 IF ENTREE THEN StrCopy(FileName,'c:\windows\system\memlink') 
 ELSE
  BEGIN
    IF W_Zone<>0 THEN
    BEGIN
      Copy_Zone:=TRUE;Def_REct:=TRUE;
      {SendMessage(Wind,Wm_first+Wm_MButtonDown,0,0);}
             New_paint;
    END;
 { TheFile.Init('c:\windows\system\memlink', stCreate, 1024);
  TheFile.Put(Points);
  TheFile.Put(Video);
  TheFile.Put(Textes);
  TheFile.Write(Filenamebit,sizeof(filenamebit));
  TheFile.Done;}
         Strcopy(filenameciel,filename); {mémoriser l'ancien nom}
         Strcopy(filename,'c:\windows\system\memlink');
         savefile;
         strcopy(filename,filenameciel);
         filenameciel0:=#0;
  END;

end;

procedure Je_Reactive; BEGIN {efface la case active}

IF (NOT(Quel_Axe)) AND (NOT(L_Segment)) AND (NOT(Detruit_Bloc)) AND (NOT(etat_objet))
   AND (NOT(Def_Texte)) AND (NOT(M_Angle)) AND (NOT(Def_Rect))
     THEN Activation(ValXv,ValYv,FALSE);
L_Segment:=FALSE;M_Angle:=FALSE;Def_Texte:=FALSE;Def_Rect:=FALSE;
Quel_Axe:=FALSE;Equation:=FALSE;Detruit_Bloc:=FALSE;Etat_Objet:=FALSE;

END;

{Demo Version} procedure TGeomWindow.CMFileUpdate(var Msg: TMessage); var

 Doc: POleDocument;

begin

 ExportBitmapImage:=FALSE;
 Doc := PGeomApplication(Application)^.Server^.Document;
 ShapeChange(FALSE);
 OleSavedServerDoc(Doc^.ServerDoc);
 Doc^.IsDirty := False;
 Dessin_Change:= False;
 Sortie_imbrication;
 done;

end; {Demo Version}

procedure TGeomWindow.CMFileUpdatefond(var Msg: TMessage); var

 Doc: POleDocument;

begin

ExportBitmapImage:=TRue;
Doc := PGeomApplication(Application)^.Server^.Document;
ShapeChange(FALSE);
OleSavedServerDoc(Doc^.ServerDoc);
Doc^.IsDirty := False;
Dessin_Change:= False;
Sortie_imbrication;
done;

end;

procedure Grise_mini; BEGIN

 Grise_Menu(Remet_Obj,TRUE);
 Grise_Menu(Sauve,TRUE);
 Grise_Menu(Zone,TRUE);
 {Grise_Menu(Vide_Corb,TRUE);}
 Grise_Menu(Imp_Zone,TRUE);
{ Grise_Menu(Imp_ZoneF,TRUE);}
 Grise_Menu(Id_Dernier,TRUE);
 GRise_Menu(id_bouge_exe,TRUE);
 GRise_Menu(id_bouge_cont,TRUE);
 Grise_Menu(id_Bouge_Det,TRUE);
 Grise_Menu(id_bouge_Fin,TRUE);

END;

procedure Grise_Par_Defaut; BEGIN

 Grise_Menu(Param_Defaut,TRUE);
{ Grise_Menu(id_restitue,TRUE);}
 Grise_mini;

END;

procedure TgeomWindow.Macro(N:BYTE); VAR TheText:array0..200 of Char;

   St: STRING200-1;

BEGIN

 Str(n,St);
 {StrCopy(TheText,'');}
 St:= '&'+St+' '+St_Macron;
 StrPcopy(TheText,st);
 ModifyMenu(Attr.Menu,129+N,mf_ByCommand or mf_String
                               ,129+N,TheText)

END;

Procedure TgeomWindow.Change_Menu(Att:INTEGER;St_or:STRING;phi:Real;a,b,x:BYTE); VAR St:String;

   TheText,Txt:ARRAY0..34 OF Char;
   nb :BYTE;
   flag : WORD;

BEGIN

IF x = 1 THEN flag:=mf_ByCommand or mf_String or mf_disabled
         ELSE flag:=mf_ByCommand or mf_String;
IF Att=Id_Bouge_Vit THEN nb:=5 ELSE nb:=3;
IF Att=215 THEN St:=St_or
ELSE
 IF (Att=Id_Bouge_Vit) OR (Att=id_Rseg) OR (Att=id_Rangle) OR (Att=id_pas_point) THEN
     BEGIN Str(Phi:nb:b,St);St:=St_or+'('+st+')'; END
 ELSE
 BEGIN Str(Phi:5:b,St);St:='('+st+')'; END;
 If Att=242 THEN St:='Pas d&e déplacement...   '+St;
 If Att=313 THEN St:='Nulle en :'+St_or;
 StrPcopy(TheText,St);
 IF (Att=214) THEN
 ModifyMenu(Attr.Menu,Att,flag
   or mf_MenuBarBreak,Att,TheText)
    ELSE
 ModifyMenu(Attr.Menu,Att,flag,Att,TheText);
 Grise_Menu(Param_Defaut,FALSE);

END;

procedure TgeomWindow.Init_Menu_Param; VAR Phi :REAL;

   TheTexT:ARRAY0..35 OF Char;

BEGIN

IF Rot_Ang>1800 THEN Phi:=360-Rot_Ang/10
  ELSE Phi:=-Rot_Ang/10;
Change_Menu(id_Rseg,'Longueur en points-écran... ',Long_Seg,3,0,0);
Change_Menu(id_Rangle,'Rayon en points-écran...     ',Ray_Ang,3,0,0);
Change_Menu(214,'',phi,7,1,1);
Change_Menu(216,'',Delta_Homot,6,2,1);
Change_Menu(215,'(ortho)',0,1,1,1);
Change_Menu(217,'',Coeff_Vect,6,2,1);
Change_Menu(id_ValX,'',UniteX,4,0,1);
Change_Menu(id_ValY,'',UniteY,4,0,1);
Change_Menu(id_Val_Arc,'',Angle_Arc,6,0,1);
Change_Menu(id_bouge_vit,'&Temporisation (msec) ',vitesse,6,0,0);
Grise_Menu(Param_Defaut,TRUE);

END;

procedure TGeomWindow.Defcommandproc(var Msg: TMessage); VAR n:INTEGER; begin

 if (Msg.Wparam>260) and (Msg.Wparam<267) THEN
  BEGIN
   n:=Msg.Wparam-260;
   Kelle_fonte(n);
   Raffraichir:=TRUE; Nettoyer:=TRUE; {on doit nettoyer car l'ancienne police non conservée}
   {SendMessage(Wind,Wm_first+Wm_MButtonDown,0,0);}
   New_paint;
   aide_ligne(fonc_aide);
  END
 else
 if (Msg.Wparam>=cm_menu_aide) THEN
     BEGIN
       {Getmenustring(Attr.menu,Msg.Wparam,filescript,fsPathName+1,mf_bycommand);}
       n:=1;
       StrPcopy(filescript,ouvre_aide(Msg.Wparam-cm_menu_aide,n));
       IF le_script THEN New_paint;
     END
 else
 if (Msg.Wparam>900) and (Msg.Wparam<905) THEN
     BEGIN
option_point:=Msg.Wparam-900;
IF option_point=4 THEN avec_points:=FALSE
    ELSE avec_points:=TRUE;
Raffraichir:=TRUE; Nettoyer:=TRUE;
       {SendMessage(Wind,Wm_first+Wm_MButtonDown,0,0);}
       New_paint;
     END
 else
 if (Msg.WParam >id_macro) and (Msg.WParam <=id_macro+5) then
   Macro_n(Msg.WParam-id_macro)
 else
 if (Msg.WParam >=id_HelpD) and (Msg.WParam <=id_Help3) then
   HelpM(Msg.WParam)
 else DefCommandproc(Msg);

end;

procedure TGeomWindow.WmCreate(Var Msg:Tmessage); var

 GWnd: PWindow;

begin

 {dialogue_presente(3);}
 GWnd := New(PGWindow, Init(@Self,Nil));
 Application^.MakeWindow(GWnd);

end;

procedure TgeomWindow.GETWindowClass(Var AWndClass:Twndclass); Begin

  TWindow.GETWindowClass(AWndClass);
  AWndClass.hbrBackground := color_AppWorkspace + 1;
  AwndClass.Hicon := loadIcon(Hinstance,'Icon_02');
  {AWndClass.Style := AWndClass.Style or cs_GlobalClass;}

End;

procedure Est_Ce_Select; BEGIN

 IF Def_rect THEN IF W_zone<>0 THEN Raffraichir:=TRUE
   ELSE
   BEGIN
     Def_rect:=FALSE;
     Fonc:=A_fonc;
     curseur_Fonc ; {remet le bon curseur}
   END;
 {SendMessage(Wind,Wm_first+Wm_MButtonDown,0,0);}
 New_paint;

END;

procedure TgeomWindow.FaitMarques_Options; VAR num: WORD; BEGIN

 IF Deplace_Xor  THEN num:=mf_bycommand OR mf_Checked
   ELSE num:=mf_bycommand OR mf_Unchecked;
 CheckMenuItem(Attr.Menu,Id_Raff,num);
 IF Avec_Lettre THEN num:=mf_bycommand OR mf_Checked
  ELSE num:=mf_bycommand OR mf_Unchecked;
 CheckMenuItem(Attr.Menu,AvecLettres,num);
 IF Avec_Masse THEN num:=mf_bycommand OR mf_Checked
 ELSE num:=mf_bycommand OR mf_Unchecked;
 CheckMenuItem(Attr.Menu,AvecMasses,num);
 IF Avec_Fond  THEN num:=mf_bycommand OR mf_Checked
 ELSE num:=mf_bycommand OR mf_Unchecked;
 CheckMenuItem(Attr.Menu,Id_fond,num);
 IF Liberte  THEN num:=mf_bycommand OR mf_UnChecked  {modif JL 6/7/94}
 ELSE num:=mf_bycommand OR mf_checked;
 CheckMenuItem(Attr.Menu,lier,num);
 {IF Aff_longueurs THEN num:=mf_bycommand OR mf_Checked
   ELSE num:=mf_bycommand OR mf_Unchecked;
 CheckMenuItem(Attr.Menu,aff_Longs,num);
 IF Aff_coordonnees THEN num:=mf_bycommand OR mf_Checked
     ELSE num:=mf_bycommand OR mf_Unchecked;
 CheckMenuItem(Attr.Menu,aff_coords,num);}
 IF Trace_Active   THEN num:=mf_bycommand OR mf_Checked
     ELSE num:=mf_bycommand OR mf_Unchecked;
 CheckMenuItem(Attr.Menu,id_trace,num);
 IF Enchaine       THEN num:=mf_bycommand OR mf_Checked
     ELSE num:=mf_bycommand OR mf_Unchecked;
 CheckMenuItem(Attr.Menu,id_enchaine,num);
 IF degre_precis=1 THEN num:=mf_bycommand OR mf_Checked
     ELSE num:=mf_bycommand OR mf_Unchecked;
 CheckMenuItem(Attr.Menu,id_deg1,num);
 IF Mesure_precis=1 THEN num:=mf_bycommand OR mf_Checked
      ELSE num:=mf_bycommand OR mf_Unchecked;
 CheckMenuItem(Attr.Menu,id_mes1,num);
 IF Mesure_precis=2 THEN num:=mf_bycommand OR mf_Checked
      ELSE num:=mf_bycommand OR mf_Unchecked;
 CheckMenuItem(Attr.Menu,id_mes2,num);
 IF Mesure_precis=3 THEN num:=mf_bycommand OR mf_Checked
      ELSE num:=mf_bycommand OR mf_Unchecked;
 CheckMenuItem(Attr.Menu,id_mes3,num);
 {IF On_Reduit       THEN num:=mf_bycommand OR mf_Checked
      ELSE num:=mf_bycommand OR mf_Unchecked;
 CheckMenuItem(Attr.Menu,id_reduc,num);}
 IF Avec_graduations      THEN num:=mf_bycommand OR mf_UnChecked
            ELSE num:=mf_bycommand OR mf_checked;
 CheckMenuItem(Attr.Menu,id_graduat,num);
 IF Avec_Trame      THEN num:=mf_bycommand OR mf_Checked
      ELSE num:=mf_bycommand OR mf_Unchecked;
 CheckMenuItem(Attr.Menu,id_trame,num);
 IF Avec_Axes       THEN num:=mf_bycommand OR mf_Checked
      ELSE num:=mf_bycommand OR mf_Unchecked;
 CheckMenuItem(Attr.Menu,id_Axes,num);
 IF Courbes_Cachees THEN num:=mf_bycommand OR mf_Checked
      ELSE num:=mf_bycommand OR mf_Unchecked;
 CheckMenuItem(Attr.Menu,id_cachees,num);
 IF AvecMessageErreur THEN num:=mf_bycommand OR mf_Checked
      ELSE num:=mf_bycommand OR mf_Unchecked;
 CheckMenuItem(Attr.Menu,id_Messagederreur,num);
 {pour les quatre options_points}
 FOR num:=1 TO 4 DO CheckMenuItem(Attr.Menu,900+num,mf_bycommand OR mf_Unchecked);
 CheckMenuItem(Attr.Menu,900+option_point,mf_bycommand OR mf_checked);
 Est_ce_Select;
 lie_objet;  {petit carré en haut de la barre pour savoir si point lié}

END;

function MainWndProc(Wnd: Hwnd; Message, WParam: Word;LParam: LongInt): LongInt; export; VAR n:WORD; begin

 Grise_menu(id_coller,TRUE);
 Grise_Menu(Vide_Corb,TRUE);
 if OpenClipboard(Wind) then
  BEGIN
  IF (GetClipBoardData(cf_bitmap)>0) or (GetClipBoardData(cf_metafilepict)>0) THEN
          BEGIN
           Grise_Menu(id_coller,FALSE);
           Grise_Menu(Vide_Corb,FALSE);
          END;
   CloseClipBoard;
  END;
  IF (Wparam<>0) THEN Help_Valeur:=Wparam;
  {récupère l'indice dans déroulant }
  MainWndProc := DefWindowProc(Wnd, Message, WParam, LParam);

end;

procedure TgeomWindow.Fichier_Primaire(Var Msg:Tmessage); BEGIN

IF NOT(Fichier_Prim) THEN
BEGIN
 {if OpenClipboard(Wind) then
  BEGIN
   IF GetClipBoardData(cf_Bitmap)>0
 THEN Grise_Menu(Vide_Corb,FALSE);
   CloseClipBoard;
  END;}
 IF Filename0=#0 THEN Construis_Quadrillage;
 IF (Filename0<>#0) OR (Imbrication) THEN
   BEGIN
      IF Filename0<>#0 THEN loadFile;
      IF Imbrication THEN
        BEGIN
        (*$ifndef VERSION_ESP *)
          StrCopy(Filename,'Sans_nom');
        (*$else *)
          StrCopy(Filename,'Sin_nombre');
        (*$endif *)
   vire_fichier_link;
   isNewFile:=TRUE;
 END;
   END;
 Fichier_Prim:=TRUE;
END;

END;

procedure TgeomWindow.Wmsize(Var Msg : Tmessage); VAR WinPosInfo: Thandle;

   Rect: Trect;
   VAR N:LongINT;

BEGIN

  GetClientRect(Hwindow,Rect);
  ClientX:=Rect.Right;
  ClientY:=Rect.Bottom;
  GetWindowREct(Hwindow,Rect);
  cltx:=Rect.left ;CltW:=Rect.Right-Rect.left;
  clty:=Rect.top  ;CltH:=Rect.Bottom-Rect.top;
  EnableAutocreate;
   IF (Def_Rect) AND (W_Zone<>0) THEN
   BEGIN
   Init_Select_Zone;
Pg:=Points^.At(points^.count-1);
WHILE (Pg^.pt1<>-1) DO
 BEGIN
   points^.AtFree(points^.count-1);
   pg:=Points^.At(points^.count-1);
 END;
 points^.Atfree(points^.count-1);
   END;
MoveWindow(Wind,72,38,clientX-72,clientY-38,TRUE);
InvalidateRect(wind, nil, TRUE);

END;

procedure TGeomWindow.FaisName(NewName: PChar); var

 Name: array0..250 of Char;

begin

 IF imbrication THEN
  BEGIN
   IF (StrComp(NewName,'')=0)

(*$ifndef VERSION_ESP *)

                 THEN StrCopy(Name,'Atelier de Géométrie 96: Sans nom ')
                  ELSE StrCopy(Name,'Atelier de Géométrie 96: ');

(*$else *)

                 THEN StrCopy(Name,'Taller de Geometría: Sin nombre')
                  ELSE StrCopy(Name,'Taller de Geometría: ');

(*$endif *)

   StrCat(Name,NewName);
   StrCat(Name,Nom_client);
  END
 ELSE
  BEGIN

(*$ifndef VERSION_ESP *)

       StrCopy(Name, 'Atelier de Géométrie 96');

(*$else *)

       StrCopy(Name, 'Taller de Geometría');

(*$endif *)

    if StrComp(NewName, '') <> 0 then
      begin
       StrCat(Name, ' - ');
       StrCat(Name, NewName);
      end;
  END;
 IF (NOT(on_scripte)) THEN SetCaption(Name);
 StrCopy(FileName, NewName);

end;

procedure init_fontes; VAR n:BYTE; BEGIN

For n:=1 TO 7 DO Fonten:=0;

END;



procedure les_fontes_de_base(init:BOOLEAN); {TRUE pour charger toutes les fontes} BEGIN

{fonte_par_defaut (hauteur,italique,n° de fonte}
{-12 permet de générer une police de 9 et -11 une police de 8}
IF INIT THEN
 BEGIN
  Fonte_par_defaut(-12,0,1); {fonte N°1 pour les noms de points}
  Fonte_par_defaut(-12,1,2); {fonte N°2 pour les noms d'objets }
  Fonte_par_defaut(-11,0,3); {fonte N°3 pour la graduation des axes}
  Fonte_par_defaut(-11,0,4); {fonte N°4 pour les textes insérés}
  Fonte_par_defaut(-10,0,5); {fonte N°5 pour les mesures}
  Fonte_par_defaut(-11,0,6); {fonte N°6 pour l'aide en ligne}
 END;
Fonte_par_defaut(-11,0,7); {pour les coordonnées souris et longueurs}

END;

procedure les_fontes; BEGIN

IF Fonte6<>0 THEN les_fontes_de_base(FALSE)
               ELSE les_fontes_de_base(TRUE);

END;

constructor TGeomWindow.Init(AParent: PWindowsObject; ATitle: PChar); VAR N:BYTE;

   VAR St:String4;
       Ch1 : Array0..3 OF CHAR;
       Kol : Array0..1 of integer;
       Kol1: Array0..1 of TcolorRef;

begin

 init_fontes;
 Force_Xor   :=FALSE;
 Avec_Lettre  :=FALSE;
 Avec_Trame    :=FALSE;avec_axes:=FALSE;
 avec_graduations:=TRUE;
 Quittons:=TRUE; {pour faire miseàjour à la seule sortie du logiciel}
 On_scripte:=FALSE;
   StrCopy(Nom_macro1,'C:\windows\calc.exe');
   StrCopy(Nom_macro2,'C:\windows\Notepad.exe');
   StrCopy(Nom_macro3,'C:\windows\MSapps\equation\eqnedit.exe');
   StrCopy(Nmacro1,'Calculatrice');
   StrCopy(Nmacro2,'Textes');
   StrCopy(Nmacro3,'Equations');
   FilenameCiel0:=#0;
  StrCopy(Filenameconf,'c:\windows\geom96.ini');
 il_faut_commencer;
 lis_Config;  {récupère force_Xor et ci_dessus}
 TWindow.Init(AParent, ATitle);
 Attr.Menu := LoadMenu(HInstance, 'Menu1');
 No_menu   := Attr.Menu;
  Attr.Style:=ws_OverLappedWindow;
  IF CltW>100 THEN
   BEGIN
    Attr.X:=Cltx  ; Attr.Y:=CltY;
    Attr.W:=CltW  ; Attr.H:=CltH;
   END;
 DefaultProc := @MainWndProc;
 Xi:=0;Yi:=0;
 VALXV  :=-1;
 COlOR_V:=NOIR;
 Blanc_fond   := getsyscolor(color_appworkspace);
 col_bureau   := getsyscolor(k_onze);
 kol0:=color_appworkspace;
 Kol1:=k_onze;
 kol10:=Genie;
 Kol11:=Gris;
 setsyscolors(2,kol,kol1);
 {r2_white := GENIE;}
 VALX_V1:=0;
 BoutonDown:=FALSE;
 Barre    := LoadBitMap(hInstance, 'Dess1');
 Barre0   := LoadBitMap(hInstance, 'Dess10');
 Barre1   := LoadBitMap(hInstance, 'Dess11');
 Barre2   := LoadBitMap(hInstance, 'Dess2');
 Barre3   := LoadBitMap(hInstance, 'Dess3');
 Barre4   := LoadBitMap(hInstance, 'Dess_Ciel');
 Barre5   := LoadBitMap(hInstance, 'Carre');
 Grise_Menu(Sauve,TRUE);
 Les_fontes;
 Curs_Wait:=LoadCursor(0,Idc_Wait);
 Curs_Norm:=LoadCursor(0,Idc_Arrow);
 Curs_Taille:=LoadCursor(0,Idc_Size);
 Curs_Gomme :=LoadCursor(Hinstance,'C_gomme');
 Curs_Main  :=LoadCursor(Hinstance,'C_main');
 curs_stylo :=LoadCursor(Hinstance,'C_Stylo');
 Curs_Select:=LoadCursor(Hinstance,'C_Select');
 curs_Vmini :=LoadCursor(Hinstance,'C_Fmini');
 curs_Fmini :=LoadCursor(Hinstance,'C_Vmini');
 curs_Visons:=LoadCursor(Hinstance,'C_Vison');
 curs_Enr   :=LoadCursor(Hinstance,'C_ENR');
 Points    := New(PCollection, Init(200,50));
 V_Points  := New(PCollection, Init(200,50));
 Video     := New(Pcollection, Init(100,50));
 Textes    := New(Pcollection, Init(3,2));
 {Images    := New(Pcollection, Init(3,2));}
 StreamRegistration;
 Init_Texte(TexteA);
 Initialise;
 Himage:=0;
 FaitMarques_Options;    {les cases cochees}
 Grise_Par_Defaut;       { les cases grisees}
 IsDirty:=FALSE;
 Dessin_Change:=FALSE;
 FOR N:=1 TO 5 DO Macro(n);
  FileName0 := #0;
 init_client;
 PG_wind:=@Self;

end;

destructor TGeomWindow.Done; VAR n: BYTE;

       Kol : Array0..1 of integer;
       Kol1: Array0..1 of TcolorRef;
       Rect : Trect;

begin

 GetWindowREct(Hwindow,Rect);
 cltx:=Rect.left ;CltW:=Rect.Right-Rect.left;
 clty:=Rect.top  ;CltH:=Rect.Bottom-Rect.top;
 done_client;
 DeleteObject(Barre);
 DeleteObject(Barre0);
 DeleteObject(Barre1);
 DeleteObject(Barre2);
 DeleteObject(Barre3);
 DeleteObject(Barre4);
 DeleteObject(Barre5);
 DeleteObject(Region_imp);
 DeleteObject(Image);
 {deleteObject(Crayon);
 deleteObject(V_crayon);}
 DestroyCursor(Curs_Wait);
 DestroyCursor(Curs_Norm);
 DestroyCursor(Curs_Taille);
 DestroyCursor(Curs_Gomme);
 DestroyCursor(Curs_Main);
 DestroyCursor(curs_stylo);
 DestroyCursor(Curs_Select);
 DestroyCursor(curs_Vmini);
 DestroyCursor(curs_Fmini);
 DestroyCursor(curs_Enr);
 DestroyCursor(curs_Visons);
 DestroyMenu(MenA);
 Dispose(Points,Done);
 Dispose(V_Points,Done);
 Dispose(Video,done);
 Dispose(Textes,done);
 {Dispose(Images,done);}
 Tobject.Done;
 TWindow.Done;
 KillTimer(wind,0);
 vire_fichier_memoire;
 Config; {doit enregistrer la fonte6 pour l'aide en ligne}
 {FOR n:=1 TO 6 DO DeleteObject(Fonten);}

{ kol0:=color_appworkspace;

 Kol1:=k_onze;
 kol10:=Blanc_fond;
 Kol11:=col_bureau;
 setsyscolors(2,kol,kol1);}
 {dialogue_presente(1);}

end;

Procedure Sortie_Imbrication; var

 App     : PGeomApplication;
 Doc     : POleDocument;
 Server: POleServerObj;

BEGIN

 IF On_Termine THEN
  BEGIN
   App := PgeomApplication(Application);
   Doc := App^.Server^.Document;
   Server:= App^.Server;
   if OleRevokeServer(Server^.ServerHdl) = ole_Wait_for_Release then
       App^.Wait(Server^.IsReleased);
   {if OleRevokeServerDoc(Doc^.ServerDoc) = ole_Wait_For_Release then
        App^.Wait(Doc^.IsReleased);
    Doc^.ServerDoc := 0;}
  END;           
 On_Termine:=TRUE;

END;

procedure TGeomwindow.Quitter(Var Msg:Tmessage); BEGIN

IF (Canclose) THEN Done;

END;

{Demo Version} function TGeomWindow.SaveChangesPrompt: TFileIoStatus; var

 App     : PGeomApplication;
 Doc     : POleDocument;
 Outcome : Integer;
 Buf     : ChaineC;

begin

 App := PgeomApplication(Application);
 Doc := App^.Server^.Document;
 Outcome := IdYes;
 if (Doc^.DocType = DoctypeEmbedded) AND  (Quittons) THEN
 { then}
   begin

(*$ifndef VERSION_ESP *)

         StrCopy(Buf, 'L''objet incorporé ');
         StrCat (Buf, Doc^.Name);
         StrCat (Buf, ' a changé. Voulez-vous le mettre à jour?');

(*$else *)

         StrCopy(Buf, 'El objeto incorporado');
         StrCat (Buf, Doc^.Name);
         StrCat (Buf, 'ha cambiado. ¿Desea actualizarlo?');

(*$endif *)

     {Outcome := MessageBox(HWindow, Buf, App^.Name, mb_IconQuestion or mb_YesNoCancel);}
     Outcome := My_MessageBox(Buf,2);
     if Outcome = IdYes then
      BEGIN
       ShapeChange(FALSE);
OleSavedServerDoc(Doc^.ServerDoc);

{Demo Version} {DlgDemo := PDemo(Application^.ExecDialog(New(PDemo, init(@Self))));}

      END;
   END;
 if Outcome = IdYes then
  SaveChangesPrompt := fiExecute

{Demo Version}{SaveChangesPrompt := finon}

 else IF Outcome = IdCancel THEN
   SaveChangesPrompt := fiCancel
 else
   SaveChangesPrompt := finon;

end; {Demo Version}

function TGeomWindow.CanClose:BOOLEAN; var

 Reply: Integer;
 Msg:Tmessage;
 Ferme:TfileIoStatus;
 Message : ChaineC;

begin

 CanClose :=TRUE;
   IF (imbrication) AND (Quittons) THEN
    BEGIN
     Ferme:=SaveChangesPrompt;
     IF (Ferme<>Ficancel) THEN Sortie_Imbrication;
     IF (Ferme=FiCancel)  THEN CanClose:=FALSE;
    END
  ELSE
    BEGIN
     if (Dessin_change) then
       begin

(*$ifndef VERSION_ESP *)

         {Reply := MessageBox(HWindow, 'Voulez-vous enregistrer?',
         'Votre dessin a changé', mb_YesNoCancel or mb_IconQuestion);}
         StrCopy(Message,'Votre dessin a changé;'+#13#10#13#10+ 'Voulez-vous enregistrer ?');
         Reply:=My_messageBox(message,2);

(*$else *)

         Reply := MessageBox(HWindow, '¿Desea grabar?',
         'Su dibujo ha cambiado', mb_YesNoCancel or mb_IconQuestion);

(*$endif *)

         if Reply = id_Yes then FileSave(Msg);
  If Reply = id_Cancel Then CanClose:=FALSE ;
      end;
    END;
    Quittons:=TRUE;

end;

procedure Quelle_Barre(DC:HDC;n:BYTE); var

 MemDC: HDC;

begin

 MemDC := CreateCompatibleDC(DC);
  IF n=0 THEN SelectObject(MemDC,Barre0)
         ELSE SelectObject(MemDC,Barre1);
   BitBlt(DC,2 ,BarreY0+Barre2Y,BarreX,barreY0+barreY1+Barre2Y, MemDC, 0, 0,SrcCopy);
 DeleteDC(MemDC);

end;

procedure TGeomWindow.WMLButtonDown(var Msg: TMessage); VAR

    Mdc :HDC;
    Detruit_dernier:BOOLEAN;

begin

detruit_dernier:=FALSE;
Xi:=Msg.LparamLO;
Yi:=Msg.LparamHI;
{on gère ici toutes les fonctions définies par les pictogrammes}
{on envoie en fait à la procedure activation qui récupère la variable FONC}
IF (Xi>70) AND (Xi<240) THEN ValX:=(xi-70) DIV 35 {case destruction ???}
                        ELSE ValX:=0;

IF (Not(Memorise)) AND (Not(On_Anime)) THEN BEGIN

IF (ValX<>4) THEN
 BEGIN  {ne pas faire si case destruction car ne change pas les paramètres dans ce cas}
  IF Quel_AXE THEN
     BEGIN Activation(ValxV,ValyV,FALSE);Quel_Axe:=FALSE;Equation:=FALSE END;
  IF (L_Segment) AND (Xi<240) AND (Yi<370) THEN
      BEGIN Activation(ValxV,ValyV,FALSE);L_Segment:=FALSE; END;
  IF (M_Angle) AND (Xi<240) AND (Yi<370) THEN
     BEGIN Activation(ValxV,ValyV,FALSE);M_Angle:=FALSE END;
  IF (Def_Texte) AND (Xi<240) AND (Yi<370) THEN
     BEGIN Activation(ValxV,ValyV,FALSE);Def_Texte:=FALSE END;
  IF (Detruit_Bloc) AND (Xi<240) AND (Yi<370) THEN
     BEGIN Activation(ValxV,ValyV,FALSE);Detruit_Bloc:=FALSE END;
  IF (Etat_objet) AND (Xi<240) AND (Yi<370) THEN
     BEGIN Activation(ValxV,ValyV,FALSE);Etat_objet:=FALSE END;
  IF (Fonc=Points_Bary) THEN EFFACE:=TRUE;
  IF Def_Rect THEN
   BEGIN
     Activation(ValxV,ValyV,FALSE);
     IF W_Zone<>0 THEN BEGIN
  Raffraichir:=TRUE;
  {SendMessage(Wind,Wm_first+Wm_MButtonDown,0,0);}
                       New_paint;
      END
    ELSE Def_Rect:=FALSE;
    Fonc:=A_fonc;
   END;
 END;
{voir en  si on n'a pas demandé une inversion de la barre}
 IF (yi>325) AND (Yi<360) AND (Xi>35) AND (Xi<70) THEN
      BEGIN
        Activation(ValxV,ValyV,FALSE);
        MDc:=GEtDC(Hwindow);
        Barre_Symetrie:=NOT(Barre_Symetrie);
        IF Barre_Symetrie THEN Quelle_Barre(MDC,0) {dessiner la bonne barre}
                          ELSE Quelle_Barre(MDC,1);
        ReleaseDC(Hwindow,MDC);
        Activation(0,1,TRUE);      {la case segment}
        Aide_ligne(fonc_aide);
     END
ELSE
IF (Xi>70) AND (Xi<240) THEN
   BEGIN
     ValY:=15;{les pictos du haut}
     ValX:=(xi-70) DIV 35;
     IF (VALXV<>-1) AND (VAlx<>4) THEN ACTIVATION(VALXV,VALYV,FALSE);
     IF (Valx<>4) THEN
       BEGIN
         ACTIVATION(VALX,VALY,TRUE);
  aide_Ligne(Fonc_Aide); {modif JL 13/7/94}
END;
     IF Valx=4 THEN {détruire le dernier objet créé}
BEGIN
         IF (NOT(Def_rect)) THEN Destruction:=TRUE
                            ELSE 
                               BEGIN
                                 Raffraichir:=TRUE;
                                 New_paint; {remplace marques_options}
                                 curseur:=curs_select;
                                 def_rect:=TRUE;
                                 fonc:=segment;
                                 detruit_dernier:=TRUE; {pour ne pas faire marques_options}
                                END;
END
    END
ELSE
IF (Xi<70) AND (Yi<360) THEN
    BEGIN
       IF VALXV<>-1 THEN ACTIVATION(VALXV,VALYV,FALSE);
       IF Yi>45 THEN Yi:=Yi-10;
       IF Yi>130 THEN Yi:=Yi-10;
       IF (Yi>212) AND (NOT(Barre_symetrie)) THEN Yi:=Yi-10;
       IF (Yi>250) AND (Barre_symetrie)      THEN Yi:=Yi-10;
       Yi:=Yi-8;
       ValY:=Yi DIV 36;
       ValX:=xi DIV 35;
       ACTIVATION(VALX,VALY,TRUE);
       aide_Ligne(fonc_Aide);  {modif JL 13/7/94}
       IF Fonc=Rotat THEN Ang_Rot(Msg);
       IF Fonc=Homotetie THEN Coef_Homot(Msg);
       IF Fonc=prod_vect THEN Coeff_vecto(Msg);
    END;
If (Xi>244)  and (Xi<290) THEN
      BEGIN
{ ValY:= 0;
 ValX:= (Xi-250) DIV 11;}
     IF (Yi>26) AND (Yi<34) THEN marque_epaiss(1);
     IF (Yi>3)  AND (Yi<13) THEN marque_epaiss(-1);
{ Marque_Epaiss(ValX);}
      ENd;
If (Xi>292) And (Xi<340) THEN
      BEGIN
 ValY:= Yi DIV 20;
 ValX:= (xi-292) DIV 13;
 MarQue_Couleur(ValX,ValY);
      ENd;
IF (Xi<70) AND (Yi>365) AND (Yi<440) {AND (GetWindow(Wind,gw_Child)=0)} THEN
      BEGIN
       IF Yi<390 THEN WinExec(Nom_macro1,sw_show)
                 ELSE IF yi<420 THEN WinExec(Nom_macro2,sw_show)
                                ELSE WinExec(Nom_macro3,sw_show);
       WindC:=GetActiveWindow;
{ShowWindow(WindC,sw_parentclosing);}
{BringWindowToTop(WindC);}
      END;
    IF Fonc=Barycentre THEN Raffraichir:=TRUE;
    if (No_collect<>points^.count) OR (fonc=reconstruire) THEN Grise_anime(TRUE,TRUE)
                                                          ELSE Grise_anime(FALSE,TRUE);
    IF (Fonc<>reconstruire) AND (No_collect<>Points^.count) THEN Raffraichir:=TRUE;
    IF NOT(detruit_dernier) THEN FaitMarques_Options;
    marque_epaiss(0);
END; {fin de Not(mémorise) }

END; {procedure TgeomWindow.WMmousemove(var Msg: TMessage); VAR Xcur,Ycur : INTEGER;

   cursor_A  : Hcursor;

BEGIN

Xcur:=Msg.LparamLO;
Ycur:=Msg.LparamHI;
IF (Xcur<70) AND (Ycur<360) THEN
    BEGIN
       IF Ycur>80 THEN Ycur:=Ycur-10;
       IF Ycur>145 THEN Ycur:=Ycur-10;
       Ycur:=Ycur-8;
       ValY:=Ycur DIV 36;
       ValX:=xcur DIV 35;
    END;

END;}

procedure TGeomWindow.WMRButtonDown(var Msg: TMessage); VAR

    Mdc :HDC;
    Retour:WORD;

begin

Xi:=Msg.LparamLO;
Yi:=Msg.LparamHI;

IF (Not(Memorise)) AND (Not(On_Anime)) THEN

 BEGIN
  IF (Xi<70) AND (Yi>365) AND (Yi<440) AND (GetWindow(Wind,gw_Child)=0) THEN
      BEGIN
       IF Yi<390 THEN quelle_macro(1)
                 ELSE IF yi<420 THEN quelle_macro(2)
                                ELSE quelle_macro(3);
         Aff_macro(Nmacro1, 1);
         Aff_macro(Nmacro2, 2);
         Aff_macro(Nmacro3, 3);
      END;
 END; {fin de Not(mémorise) }

END;

procedure TGeomWindow.Paint(PaintDC: HDC;var PaintInfo: TPaintStruct); VAR St :STRING;

  {Gwnd   :PGWindow;}
   Doc :PoleDocument;
  Crayon,V_Crayon                   : HPen;

begin

 IF FIRST THEN
 BEGIN
  Wind0:=Hwindow;
  Menu0:=Attr.Menu;
  GetWindowsDirectory(Nom_fic_anime,79);
  StrCat(Nom_fic_anime,'WWWW.@@@');
  Fonc:=3;
  Valx_V1:=0;Valy_V1:=0;
  Activation(0,1,TRUE);
 END;
  {- trace les deux rectangles gris sans bordure---}
  crayon:= CreatePen(Ps_Null,0,Blanc);
  V_Crayon := SelectObject(PaintDC,crayon );
  Rect_PLEIN(PaintDC,0,0,ClientX+1,39,GRIS,GRIS);
  Rect_PLEIN(PaintDC,0,0,72,ClientY+1,GRIS,GRIS);
  SelectObject(PaintDC,V_crayon);
  DeleteObject(Crayon);
  efface:=FALSE;
  FaisBarre;
  IF NOT( (Quel_Axe) OR (L_Segment) OR (M_Angle)
                     OR (Def_Texte) OR (Detruit_Bloc) OR (Etat_objet)
       OR ( (On_Anime) ) )
   THEN  activation(ValxV,ValyV,FALSE);
  Marque_couleur(Valx_V1,Valy_V1);
  {Vide_Affiche;}
  ValX_V2:=-1;
  Marque_epaiss(0);
  Aide_ligne(Fonc_Aide);

end;

procedure TGEomWindow.FaisBarre; var

 MemDC,DC: HDC;
 Wnd : Hwnd;
 S : Array0..200 of Char;

begin

 Dc:=GEtDC(Hwindow);
   MemDC := CreateCompatibleDC(DC);
   SelectObject(MemDC,Barre);
   BitBlt(DC,2 ,Barre2Y-3,BarreX,barreY0+Barre2Y-3, MemDC, 0, 0,SrcCopy);
   IF Barre_Symetrie THEN Quelle_Barre(DC,0)
                     ELSE Quelle_Barre(DC,1);
   SelectObject(MemDC,Barre2);
   BitBlt(DC,2 ,3,Barre2X,barre2Y, MemDC, 0, 0, SrcCopy);
     SelectObject(MemDC,Barre3);
     BitBlt(DC,2 ,385+2-12,68+2,56+20-12, MemDC, 0, 0, SrcCopy);
 DeleteDC(MemDC);
 ReleaseDC(Hwindow,DC);
  Aff_macro(Nmacro1, 1);
  Aff_macro(Nmacro2, 2);
  Aff_macro(Nmacro3, 3);

end;

{procedure TgeomWindow.Aff_long(VAR Msg: Tmessage); BEGIN

Affiche(0,'',1);
Aff_longueurs:=NOT(Aff_Longueurs);
FaitMarques_Options;

END;

procedure TgeomWindow.Aff_coord(VAR Msg: Tmessage); BEGIN

Affiche(0,'',2);
Affiche(0,'',3);
Aff_Coordonnees:=NOT(Aff_Coordonnees);
FaitMarques_Options;

END;}

procedure TgeomWindow.TangenteC(VAR Msg: Tmessage); BEGIN

{on commence par désactivée la case qui était active}
IF (Fonc<>tangente) THEN Je_Reactive;
L_segment:=TRUE;
Fonc:=tangente;
Aide_Ligne(105);
Curseur:=Curs_Norm;
ValxV:=-1;
FaitMarques_Options;

END; procedure TgeomWindow.Aff_coordsP(VAR Msg: Tmessage); BEGIN

{on commence par désactivée la case qui était active}
IF (Fonc<>coordonnees_P) THEN Je_Reactive;
L_segment:=TRUE;
Fonc:=coordonnees_P;
Aide_Ligne(83);
Curseur:=Curs_Norm;
ValxV:=-1;
FaitMarques_Options;

END;

procedure TgeomWindow.Av_lettres(Var Msg: Tmessage); BEGIN

Avec_lettre:=NOT(Avec_Lettre);
IF avec_lettre THEN remet_les_mu
               ELSE vire_les_mu;
Raffraichir :=TRUE;
FaitMarques_Options;

END;

{procedure TgeomWindow.Reduite(Var Msg: Tmessage); BEGIN

IF Not(Def_rect) THEN
BEGIN
  On_Reduit:=NOT(On_Reduit);
  IF On_Reduit THEN BEGIN
            GRise_Anime(TRUE,TRUE);On_Anime:=TRUE;Reduc:=0.5;
      END
        ELSE BEGIN
       GRise_Anime(FALSE,TRUE);On_Anime:=FALSE; Reduc:=2;
      END;
  Nettoyer:=TRUE;
  Raffraichir :=TRUE;
  FaitMarques_Options;
END;

END;}

procedure TgeomWindow.Raffraich(Var Msg: Tmessage); BEGIN

Deplace_XOR:=NOT(Deplace_XOR);
Force_Xor:=NOT(Deplace_Xor);
FaitMarques_Options;

END;

procedure TgeomWindow.const_Enchainee(Var Msg: Tmessage); BEGIN

Enchaine:=NOT(Enchaine);
{Raffraichir :=TRUE;}
FaitMarques_Options;

END;

procedure TgeomWindow.Bouge_Det(Var Msg : Tmessage); BEGIN

GRise_Menu(id_bouge_exe,TRUE);
GRise_Menu(id_bouge_cont,TRUE);
Grise_Menu(id_bouge_fin,TRUE);
Grise_Menu(id_Bouge_det,TRUE);
Video^.FreeAll;
memorise:=FALSE;

END;

procedure TgeomWindow.Bouge_Deb(Var Msg : Tmessage); VAR Flag: BOOLEAN; BEGIN

IF NOT(Def_rect) THEN
BEGIN
  FLAG:=TRUE;
  GRise_Menu(id_bouge_exe,TRUE);
  GRise_Menu(id_bouge_cont,TRUE);
  Grise_Menu(id_bouge_fin,FALSE);
  Grise_Menu(id_bouge_det,FALSE);
  Grise_Anime(TRUE,FALSE);
  Msg.message:=0;
  MemoriseF(Msg);
  Video^.FreeAll;
  memorise:=TRUE;
  IF Def_Texte    THEN BEGIN Def_Texte   :=FALSE;Fonc:=A_fonc;FLAG:=FALSE END;
  IF Detruit_bloc THEN BEGIN Detruit_Bloc:=FALSE;Fonc:=A_fonc;FLAG:=FALSE END;
  IF Etat_objet   THEN BEGIN Etat_objet  :=FALSE;Fonc:=A_fonc;FLAG:=FALSE END;
  IF L_Segment    THEN BEGIN L_Segment   :=FALSE;Fonc:=A_fonc;FLAG:=FALSE END;
  IF M_Angle      THEN BEGIN M_Angle     :=FALSE;Fonc:=A_fonc;FLAG:=FALSE END;
  IF FLAG  THEN Activation(Valxv,Valyv,FALSE);
  Activation(0,15,TRUE); {obliger l'unique case déplace }
  Aide_ligne(20);
END;

END;

procedure TgeomWindow.Bouge_Fin(Var Msg : Tmessage); BEGIN

memorise:=FALSE;
curseur:=Curs_Norm;
Grise_Menu(Id_Bouge_fin,FALSE);
Grise_Menu(Id_Bouge_fin,TRUE);
Grise_Anime(FALSE,FALSE);

END;

procedure TgeomWindow.Bouge_Exe(Var Msg : Tmessage); BEGIN

 IF (Video^.count>5) and ( Def_Rect<>TRUE )THEN
  BEGIN
    Remet_Capture;
    memorise:=FALSE;
    GRise_Menu(id_bouge_fin,TRUE);
    GRise_Menu(id_bouge_exe,TRUE);
    GRise_Menu(id_bouge_cont,FALSE);
    Grise_Menu(id_bouge_deb,TRUE);
    Grise_Menu(id_bouge_det,TRUE);
    GRise_Anime(TRUE,FALSE);
    Compteur:=0;
    Msg.message:=0;
    Restitue(Msg);
    Horloge_debut:=TRUE;
    SetTimer(wind,0,vitesse,nil);
    On_Anime:=TRUE;
    A_fonc:=fonc;
    fonc:=Select;
  END;

END;

procedure TgeomWindow.Bouge_cont(Var Msg : Tmessage); BEGIN

 IF (Video^.count>5) THEN
 BEGIN
   GRise_Menu(id_bouge_exe,FALSE);
   GRise_Menu(id_bouge_cont,TRUE);
   GRise_Menu(id_Bouge_Det,FALSE);
   Grise_Menu(id_Bouge_Deb,FALSE);
   Grise_Menu(id_bouge_det,FALSe);
   Grise_Anime(FALSE,FALSE);
   On_Anime:=FALSE;
   KillTimer(wind,0);
   IF NOT (Trace_Active) THEN
   BEGIN
    Msg.message:=0;
    Restitue(Msg);
   END;
   fonc:=A_fonc;
   curseur_fonc;
   SetCursor(curseur);
   {modif JL 14/7/94}
   Raffraichir:=TRUE;
   FaitMarques_Options;
   {fin modif JL }
 END;

END;

procedure TgeomWindow.Trace_Activee(Var Msg: Tmessage); BEGIN

Trace_Active:=NOT(Trace_Active);
IF TRace_Active THEN Deplace_Xor:=TRUE ELSE Deplace_Xor:=FALSE;  {modif JL 10/7/94}
{Raffraichir :=TRUE;}
FaitMarques_Options;

END;

procedure TgeomWindow.Av_Fond(Var Msg: Tmessage); BEGIN

Avec_fond:=NOT(Avec_Fond);
Raffraichir :=TRUE;
FaitMarques_Options;

END;

procedure TgeomWindow.Av_Masses(Var Msg: Tmessage); BEGIN

Avec_Masse:=NOT(Avec_Masse);
IF Avec_masse THEN remet_les_masses
              ELSE vire_les_masses;
Raffraichir :=TRUE;Nettoyer:=TRUE;
FaitMarques_Options;

END;

procedure TgeomWindow.Deg1(Var Msg: Tmessage); BEGIN

IF Degre_precis=0 THEN Degre_precis:=1 ELSE Degre_precis:=0;
Raffraichir:=TRUE;
FaitMarques_Options;

END;

procedure TgeomWindow.Mes1(Var Msg: Tmessage); BEGIN

Mesure_precis:=1;
Raffraichir:=TRUE;
FaitMarques_Options;

END;

procedure TgeomWindow.Mes2(Var Msg: Tmessage); BEGIN

Mesure_precis:=2;
Raffraichir:=TRUE;
FaitMarques_Options;

END;

procedure TgeomWindow.Mes3(Var Msg: Tmessage); BEGIN

Mesure_precis:=3;
Raffraichir:=TRUE;
FaitMarques_Options;

END;

procedure TgeomWindow.Remet_Objects(VAr Msg: Tmessage); BEGIN

 IF (NOT(memorise)) AND (NOT(On_anime)) THEN
  BEGIN
   Remet_Les_objects;Raffraichir:=TRUE;
   Grise_Menu(Remet_Obj,TRUE);
   Grise_Menu(id_dernier,TRUE);
   FaitMarques_Options;
  END;

END;

procedure TgeomWindow.Remet_dernier(VAr Msg: Tmessage); BEGIN

 IF (NOT(memorise)) AND (NOT(On_anime)) THEN
  BEGIN
   Remet_Le_dernier;Raffraichir:=TRUE;dessin_change:=TRUE;
   IF Gommes0=0 THEN
   BEGIN
     Grise_Menu(id_Dernier,TRUE);
     Grise_Menu(Remet_Obj,TRUE);
   END;
  FaitMarques_Options;
 END;

END;

procedure TgeomWindow.Nettoie(Var Msg: Tmessage); BEGIN

Raffraichissons:=TRUE;
Raffraichir:=TRUE;
Nettoyer   :=TRUE;
FaitMarques_Options;

END;

procedure TgeomWindow.PointXY(VAr Msg: Tmessage); BEGIN

Remet_capture;
St_MonX:='0';St_MonY:='0';St_MonZ:='0';
Quelle_XY(1);{1 pour coordonnées}
Place_XY:=TRUE;
FaitMarques_Options;

END;

procedure TgeomWindow.graduations(Var Msg: Tmessage); BEGIN

  A_fonc:=Fonc;
  Fonc:=Quadrill;
  Avec_graduations:=NOT(Avec_graduations);
  FaitMarques_Options;

END; procedure TgeomWindow.Trame(Var Msg: Tmessage); BEGIN

  A_fonc:=Fonc;
  Fonc:=Quadrill;
  Avec_trame:=NOT(Avec_trame);
  IF NOT(Avec_axes) AND (Avec_Trame) THEN Avec_axes:=TRUE;
  FaitMarques_Options;

END; procedure TgeomWindow.Axes(Var Msg: Tmessage); BEGIN

  A_fonc:=Fonc;
  Fonc:=Quadrill;
  Avec_axes:=NOT(Avec_axes);
  IF NOT(Avec_axes) AND (Avec_Trame) THEN Avec_Trame:=FALSE;
  FaitMarques_Options;

END; procedure TgeomWindow.Cachees(Var Msg: Tmessage); BEGIN

  On_Cache:=TRUE;
  Courbes_Cachees:=NOT(Courbes_cachees);
  Raffraichir:=TRUE;Nettoyer:=TRUE;
  FaitMarques_Options;

END;

procedure TgeomWindow.Lie(Var Msg: Tmessage); var Chaine_avert:ChaineC;

   reply:integer;

BEGIN

if (liberte=false) then
begin

(*$ifndef VERSION_ESP *)

     StrCopy(Chaine_avert,'Passage en mode Points non liés:'+
     #13#10#13#10+'   dans ce mode on ne peut lier un point à un objet.'+
     #13#10+'   (Ex: un point sur un cercle.)');

(*$else *)

     StrCopy(Chaine_avert,'Paso al modo Puntos no vinculados:'+
     #13#10#13#10+'   en este modo no se puede vincular un punto a un objeto.'+
     #13#10+'   (Ej.: un punto en un círculo.)');

(*$endif *)

end
else
begin

(*$ifndef VERSION_ESP *)

     StrCopy(Chaine_avert,'Passage en mode Points liés:'+
     #13#10#13#10+'   dans ce mode il est possible de lier un point à un objet.'+
     #13#10+'   (Ex: un point sur un cercle.)');

(*$else *)

     StrCopy(Chaine_avert,'Paso al modo Puntos vinculados:'+
     #13#10#13#10+'   en este modo es posible vincular un punto a un objeto.'+
     #13#10+'   (Ej.: un punto en un círculo.)');

(*$endif *)

end;
if AvecMessageErreur then
begin

(*$ifndef VERSION_ESP *)

      reply:=My_messageBox(Chaine_avert,4);
     {reply:=Messagebox(0,Chaine_avert,'Attention',MB_OKCANCEL);}

(*$else *)

     reply:=Messagebox(0,Chaine_avert,'Cuidado',MB_OKCANCEL);

(*$endif *)

     if(reply=Id_Yes)then
     begin
          Liberte:=NOT(Liberte);  {modif JL 6/7/94}
          Lie_Objet;
          { Raffraichir:=TRUE;}   {modif JL 10/7/94}
          FaitMarques_Options;
     end;
end
else
begin
     Liberte:=NOT(Liberte);  {modif JL 6/7/94}
     Lie_Objet;
   { Raffraichir:=TRUE;}   {modif JL 10/7/94}
     FaitMarques_Options;
end;

END;

procedure TgeomWindow.Detruit(Var Msg: Tmessage); BEGIN

Je_Reactive;
Fonc:=Segment;A_fonc:=Fonc;
Detruit_bloc:=TRUE;
Aide_ligne(79);
FaitMarques_Options;
Curseur:=Curs_norm;

END;

procedure TgeomWindow.Anal_Histo(Var Msg: Tmessage); BEGIN

Historique:=TRUE;
Fais_historique;
Histo_edit;
Historique:=FALSE;

END;

procedure TgeomWindow.Histo_Tri(Var Msg: Tmessage); BEGIN

Histor_points;
Histo_edit;

END;

procedure TgeomWindow.derivons(Var Msg: Tmessage); BEGIN

Je_Reactive;
Fonc:=derivee;A_fonc:=Fonc;
Etat_Objet:=TRUE;
Aide_ligne(99);
FaitMarques_Options;
Curseur:=Curs_norm;

END; procedure TgeomWindow.integrons(Var Msg: Tmessage); BEGIN

Je_Reactive;
Fonc:=primitive;A_fonc:=Fonc;
Etat_Objet:=TRUE;
Aide_ligne(100);
FaitMarques_Options;
Curseur:=Curs_norm;

END; procedure TgeomWindow.composons(Var Msg: Tmessage); BEGIN

Je_Reactive;
Fonc:=gof;A_fonc:=Fonc;
Etat_Objet:=TRUE;
Aide_ligne(101);
FaitMarques_Options;
Curseur:=Curs_norm;

END;

procedure TgeomWindow.Anal_Etat(Var Msg: Tmessage); BEGIN

Je_Reactive;
Fonc:=Segment;A_fonc:=Fonc;
Etat_Objet:=TRUE;
Aide_ligne(80);
FaitMarques_Options;
Curseur:=Curs_norm;

END;

procedure TgeomWindow.EquationAff(Var Msg: Tmessage); BEGIN

Je_Reactive;
Equation:=TRUE;Quel_Axe:=TRUE;
Fonc:=Parall;A_fonc:=Fonc;
aide_ligne(13);
FaitMarques_Options;
Curseur:=Curs_norm;

END;

procedure TgeomWindow.Axe_Proj(Var Msg: Tmessage); BEGIN

Je_Reactive;
Quel_Axe:=TRUE;
Fonc:=Parall;A_fonc:=Fonc;
Change_Menu(215,'(.........)',0,1,1,1);
aide_ligne(48);
FaitMarques_Options;
Curseur:=Curs_norm;

END;

{procedure ajoutée le 10/7/94} procedure TgeomWindow.EtatCoul(VAR Msg: Tmessage); BEGIN

IF (Fonc<>Etat_coul) THEN Je_Reactive;
L_segment:=TRUE;
Fonc:=Etat_coul;
Aide_Ligne(82);
Curseur:=Curs_Norm;
ValxV:=-1;
FaitMarques_Options;

END;

procedure TgeomWindow.EtatPoint(VAR Msg: Tmessage); {modif JL 6/7/94} BEGIN

IF (Fonc<>Etat_point) THEN Je_Reactive;
L_segment:=TRUE;
Fonc:=Etat_point;
Aide_Ligne(81);
Curseur:=Curs_Norm;
ValxV:=-1;
FaitMarques_Options;

END;

procedure TgeomWindow.Pas_Lieu(Var Msg: Tmessage); VAR TheText:Array0..6 OF Char;

   Err    :INTEGER;
   Phi    :REAL;
   St     :String3;

BEGIN

Str(PasLieu,St);
Err:=1;
WHILE Err<>0 DO
 BEGIN
   StrPcopy(TheText,St);
   IF Application^.ExecDialog(New(PInputDialog,
      Init(@Self,'LIEU: Pas de déplacement   (1.....40)',
             'Nouveau pas:',TheText,Sizeof(TheText))))=Id_OK
   THEN
    BEGIN
     VAL(TheText,PasLieu,Err);
     IF (PasLieu<1) OR (PasLieu>40) THEN
       BEGIN Err:=1;PasLieu:=4 END;
    END
   ELSE Err:=0;
END;
Change_Menu(242,'',PasLieu,3,0,0);

END;

procedure TgeomWindow.Nulle_en_zero(Var Msg: Tmessage); VAR TheText:Array0..20 OF Char;

   Err    :INTEGER;
   Phi    :REAL;

BEGIN

Err:=1;
WHILE Err<>0 DO
 BEGIN
   StrPcopy(TheText,Xprimit);
   IF Application^.ExecDialog(New(PInputDialog,
      Init(@Self,'PRIMITIVE Nulle en   (-500.00.....500.00)',
             'Nulle en :',TheText,Sizeof(TheText))))=Id_OK
   THEN
    BEGIN
     Xprimit:=StrPas(TheText);
     phi:=valeur(Xprimit);
     Err:=0;
     IF (phi<-500) OR (phi>500) THEN
       BEGIN Err:=1;Xprimit:='0.00' END;
    END
   ELSE Err:=0;
END;
Change_Menu(313,Xprimit,0,3,0,0);

END;

procedure TgeomWindow.inters_Courbes(VAR Msg: Tmessage); {modif JL 6/7/94} BEGIN

IF (Fonc<>inters) THEN Je_Reactive;
L_segment:=TRUE;
Fonc:=inters;
Aide_Ligne(107);
Curseur:=Curs_Norm;
ValxV:=-1;
FaitMarques_Options;

END;

procedure TgeomWindow.LieuPoint(VAR Msg: Tmessage); {modif JL 6/7/94} BEGIN

IF (Fonc<>lieu_point) THEN Je_Reactive;
L_segment:=TRUE;
Fonc:=lieu_point;
Aide_Ligne(96);
Curseur:=Curs_Norm;
ValxV:=-1;
FaitMarques_Options;

END;

procedure TgeomWindow.MasseBary(VAR Msg: Tmessage); BEGIN

IF (Fonc<>Points_Bary) THEN Je_Reactive;
L_segment:=TRUE;
Fonc:=Points_Bary;
Aide_Ligne(53);
Curseur:=Curs_Norm;
ValxV:=-1;

END;

procedure TgeomWindow.L_Seg(Var Msg: Tmessage); BEGIN

Avec_Degres:=TRUE;
Je_Reactive;
L_segment:=TRUE;
Aide_Ligne(43);
Fonc:=Milieu;A_fonc:=Milieu;
FaitMarques_Options;
curseur:=Curs_Norm;

END;

procedure TgeomWindow.M_Seg(Var Msg: Tmessage); BEGIN

L_Seg(Msg);
Avec_Degres:=FALSE;

END;

procedure TgeomWindow.M_ang(Var Msg: Tmessage); BEGIN

Avec_Degres:=TRUE;
Je_Reactive;
M_Angle:=TRUE;
Aide_Ligne(42);
Fonc:=bissectrice;A_fonc:=Fonc;
FaitMarques_Options;
curseur:=Curs_Norm;

END;

procedure TgeomWindow.On_Colle(Var Msg: Tmessage); BEGIN

Je_Reactive;
L_Segment:=TRUE;
Aide_Ligne(98);
Fonc:=Coller;A_fonc:=Fonc;
FaitMarques_Options;
curseur:=Curs_Norm;

END;

procedure TgeomWindow.M_Aire(Var Msg: Tmessage); BEGIN

Je_Reactive;
L_Segment:=TRUE;
Aide_Ligne(95);
Fonc:=Aire;A_fonc:=Fonc;
FaitMarques_Options;
curseur:=Curs_Norm;

END; procedure TgeomWindow.M_AireQ(Var Msg: Tmessage); BEGIN

Je_Reactive;
L_Segment:=TRUE;
Aide_Ligne(109);
Fonc:=AireQ;A_fonc:=Fonc;
FaitMarques_Options;
curseur:=Curs_Norm;

END;

procedure TgeomWindow.M_Mang(Var Msg: Tmessage); BEGIN

M_ang(Msg);
Avec_Degres:=FALSE;

END;

procedure TgeomWindow.Pol_Defaut(Var Msg: Tmessage); BEGIN

les_fontes_de_base(TRUE);
aide_ligne(fonc_aide);
Raffraichir:=TRUE;Nettoyer:=TRUE;
FaitMarques_Options;

END;

procedure TgeomWindow.Par_Defaut(Var Msg: Tmessage); BEGIN

IF Quel_Axe THEN Activation(ValxV,ValyV,FALSE);
Quel_Axe:=FALSE;
N_Proj:=0;
Rot_Ang:=2700;
Delta_Homot:=0.5;
Ratio:=1;
{V_UniteX:=UniteX;V_UniteY:=UniteY;}
Viel_UniteX:=UniteX;Viel_UniteY:=UniteY;
UniteX:=40;UniteY:=40;Unite_XR:=40;Unite_YR:=40;
Coeff_vect:=2;
Angle_Arc:=360;
Init_Menu_Param;
Init_Param:=TRUE;
Vire_les_projections;
Raffraichir:=TRUE;Nettoyer:=TRUE;
{SendMessage(Wind,Wm_first+Wm_MButtonDown,0,0);}
FaitMarques_Options;

END;

procedure TgeomWindow.Quelle_Zone(Var Msg: Tmessage); BEGIN

je_reactive;
Def_Rect:=TRUE;
{debug stef}
DEF_texte:=FALSE;
A_Fonc:=Fonc;
Aide_Ligne(44);
Fonc:=Segment;
Curseur:=Curs_Select;

END;

{procedure TGeomWindow.ImprimerF(var Msg: TMessage); begin

 Imprime_Tout:=TRUE;Imp_fond:=TRUE;
 New_paint;

end;} procedure TGeomWindow.Imprimer(var Msg: TMessage); begin

 Imprime_Tout:=TRUE;Imp_fond:=FALSE;
 New_paint;
 IF Def_rect THEN Je_Reactive; {si une zone est définie réactiver la case après effaçage
 sinon la case n'est pas déactivée}

end;

procedure TGeomWindow.Imprimer_Zone(var Msg: TMessage); begin

 {Je_Reactive;A_fonc:=Fonc;L_segment:=TRUE;}
 Copy_zone:=TRUE;Imp_fond:=FALSE;
 Imprime_La_zone:=TRUE;
 New_paint;{la premiere fois le rect_zone s'efface et def_rect:=false}
 New_paint;{W_zone est toujours là et on imprime la zone}
 Je_Reactive;

end;

{procedure TGeomWindow.Imprimer_ZoneF(var Msg: TMessage); begin

 Je_Reactive;
 Copy_zone:=TRUE;Imp_fond:=TRUE;
 Imprime_La_zone:=TRUE;
 New_paint;
 New_paint;

end;}

procedure TgeomWindow.Vire_Corbeille(Var Msg: Tmessage); BEGIN

Vide_Corbeille;

END;

procedure TgeomWindow.Copie_Zone(Var Msg: Tmessage); BEGIN

Copy_zone:=TRUE;
{SendMessage(Wind,Wm_first+Wm_MButtonDown,0,0);
SendMessage(Wind,Wm_first+Wm_MButtonDown,0,0);}
New_paint;
New_paint;
Je_reactive;

END;

procedure TgeomWindow.Ang_Rot(Var Msg: Tmessage); VAR TheText:Array0..6 OF Char;

   Err    :INTEGER;
   Phi    :REAL;
   St     :String7;

BEGIN

IF Rot_Ang>1800 THEN Phi:=360-Rot_Ang/10
                ELSE Phi:=-Rot_Ang/10;
Str(Phi:7:1,St);
Err:=1;
WHILE Err<>0 DO
 BEGIN
   StrPcopy(TheText,St);
   IF Application^.ExecDialog(New(PInputDialog,

(*$ifndef VERSION_ESP *)

       Init(@Self,'Rotation: Angle  (-180.0.....180.0)',
         'Nouvel Angle:',TheText,Sizeof(TheText))))=Id_OK

(*$else *)

       Init(@Self,'Rotación: Angulo  (-180.0.....180.0)',
       'Nuevo ángulo.',TheText,Sizeof(TheText))))=Id_OK

(*$endif *)

   THEN
    BEGIN
     VAL(TheText,Phi,Err);
     IF (Phi<-180) OR (Phi>180) THEN Err:=1;
     IF Err=0 THEN
        IF Phi<0 THEN Rot_Ang:=ROUND(ABS(Phi*10))
                 ELSE Rot_Ang:=3600-ROUND(Phi*10);
    END
   ELSE Err:=0;
END;
Change_Menu(214,'(.....)',phi,7,1,1);
IF fonc=Rotat THEN aide_ligne(Rotat+19);

END;

procedure TgeomWindow.coef_Homot(Var Msg: Tmessage); VAR TheText:Array0..6 OF Char;

   Err    :INTEGER;
   Phi    :REAL;
   St     :String7;

BEGIN

Str(Delta_Homot:6:2,St);
Err:=1;
WHILE Err<>0 DO
 BEGIN
   StrPcopy(TheText,St);
   IF Application^.ExecDialog(New(PInputDialog,

(*$ifndef VERSION_ESP *)

         Init(@Self,'Rapport d''homothétie  (-10.00.....10.00)',
         'Nouveau rapport:',TheText,Sizeof(TheText))))=Id_OK

(*$else *)

         Init(@Self,'Relación de homotecia  (-10.00.....10.00)',
         'Nueva relación:',TheText,Sizeof(TheText))))=Id_OK

(*$endif *)

   THEN
    BEGIN
     VAL(TheText,Delta_Homot,Err);
     IF (Delta_Homot<-10) OR (Delta_Homot>10) THEN
       BEGIN Err:=1;Delta_homot:=0.5 END;
    END
   ELSE Err:=0;
END;
Change_Menu(216,'(.....)',Delta_Homot,6,2,1);
IF fonc=Homotetie THEN aide_ligne(fonc+19);

END;

procedure TgeomWindow.M_Rang(Var Msg: Tmessage); VAR TheText:Array0..6 OF Char;

   Err    :INTEGER;
   Phi    :REAL;
   St     :String7;

BEGIN

Str(Ray_Ang:6:2,St);
Err:=1;
WHILE Err<>0 DO
 BEGIN
   StrPcopy(TheText,St);
   IF Application^.ExecDialog(New(PInputDialog,

(*$ifndef VERSION_ESP *)

          Init(@Self,'Rayon de marquage  (5.....100)',
          'Nouveau rayon:',TheText,Sizeof(TheText))))=Id_OK

(*$else *)

          Init(@Self,'Radio de marcación (5.....100)',
          'Nuevo radio:',TheText,Sizeof(TheText))))=Id_OK

(*$endif *)

   THEN
    BEGIN
     VAL(TheText,Ray_Ang,Err);
     IF (Ray_Ang<5) OR (Ray_Ang>100) THEN
       BEGIN Err:=1;Ray_Ang:=15 END;
    END
   ELSE Err:=0;
END;
       Change_Menu(id_Rangle,'Rayon en points-écran...     ',Ray_Ang,3,0,0);

END;

procedure TgeomWindow.M_Rseg(Var Msg: Tmessage); VAR TheText:Array0..6 OF Char;

   Err    :INTEGER;
   Phi    :REAL;
   St     :String7;

BEGIN

Str(Long_Seg,St);
Err:=1;
WHILE Err<>0 DO
 BEGIN
   StrPcopy(TheText,St);
   IF Application^.ExecDialog(New(PInputDialog,

(*$ifndef VERSION_ESP *)

         Init(@Self,'Longueur de marquage  (2.....100)',
         'Nouvelle longueur:',TheText,Sizeof(TheText))))=Id_OK

(*$else *)

         Init(@Self,'Longitud de marcación  (2.....100)',
         'Nueva longitud:',TheText,Sizeof(TheText))))=Id_OK

(*$endif *)

   THEN
    BEGIN
     VAL(TheText,Long_Seg,Err);
     IF (long_Seg<2) OR (long_Seg>100) THEN
BEGIN Err:=1;Long_Seg:=12 END;
    END
   ELSE Err:=0;
END;
         Change_Menu(id_Rseg,'Longueur en points-écran... ',Long_Seg,3,0,0);
         Change_Menu(id_Rangle,'Rayon en points-écran...     ',Ray_Ang,3,0,0);

END;

procedure TgeomWindow.Coeff_vecto(Var Msg: Tmessage); VAR TheText:Array0..6 OF Char;

   Err    :INTEGER;
   Phi    :REAL;
   St     :String7;

BEGIN

Str(Coeff_vect:6:2,St);
Err:=1;
WHILE Err<>0 DO
 BEGIN
   StrPcopy(TheText,St);
   IF Application^.ExecDialog(New(PInputDialog,

(*$ifndef VERSION_ESP *)

      Init(@Self,'k fois un vecteur   (-50.00.....50.00)',
             'Nouveau k:',TheText,Sizeof(TheText))))=Id_OK

(*$else *)

      Init(@Self,'k veces un vector (-50.00.....50.00)',
             'Nuevo  k:',TheText,Sizeof(TheText))))=Id_OK

(*$endif *)

   THEN
    BEGIN
     VAL(TheText,Coeff_vect,Err);
     IF (Coeff_vect<-50) OR (Coeff_vect>50) THEN
       BEGIN Err:=1;Coeff_vect:=2 END;
    END
   ELSE Err:=0;
END;
IF fonc=Prod_vect THEN aide_ligne(fonc+19);
Change_Menu(217,'(.....)',coeff_vect,6,2,1);

END;

procedure TgeomWindow.Angle_D(Var Msg: Tmessage); VAR TheText:Array0..6 OF Char;

   Err    :INTEGER;
   Phi    :REAL;
   St     :String7;

BEGIN

Str(Angle_Arc:6,St);
Err:=1;
WHILE Err<>0 DO
 BEGIN
   StrPcopy(TheText,St);
   IF Application^.ExecDialog(New(PInputDialog,

(*$ifndef VERSION_ESP *)

      Init(@Self,'Arc en degrés  (-360.....360)',
             'Nouvel arc:',TheText,Sizeof(TheText))))=Id_OK

(*$else *)

      Init(@Self,'Arco en grados  (-360.....360)',
             'Nuevo arco:',TheText,Sizeof(TheText))))=Id_OK

(*$endif *)

   THEN
    BEGIN
     VAL(TheText,Angle_Arc,Err);
     IF (Angle_arc<-360) OR (Angle_Arc>360) THEN
       BEGIN Err:=1;angle_Arc:=360 END;
    END
   ELSE Err:=0;
END;
Change_Menu(id_Val_Arc,'(.....)',Angle_Arc,6,0,1);

END;

procedure TgeomWindow.Unite_X(Var Msg: Tmessage); {corrida} VAR TheText:Array0..6 OF Char;

   Err    :INTEGER;
   St     :String7;

BEGIN

Str(UniteX:4:0,St);
Err:=1;{V_UniteX:=UniteX;}Viel_UniteX:=UniteX;Viel_UniteY:=UniteY;{V_uniteY:=UniteY;}
WHILE Err<>0 DO
 BEGIN
   StrPcopy(TheText,St);
   IF Application^.ExecDialog(New(PInputDialog,

(*$ifndef VERSION_ESP *)

      Init(@Self,'Unité en pixels  (0.....500)',
             'Nouvelle unité:',TheText,Sizeof(TheText))))=Id_OK

(*$else *)

      Init(@Self,'Arco en grados  (0.....500)',
             'Nuevo arco:',TheText,Sizeof(TheText))))=Id_OK

(*$endif *)

   THEN
    BEGIN
     VAL(TheText,UniteX,Err);
     IF (UniteX<2) OR (UniteX>500) THEN
       BEGIN Err:=1;UniteX:=40 END;
    END
   ELSE Err:=0;
   UniteY:=UniteX; {toujours normé quand on change uniteX}
   Ratio:=1; {ellipses->cercles car  repère normé} 
END;
Change_Menu(id_ValX,'(.....)',UniteX,4,0,1);
Change_Menu(id_ValY,'(.....)',UniteY,4,0,1);
Raffraichir:=TRUE;Nettoyer:=TRUE; {on doit nettoyer car ne peut conserver les lieux}
{SendMessage(Wind,Wm_first+Wm_MButtonDown,0,0);}
New_paint;

END;

procedure TgeomWindow.Zoom(n:BYTE); BEGIN

Viel_uniteX:=uniteX;Viel_uniteY:=UniteY;
IF n=1 THEN unitex:=Unitex*0.8;
IF n=0 THEN unitex:=40;
IF n=2 THEN uniteX:=UniteX/0.8;
IF unitex=40 THEN grise_menu(id_normale,TRUE)
             ELSE grise_menu(id_normale,FALSE);
IF unitex<2 THEN BEGIN unitex:=2; grise_menu(id_eloigne,TRUE) END
            ELSE grise_menu(id_eloigne,FALSE);
IF unitex>500 THEN BEGIN unitex:=500; grise_menu(id_approche,TRUE) END
              ELSE grise_menu(id_approche,FALSE);
uniteY:=UniteX;
Change_Menu(id_ValY,'(.....)',UniteY,6,0,1);
Change_Menu(id_ValX,'(.....)',UniteX,6,0,1);
Raffraichir:=TRUE;Nettoyer:=TRUE; {on doit nettoyer car ne peut conserver les lieux}
{SendMessage(Wind,Wm_first+Wm_MButtonDown,0,0);}
New_paint;

END;

procedure TgeomWindow.Eloigne(Var Msg: Tmessage); BEGIN

Zoom(1);

END; procedure TgeomWindow.Normale(Var Msg: Tmessage); BEGIN

Zoom(0);

END; procedure TgeomWindow.approche(Var Msg: Tmessage); BEGIN

Zoom(2);

END;

procedure TgeomWindow.Unite_Y(Var Msg: Tmessage); {corrida} VAR TheText:Array0..6 OF Char;

   Err    :INTEGER;
   St     :String7;

BEGIN

Str(UniteY:4:0,St);
Err:=1;{V_UniteY:=UniteY;}Viel_UniteY:=UniteY;
WHILE Err<>0 DO
 BEGIN
   StrPcopy(TheText,St);
   IF Application^.ExecDialog(New(PInputDialog,

(*$ifndef VERSION_ESP *)

      Init(@Self,'Unité en pixels  (0.....500)',
             'Nouvelle unité:',TheText,Sizeof(TheText))))=Id_OK

(*$else *)

      Init(@Self,'Arco en grados  (0.....500)',
             'Nuevo arco:',TheText,Sizeof(TheText))))=Id_OK

(*$endif *)

   THEN
    BEGIN
     VAL(TheText,UniteY,Err);
     IF (UniteY<2) OR (UniteY>500) THEN
       BEGIN Err:=1;UniteY:=40 END;
    END
   ELSE Err:=0;
END;
Ratio:=UniteY/UniteX; {pour ellipses lorsque repére non normé}
Change_Menu(id_ValY,'(.....)',UniteY,6,0,1);
Raffraichir:=TRUE;Nettoyer:=TRUE; {on doit nettoyer car ne peut conserver les lieux}
{SendMessage(Wind,Wm_first+Wm_MButtonDown,0,0);}
New_paint;

END;

procedure TgeomWindow.Bouge_vit(Var Msg: Tmessage); VAR TheText:Array0..6 OF Char;

   Err    :INTEGER;
   Phi    :REAL;
   St     :String7;

BEGIN

Str(Vitesse:6,St);
Err:=1;
WHILE Err<>0 DO
 BEGIN
   StrPcopy(TheText,St);
   IF Application^.ExecDialog(New(PInputDialog,

(*$ifndef VERSION_ESP *)

         Init(@Self,'Temporisation d''animation (10...1000)',
         'Nouvelle temporisation:',TheText,Sizeof(TheText))))=Id_OK

(*$else *)

         Init(@Self,'Temporización de animación (10...1000)',
         'Nueva temporización:',TheText,Sizeof(TheText))))=Id_OK

(*$endif *)

   THEN
    BEGIN
     VAL(TheText,Vitesse,Err);
     IF (Vitesse<10) OR (vitesse>1000) THEN
BEGIN Err:=1;angle_Arc:=100 END;
    END
   ELSE Err:=0;
END;
         Change_Menu(id_bouge_vit,'&Temporisation (msec) ',vitesse,6,0,0);

END;

procedure TgeomWindow.InTexteA(Var Msg: Tmessage); BEGIN

IF editor THEN  {dans editor on récup le texte et vrai si ok}
BEGIN
  IF (NOT(Def_Texte)) THEN  Je_Reactive;{Activation(ValXv,ValYv);}
  IF EQUATION THEN EQUATION:=False;
  IF Quel_Axe THEN Quel_Axe:=False;
  def_rect:=FALSE;
  Def_Texte:=TRUE;
  A_fonc:=fonc;
  fonc:=Segment;
  Aide_ligne(71);
  Curseur:=Curs_select;
END;

END;

procedure TGeomWindow.Quelle_polaire(Var Msg:Tmessage); Begin

     Remet_Capture;
     Quelle_Fn_polaire;
     FaitMarques_Options;

end;

procedure TGeomWindow.Quelle_Affine(Var Msg:Tmessage); Begin

     Remet_Capture;
     Quelle_Fn_Affine;
     FaitMarques_Options;

end;

procedure TGeomWindow.Quelle_Param(Var Msg:Tmessage); begin

      Remet_Capture;
      Quelle_Fn_Param;
      FaitMarques_Options;

end;

procedure TgeomWindow.ANAL_DIR(Var Msg: Tmessage); VAR m: WORD; BEGIN

m:=Analyse_Directions;
IF m<>0 THEN Avert(M,1);

END;

procedure TgeomWindow.ANAL_TRI(Var Msg: Tmessage); VAR m: WORD; BEGIN

m:=Analyse_Triangles;
IF m<>0 THEN Avert(M,1);

END;

procedure TgeomWindow.HelpM(Help_Val:INTEGER); BEGIN

Help:=TRUE;Help_Valeur:=Help_Val;
{SendMessage(Wind,Wm_first+Wm_MButtonDown,0,0);}
New_paint;

END;

procedure TgeomWindow.ANAL_QUA(Var Msg: Tmessage); VAR m: WORD; BEGIN

m:=Analyse_Quadri;
IF m<>0 THEN Avert(M,1);

END;

{modif 06/05/94} procedure TgeomWindow.Efface_tout_et_recommence(var Msg: TMessage); begin

Remet_Capture;Quittons:=FALSE;
On_TErmine:=FALSE; {empêche canclose de révoker le serveur}
IF (Canclose) THEN
BEGIN
 PGeom_Wind^.DoneDocument;
 PGeom_Wind^.Initdocument;
 IF Himage<>0 THEN DeleteObject(Image);
 filenamebit0:=#0;Himage:=0;
 New_Collections(TRUE);
 UniteX:=40;{V_uniteX:=40;} UniteY:=40;{V_uniteY:=40;}Viel_uniteX:=40;Viel_uniteY:=40;
 InvalidateRect(Wind, nil, True);
 IsDirty := False;
 Dessin_Change:=False;
 IsNewFile := True;
 Filename0:=#0;
 FaisName(filename);
  IF NOT( (Quel_Axe) OR (L_Segment) OR (M_Angle) OR (On_Anime)
           OR (Def_Texte) OR (Detruit_Bloc) OR (Etat_objet) )
   THEN  activation(ValxV,ValyV,FALSE);
 Initialise;faisbarre;ValX_V2:=-1;Avec_trame:=FALSE;
 Activation(0,1,TRUE);Marque_Epaiss(0);Marque_couleur(0,0);FIRST:=TRUE;
 Aide_Ligne(22);
 {Vide_affiche;}
 Construis_Quadrillage;
 Init_Menu_Param;
 Grise_Par_Defaut;
 Init_Texte(TexteA);
 T_Txt.Texte1:=TexteA;
 FaitMarques_Options;
END;
{SendMessage(Wind,Wm_first+Wm_MButtonDown,0,0);}

end;

procedure vire_menu_aide; VAR Aide_menu,Main_menu: Hmenu;

   k: INTEGER;

BEGIN

 DestroyMenu(MenA);
 Main_menu :=getMenu(Wind0);
 Aide_menu:=GetSubmenu(Main_menu,7);
 IF getMenuItemCount(Aide_menu)>10 THEN
  BEGIN
    Deletemenu(Aide_menu,0,mf_byposition);
    Deletemenu(Aide_menu,0,mf_byposition);
  END;

END;

procedure TGeomWindow.FileNew(var Msg: TMessage); begin

Remet_Capture;Quittons:=FALSE;
On_TErmine:=FALSE; {empêche canclose de révoker le serveur}
IF (Canclose) THEN
BEGIN
   PGeom_Wind^.DoneDocument;
   PGeom_Wind^.Initdocument;
 IF Himage<>0 THEN DeleteObject(Image);
 vire_menu_aide;
 filenamebit0:=#0;Himage:=0;
 New_Collections(TRUE);
 UniteX:=40;Viel_uniteX:=40;UniteY:=40;Viel_uniteY:=40;
 InvalidateRect(Wind, nil, True);
 IsDirty := False;
 Dessin_Change:=False;
 IsNewFile := True;
 Filename0:=#0;
 FaisName(filename);
  IF NOT( (Quel_Axe) OR (L_Segment) OR (M_Angle) OR (On_Anime)
           OR (Def_Texte) OR (Detruit_Bloc) OR (Etat_objet) )
   THEN  activation(ValxV,ValyV,FALSE);
 Initialise;faisbarre;ValX_V2:=-1;Avec_trame:=FALSE;Avec_lettre:=FALSE;
 Activation(0,1,TRUE);Marque_Epaiss(0);Marque_couleur(0,0);FIRST:=TRUE;
 Aide_Ligne(22);
 {Vide_affiche;}
 Construis_Quadrillage;
 Init_Menu_Param;
 les_fontes_de_base(FALSE); {fontes de base sauf aide en ligne dans Geom.ini}
 Grise_Par_Defaut;
 Init_Texte(TexteA);
 T_Txt.Texte1:=TexteA;
 FaitMarques_Options;
END;
{SendMessage(Wind,Wm_first+Wm_MButtonDown,0,0);}

end;

procedure TGeomWindow.Macro_N(No:BYTE); VAR Msg : Tmessage; begin

On_Termine:=FALSE;Quittons:=FALSE;
IF Canclose THEN
 BEGIN
   FileName0:=#0;
   StrPcopy(FileName,St_MacroNo);
   LoadFile;
 END

end;

procedure TGeomWindow.FileOpen(var Msg: TMessage); VAR N,J:BYTE;

  St:STRING;

begin

 On_TErmine:=FALSE; {empêche canclose de révoker le serveur}
 Quittons:=FALSE;
 if CanClose then
   if Application^.ExecDialog(New(PFileDialog,
       Init(@Self, PChar(sd_FileOpen),
StrCopy(FileName,'*.FIG')))) = id_Ok then
 BEGIN
  J:=1;st:=Strpas(Filename);
  While (J<6) AND (St<>St_macroJ) DO inc(J); {y est elle déjà ? }
  IF J=6 THEN {elle n'y est pas !!!}
   BEGIN
     For N:=5 DownTo 2 DO St_Macron:=St_Macron-1;
     St_Macro1:=St;
     For N:=1 TO 5 Do Macro(n);
   END;
  LoadFile;
 END;

end;

procedure TGeomWindow.Importe(var Msg: TMessage); begin

if Application^.ExecDialog(New(PFileDialog,
       Init(@Self, PChar(sd_FileOpen),
StrCopy(FileNamebit,'*.BMP')))) = id_Ok then
 BEGIN
  LoadBit(Filenamebit);
  Chargement:=TRUE; {pour effacer fenêtre wind}
  SendMessage(Wind,Wm_first+Wm_paint,0,0);
 END
 ELSE filenamebit0:=#0;

end;

{Demo Version} procedure TGeomWindow.FileSave(var Msg: TMessage); begin

if Filename0=#0 then FileSaveAs(Msg) else SaveFile;

{Demo Version}{DlgDemo := PDemo(Application^.ExecDialog(New(PDemo, init(@Self))));} end; {Demo Version}

procedure TGeomWindow.MemoriseF(var Msg: TMessage); var

 TheFile: TBufStream;
 n     : BYTE;

begin

    FileNameBis0:=#0;
    IF Msg.message=0 THEN Strcopy(FileNameBis,Nom_Fic_Anime)
                     ELSE Strcopy(FileNameBis,Nom_Fic_mem);

{ messagebox(0,FileNameBis,'debug',mb_ok); }

    TheFile.Init(FileNameBis, stCreate, 1024);
    TheFile.Put(Points);
    TheFile.Put(Textes);
    {TheFile.Put(Images);}
    TheFile.Write(FilenameBit,Sizeof(filenamebit));
    FOR n:=1 TO 5 DO
     BEGIN
      GetObject(fonten,sizeof(Tlogfont),@logfont);
      TheFile.Write(Logfont,sizeof(Tlogfont));
     END;
    Thefile.Write(No_Collect,Sizeof(No_Collect));
    Thefile.Write (Avec_Lettre, sizeof(BOOLEAn));
    Thefile.Write (Avec_Trame, sizeof(BOOLEAn));
    Thefile.Write (Avec_graduations, sizeof(BOOLEAn));
    TheFile.Write (OleFileHeader, SizeOf(TOleFileHeader));
    PGeom_Wind^.PutChildren(TheFile);

TheFile.Done;

   { IF Msg.message<>0 THEN Grise_Menu(id_restitue,FALSE);}

end;

procedure TGeomWindow.Load_OPTIONS; BEGIN

   {Avec_Axes:=NOT(Axes_Caches);
   Avec_Trame:=NOT(Trame_Cachee);}
   Courbes_Cachees:=Yatil_Courbes_Cachees;
   FaitMarques_Options;    {les cases cochees}

END;

procedure TGeomWindow.Restitue_les_points(var Msg: Tmessage); var

 TempColl : PCollection;
 TheFile  : TBufStream;

begin

 FileNameBis0:=#0;
 Strcopy(FileNameBis,Nom_Fic_Anime);
 TheFile.Init(FileNameBis, stOpen, 1024);
 TempColl := PCollection(TheFile.Get);
 TheFile.Done;
 if TempColl <> nil then
 begin
  Dispose(Points,Done);
  Points    := New(PCollection, Init(200,50));
  Points := TempColl;
  Chargement:=TRUE;
  SendMessage(Wind,Wm_first+Wm_paint,0,0);
 end;

end;

procedure TGeomWindow.Restitue(var Msg: TMessage); var

 Header: TOleFileHeader;
 TempColl : PCollection;
 TxtColl{,Imgcoll} : PCollection;
 TheFile  : TBufStream;
 n: BYTE;

begin

Quittons:=FALSE; 
IF (Msg.Message=0) OR  AND (Canclose)) THEN
BEGIn
 filenamebit0:=#0;Himage:=0;
 FileNameBis0:=#0;
 IF Msg.message=0 THEN Strcopy(FileNameBis,Nom_Fic_Anime)
    ELSE
                      begin
                           Strcopy(FileNameBis,Nom_Fic_mem);
                                Dessin_Change := true;
                      end;
 TheFile.Init(FileNameBis, stOpen, 1024);
 TempColl := PCollection(TheFile.Get);
 TxtColl  := PCollection(TheFile.Get);
 {imgColl  := PCollection(TheFile.Get);}
 TheFile.read(Filenamebit,sizeof(filenamebit));
 IF Filenamebit0<>#0 THEN loadbit(filenamebit);
 if TheFile.Status <> 0 then
   Status := em_Stream;
    FOR n:=1 TO 5 DO
     BEGIN
       TheFile.Read(Logfont,sizeof(Tlogfont));
       Create_fonte(n);
     END;
   IF TheFile.Status=StReadError THEN les_fontes_de_base(FALSE);
 Vide_Gommes;
 if TempColl <> nil then
 begin
  New_Collections(FALSE);
  IF NOT( (Quel_Axe) OR (L_Segment) OR (M_Angle) OR (On_Anime)
                      OR (Def_Texte) OR (Detruit_Bloc) OR (etat_objet) )
   THEN  activation(ValxV,ValyV,FALSE)
   ELSE
     BEGIN
      Quel_Axe:=FALSE; L_Segment:=FALSE; M_Angle:=FALSE;
      def_texte:=FALSE;Detruit_bloc:=FALSE;Etat_objet:=FALSE;
     END;
   Vni:=-1;Vno:=-1;
   If TxtColl<>nil THEN Textes:=TxtColl;
   {If TxtColl<>nil THEN images:=imgColl;}
   Points := TempColl;
   Thefile.Read(No_Collect,Sizeof(No_Collect));
   No_Collect:=Points^.count;
   IF TheFile.Status=StReadError THEN
                  BEGIN
                    {Version94:=TRUE;}
                    les_fontes_de_base(TRUE);
                    De_94_a_96;
                  END
   ELSE
    BEGIN
     Thefile.Read (Avec_Lettre, sizeof(BOOLEAn));
     Thefile.Read (Avec_Trame, sizeof(BOOLEAn));
     Thefile.Read (Avec_graduations, sizeof(BOOLEAn));
    END;
   {insertion d'objets ole -> unité oleclnt}
   PGeom_Wind^.DoneDocument;
   PGeom_Wind^.Initdocument;
   TheFile.Read (Header, SizeOf(TOleFileHeader));
   if Longint(Header) = Longint(OleFileHeader) then
   begin
     PGeom_Wind^.GetChildren(TheFile);
     if (Thefile.Status = 0) and PGeom_Wind^.CreateChildren then
                                    PGeom_Wind^.UpdateDocument;
   end;
   TheFile.Done;
   IF No_Collect<>Points^.count THEN Activation(3,15,TRUE)
                                ELSE Activation(0,1,TRUE);
   aide_ligne(fonc_aide);
   Load_OPTIONS;
   Chargement:=TRUE; {pour effacer fenêtre wind}
   SendMessage(Wind,Wm_first+Wm_paint,0,0);
   Yatil_Objects_Gommes;
   IF Gommes0<>0 THEN
   BEGIN
     Grise_Menu(id_Dernier,FALSE);
     Grise_Menu(Remet_Obj,FALSE);
   END;
 End;
END; {fin de if(not(on_anime)))}
{Version94:=FALSE;}

end;

{Demo Version} procedure TGeomWindow.FileSaveAs(var Msg: TMessage); var

 FileDlg     : PFileDialog;
 Att,Att0,Att1    : WORD;
 f           : File;
 Txt : ChaineC;

begin {Demo Version}{DlgDemo := PDemo(Application^.ExecDialog(New(PDemo, init(@Self))));}

 StrCopy(FileName, '*.fig');
 Repeat
   Att1:=Id_Ok;
   Att:=Application^.ExecDialog(New(PFileDialog,
                            Init(@Self, PChar(sd_FileSave), FileName)));
   IF Att=Id_Ok THEN
     BEGIN
      FaisName(Filename);
      Assign(f,Filename);
      GetFAttr(f,Att0);
      IF DosError=0 THEN

(*$ifndef VERSION_ESP *)

        BEGIN 
         StrCopy(Txt,'Ce fichier existe dejà.'+#13#10#13#10+'Veux tu le remplacer ?');
         Att1:=My_messageBox(Txt,2);
         IF Att1=id_No THEN StrCopy(FileName, '*.fig');
        END;
         {Att1:=MessageBox(HWindow, 'Veux tu le remplacer ?',
         'Ce fichier existe dejà', mb_OKcancel or mb_Iconquestion);}

(*$else *)

         Att1:=MessageBox(HWindow, '¿Quiere cambiarlo?',
         'Este archivo ya existe', mb_OKcancel or mb_Iconquestion);

(*$endif *)

   END;
   IF (Att=id_ok) AND (Att1<>id_Cancel) THEN
    BEGIN
     SaveFile;
     GRise_Menu(Sauve,FALSE);
    END;
 Until Att1<>id_No;

end;

function le_script:BOOLEAN; VAR imgTxt:TEXT;

   St:STRING;

BEGIN

   Textes_ciel    := New(Pcollection, Init(20,10));
  {$I-}
    Assign(imgTxt,FileScript);
    Reset(imgTxt);
    IF IoResult=0 THEN
    BEGIN
     While Not(Eof(imgtxt)) do
       BEGIN
         Readln(imgTxt,St);
         IF pos('{',St)=0 THEN {n'enregistre pas les commentaires}
         Textes_ciel^.Insert(New(PDFigures,Init(0,0,0,0,0,0,0,St,0,0,0,0)));
       END;
    close(imgTxt);
  {$I+}
    on_scripte:=TRUE;
    le_script:=TRUE;
   END
   ELSE Le_script:=FALSE;

END;

{Demo Version} procedure TgeomWindow.imagiciel; BEGIN

   if Application^.ExecDialog(New(PFileDialog,
       Init(@Self, PChar(sd_FileOpen),
StrCopy(FileScript,'*.TXT')))) = id_Ok then
       IF le_script THEN new_paint;

END;

{Cette fonction renvoie l'enregistrement n d'un fichier .AID } {le nom de l'aide si cas=0 , le nom du fichier TXT si cas=1} function Ouvre_aide(n:WORD;VAR cas:INTEGER):STRING; VAR File_aide : TEXT;

   St: STRING;
   K: INTEGER;

BEGIN

    ouvre_aide:='RIEN&&&';
    k:=0;
    St :=StrPas(Filename);
    majuscules(St);
    IF pos('.FIG',St)>0 THEN Delete(St,pos('.FIG',St),4);
    St:=St+'.AID';
  {$I-}
    Assign(File_aide,St);
    Reset(file_aide);
   IF IoResult=0 THEN
   BEGIN
     While (Not(Eof(File_aide))) AND (k<n) do BEGIN Readln(File_aide,St);inc(k) END;
      BEGIN
        IF cas=0 THEN
                   IF pos(':',St)>0 THEN delete(St,pos(':',st),80)
                                    ELSE BEGIN Str(k+1,St);St:='Aide '+st END
                 ELSE
                   BEGIN
                     IF pos(':',St)>0 THEN delete(St,1,pos(':',st));
                     vide_blanc(St);
                   END;
         Ouvre_aide:=St;
       END;
     IF Eof(File_aide) THEN Cas:=100;
    close(File_aide);
   END;
  {$I+}

END;

procedure charge_aide; VAR

   St: STRING;
   StL : ChaineL;
   K,cas: INTEGER;

BEGIN

     k:=1;Cas:=0;
     St:=ouvre_aide(k,cas);cas:=0;
     IF St<>'RIEN&&&' THEN
      BEGIN
        MenA := CreatePopUpMenu;
        REPEAT
           St:=ouvre_aide(K,cas);
           StrPcopy(Stl,st);
           AppendMenu(MenA,mf_Enabled,cm_menu_aide+k,Stl);
           inc(k);
        Until cas=100;
        insertMenu(PG_Wind^.Attr.Menu,id_HelpD,mf_popup,MenA,'Aide(s) de l''exercice');
        insertMenu(PG_Wind^.Attr.Menu,id_HelpD,mf_separator,0,Nil);
     END;

END;

function TgeomWindow.LoadFile:BOOLEAN; var

 Header: TOleFileHeader;
 TempColl,Tcoll,TxTColl{,ImgColl}: PCollection;
 TheFile: TBufStream;
 Msg0  :Tmessage;
 n: BYTE;
 Vid_existe:BOOLEAN;
 Txt : ChaineC;

begin

 IF FilenameCiel0=#0 THEN vire_menu_aide;
 Vid_existe:=FALSE;filenamebit0:=#0;Himage:=0;
 TheFile.Init(FileName, stOpen, 1024);
 TempColl := PCollection(TheFile.Get);
 IF TheFile.Status<>0 THEN
           BEGIN
             StrPcopy(Txt,'PROBLEME AU CHARGEMENT DU FICHIER'+#13#10+Filename);
             My_messageBox(Txt,1);
             TheFile.done;
             LoadFile:=FALSE;
             exit
           END
           ELSE loadFile:=TRUE;
 Tcoll    := PCollection(TheFile.Get);
 TxtColl  := PCollection(TheFile.Get);
 {ImgColl  := PCollection(TheFile.Get);}
 if Filenamebit0<>#0 THEN
   BEGIN
     TheFile.Read(Filenamebit,sizeof(filenamebit));
     loadbit(filenamebit);
   END;
 if TempColl <> nil then
 begin
   if TheFile.Status <> 0 then Status := em_Stream;
    FOR n:=1 TO 5 DO
     BEGIN
       TheFile.Read(Logfont,sizeof(Tlogfont));
       Create_fonte(n);
     END;
   IF TheFile.Status=StReadError THEN les_fontes_de_base(FALSE);
   IF pos('memlink',Filename)>0 THEN FaisName(Filename);
   New_Collections(TRUE);
  IF (Not(on_scripte)) THEN
   IF NOT( (Quel_Axe) OR (L_Segment) OR (M_Angle) OR (On_Anime)
                     OR (Def_Texte) OR (Detruit_Bloc) OR (Etat_objet) )
   THEN  activation(ValxV,ValyV,FALSE);
   Initialise;
  IF (Not(on_scripte)) THEN
  BEGIN
   Dessin_Change:=FALSE;
   Valx_V2:=-1;
   Marque_Epaiss(0);Marque_couleur(0,0);
   faisbarre; {remettre la barre figures}
   Grise_mini;       { les cases grisees}
  END;
   Points := TempColl;
   Thefile.Read(No_Collect,Sizeof(No_Collect));
   No_Collect:=Points^.count;
   IF TheFile.Status=StReadError THEN
                  BEGIN
                    les_fontes_de_base(TRUE);
                    {Version94:=TRUE;}
                    De_94_a_96;
                  END
   ELSE
    BEGIN
     Thefile.Read (Avec_Lettre, sizeof(BOOLEAn));
     Thefile.Read (Avec_Trame, sizeof(BOOLEAn));
     Thefile.Read (Avec_graduations, sizeof(BOOLEAn));
    END;
    PGeom_Wind^.DoneDocument;
    PGeom_Wind^.Initdocument;
   TheFile.Read (Header, SizeOf(TOleFileHeader));
    if Longint(Header) = Longint(OleFileHeader) then
   begin
     PGeom_Wind^.GetChildren(TheFile);
     if (Thefile.Status = 0) and PGeom_Wind^.CreateChildren then
                                    PGeom_Wind^.UpdateDocument;
   end;
   TheFile.Done; {- on referme le fichier --}
  IF NOT(on_scripte) THEN
  BEGIN
   IF No_Collect<>Points^.count THEN Activation(3,15,TRUE)
                                ELSE Activation(0,1,TRUE);
   Aide_Ligne(fonc_Aide);
   Load_OPTIONS;
  END;
   if TxtColl <> nil then Textes  := Txtcoll;
   {if ImgColl <> nil then Images  := Imgcoll;}
  IF NOT(on_scripte) THEN
   if (Tcoll=Nil) OR (TColl^.count<5) then Grise_Menu(id_bouge_exe,TRUE)
   ELSE
   begin
     GRise_Menu(id_bouge_exe,FALSE);
     GRise_Menu(id_bouge_cont,TRUE);
     Grise_Menu(id_bouge_det,FALSE);
     Video  := Tcoll;
     Vid_existe:=TRUE;
    End
 end
 ELSE BEGIN Avert(45,0);ConsTruis_Quadrillage END;
 IsDirty := True;
 IsNewFile := False;
 FIRST:=FALSE;
 IF (TempColl<>Nil) AND (Not(on_scripte)) THEN Grise_Menu(Sauve,FALSE);
  Yatil_Objects_Gommes;
  IF (Gommes0<>0) AND (Not(on_scripte)) THEN
  BEGIN
    Grise_Menu(id_Dernier,FALSE);
    Grise_Menu(Remet_Obj,FALSE);
  END;
 Msg0.message:=0;
 IF (Vid_existe) THEN MemoriseF(Msg0);
 IF (NOT(on_scripte)) THEN
  BEGIN
   IF filenameCiel0=#0 THEN charge_aide;
   Chargement:=TRUE; {pour effacer fenêtre wind}
   SendMessage(Wind,Wm_first+Wm_paint,0,0);
  END;
 {VErsion94:=FALSE;}

end;

procedure TGeomwindow.Avert(n,I:INTEGER); VAR Txt: chaineC; BEGIN

  LoadString(Hinstance, n, @Txt,sizeof(Txt));
  {Modif 007 Stef 06/07/94}
  {IF I=0 THEN}
  IF (I=0) and AvecMessageErreur THEN
  {Modif 007 Stef 06/07/94}

(*$ifndef VERSION_ESP *)

         {MessageBox(HWindow, @txt,
          'Attention', mb_OK or mb_IconExclamation)}
          My_messageBox(Txt,1)
             ELSE
              My_messageBox(Txt,3);
                 {MessageBox(HWindow, @txt,
                  'Résultat de l''analyse', mb_OK or mb_IconExclamation);}

(*$else *)

         MessageBox(HWindow, @txt,
         'Cuidado', mb_OK or mb_IconExclamation)
      ELSE
                 MessageBox(HWindow, @txt,
                 'Resultado del análisis', mb_OK or mb_Iconinformation);

(*$endif *) END;

procedure TGeomWindow.SaveFile; var

 TheFile: TBufStream;
 Msg0 : Tmessage;
 n  : BYTE;

begin

  BEGIN
    Msg0.message:=0;
    IF (Video^.count>5) THEN Restitue(Msg0);
    TheFile.Init(FileName, stCreate, 1024);
    TheFile.Put(Points);
    TheFile.Put(video);
    Thefile.Put(Textes);
    {Thefile.Put(Images);}
    TheFile.Write(Filenamebit,sizeof(Filenamebit));
    FOR n:=1 TO 5 DO
     BEGIN
      GetObject(fonten,sizeof(Tlogfont),@logfont);
      TheFile.Write(Logfont,sizeof(Tlogfont));
     END;
    Thefile.Write (No_Collect,Sizeof(No_Collect));
    Thefile.Write (Avec_Lettre, sizeof(BOOLEAn));
    Thefile.Write (Avec_Trame, sizeof(BOOLEAn));
    Thefile.Write (Avec_graduations, sizeof(BOOLEAn));
    TheFile.Write (OleFileHeader, SizeOf(TOleFileHeader));
    TheFile.Done;
    IsNewFile := False;
    Dessin_Change := False;
    IsDirty := True;
  END;

end;

procedure TgeomWindow.Configurer(var Msg: TMessage); var

 HDriver: THandle;
 Size: Integer; { Taille de la structure DevMode }
 DeviceName, DriverName, OutputName: PChar;
 DriverExtName: array0 .. 12 of Char;
 Buffer: array0 .. 80 of Char;
 Txt :ChaineC;
 P: TFarProc;
 old_DC:HDC;

begin

 old_DC:=MonDC;
 Remet_Capture;
 GetProfileString('windows', 'device', ',,', Buffer, Sizeof(Buffer));
 DeviceName := NextToken(Buffer, ',');
 DriverName := NextToken(nil, ',');
 OutputName := NextToken(nil, ',');
 if (StrLen(DeviceName) = 0) or
    (StrLen(DriverName) = 0) or (StrLen(OutputName) = 0) then
 begin

(*$ifndef VERSION_ESP *)

   StrCopy(Txt,'ERREUR !'+#13#10+'Aucune imprimante installée.');
   My_messageBox(Txt,1);
   {MessageBox(HWindow, 'Aucune imprimante installée', 'Erreur', mb_Ok);}

(*$else *)

   MessageBox(HWindow, 'Ninguna impresora instalada,', 'Error', mb_Ok);

(*$endif *)

   Exit
 end;
 StrLCat(StrCopy(DriverExtName, DriverName), '.DRV', 12);
 HDriver := LoadLibrary(DriverExtName);
 if HDriver < 32 then

(*$ifndef VERSION_ESP *)

       BEGIN
        StrCopy(Txt,'ERREUR !'+#13#10+'Echec dans le chargement du pilote.');
        My_messageBox(Txt,1);
       END
        { MessageBox(HWindow, 'Echec dans le chargement du pilote', 'Erreur',}

(*$else *)

         MessageBox(HWindow, 'No se logró cargar el piloto', 'Error',
          mb_IconExclamation or mb_Ok)

(*$endif *)

     
 else begin
   P := GetProcAddress(HDriver, 'ExtDeviceMode');
   if P <> nil then
   begin
     ExtDeviceMode := TExtDeviceMode(P);
     Size := ExtDeviceMode(HWindow, HDriver, nil, DeviceName,
OutputName, nil, nil, 0);
     GetMem(DevModeOutput, Size);
     ExtDeviceMode(HWindow, HDriver, DevModeOutput, DeviceName,
OutputName, nil, nil, dm_Prompt or dm_Copy or dm_Update or dm_Scale);
     FreeMem(DevModeOutput, Size)
   end else
   begin
     P := GetProcAddress(HDriver, 'DeviceMode');
     if P <> nil then
     begin
       DeviceMode := TDeviceMode(P);
DeviceMode(HWindow, HDriver, DeviceName, OutputName)
     end
   end;
   FreeLibrary(HDriver)
 end;
 MonDC:=Old_DC;

end;

Procedure TgeomWindow.ToucheSySDown(VAR Msg:Tmessage); begin

 Remet_capture; {redonne le focus d'entrée à la fenêtre mère}
 DefWndProc(Msg);

End;

Procedure TgeomWindow.ToucheSysUp(VAR Msg:Tmessage); begin

     if Msg.WParam = vk_F4 then Quitter(Msg)
     else  DefWndProc(Msg);

End;

Procedure TgeomWindow.ToucheDown(VAR Msg:Tmessage); VAr PCur:Tpoint; begin

     {SetCursor(curseur);} {remet le bon curseur après focus}
   IF (Msg.Wparam>=vk_Left) AND (Msg.Wparam<=Vk_Down) THEN
    BEGIN
     GetCursorPos(PCur);
     if (Msg.Wparam = Vk_Right)  THEN PCur.X:=PCur.X+1;
     if (Msg.Wparam = Vk_left)   THEN PCur.X:=PCur.X-1;
     if (Msg.Wparam = Vk_Down)   THEN PCur.Y:=PCur.Y+1;
     if (Msg.Wparam = Vk_Up)     THEN PCur.Y:=PCur.Y-1;
     SetCursorPos(PCur.X,PCur.Y);
    END;
    {SendMessage(Wind,Wm_first+Wm_MouseMove,mk_Control,100+100*65536);}
    DefWndProc(Msg);

END;

Procedure TgeomWindow.ToucheUp(VAR Msg:Tmessage); begin

    {SetCursor(curseur);} {remet le bon curseur après focus}
     if (Msg.Wparam >64)
      AND (Msg.Wparam<91)  THEN Ch_Clav:=Chr(Msg.Wparam);
     if Msg.WParam = vk_F2 then
       BEGIN
         montre_element;{reconstruction dans globales}
        IF Fonc=Reconstruire THEN SendMessage(Wind,Wm_first+wm_LButtonDown,0,0);
       END;
     if Msg.WParam = vk_F3 then
       BEGIN
         cache_element;{destruction dans globales}
         IF fonc=Reconstruire THEN SendMessage(Wind,Wm_first+wm_RButtonDown,0,0);
       END;
     if Msg.WParam = vk_F4 then zoom(1);
     if Msg.WParam = vk_F5 then zoom(0);
     if Msg.WParam = vk_F6 then zoom(2);
     if Msg.WParam = vk_F1 then
      if GetKeyState(VK_Shift) >= 0 then
{ If F1 without shift, call up help main index topic }
BEGIN
 Help:=TRUE;
 Help_Valeur:=fonc;
 Ch_Clav:='~';
 {SendMessage(Wind,Wm_first+Wm_MButtonDown,0,0);}
        New_paint;
      END;
     if (Msg.Wparam = Vk_End) AND (On_Anime) THEN Bouge_cont(Msg);
     if (Msg.Wparam = Vk_Control) THEN
               BEGIN
        Kontrol:=TRUE;
                      Kont:=NNo;X_Sav:=-1;
                    {SendMessage(Wind,Wm_first+Wm_MButtonDown,0,0);}
                      New_paint;
               END;
     if (Msg.Wparam = Vk_Home) AND (NOT(def_rect))
     AND (NOT(On_Anime))
     AND (NOT(Memorise))
     AND (NOT(Bouge_Vecteur))
     AND (NOT(BoutonDown)) THEN
      Bouge_Exe(Msg);
     if (Msg.Wparam = Vk_Insert) AND (NOT(def_rect))
     AND (NOT(On_Anime))
     AND (NOT(Memorise))
     AND (NOT(Bouge_Vecteur))
     AND (NOT(BoutonDown)) THEN
      pointXY(Msg);
     if (Msg.Wparam = Vk_Delete) AND (NOT(def_rect))
     AND (NOT(On_Anime))
     AND (NOT(Memorise))
     AND (NOT(Bouge_Vecteur))
     AND (NOT(BoutonDown)) THEN
BEGIN
  Courbe_Modif:=TRUE;
  Destruction:=TRUE;
  Raffraichir:=TRUE;
  Ch_Clav:='~';
  {SendMessage(Wind,Wm_first+Wm_MButtonDown,0,0);}
         New_paint;
END;
    DefWndProc(Msg);

END;

Procedure TgeomWindow.ToucheM(VAR Msg:Tmessage);

BEGIN
  if  then
     begin
 Help := True;
         {Help_Valeur vient de la fonction mainproc}
 {SendMessage(Wind,Wm_first+Wm_MButtonDown,0,0);}
        New_paint;
     end;

end; {Modif 006 Stef 06/07/94} procedure TgeomWindow.AvecMessageDerreur(Var Msg: Tmessage); BEGIN

AvecMessageErreur:=NOT(AvecMessageErreur);
Raffraichir :=FALSE;
FaitMarques_Options;

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

{Modif 013 Stef 06/07/94} {Modif 013 Stef 06/07/94} end.

Page top