home *** CD-ROM | disk | FTP | other *** search
/ DP Tool Club 26 / CD_ASCQ_26_1295.iso / voxrom / textes / repwin08 / annexes / scythale / xfibo.pas < prev   
Pascal/Delphi Source File  |  1995-10-01  |  17KB  |  615 lines
  1. {$C MOVEABLE DEMANDLOAD DISCARDABLE}
  2. {$A+,B-,D+,E+,F+,G+,I+,L+,N+,O-,P-,Q-,R+,S+,T-,V+,X+,Y+}
  3. {$M 1024,32768,655360}
  4. { $ M 4096 }
  5.  
  6. Program XFIBO;
  7. (*
  8.    SUITES DE FIBONACCI : CARACTERES DE DIVISIBILITE -
  9.                          RECHERCHE DE GRANDS ENTIERS PREMIERS
  10.  
  11.    PROJET PLURIDISCIPLINAIRE D'ALGEBRE DE 1ERE ANNEE E.S.I.E.A :
  12.    Réalisé par Matthieu BRIAND & Emmanuel Pierre [Scythale] classe 11
  13.  
  14.    Ce programme a pour but de faire un crible des entiers premiers à l'aide
  15.    des propriétés des suites de Fibonacci.
  16.    Il monte jusqu'à F471 (472 termes demandés !) avec 621ko de memoire...
  17.    Théoriquement, il n'y a pas de limite, seule la mémoire disponible
  18.    peut limiter le calcul.
  19.  
  20.    La complexité du code vient du type utilisé : les listes...
  21.    Toutes les opérations de base doivent être redéfinies !
  22.  
  23.    Cette structure de donnée est nécessaire : le type Entier sur 64 bits
  24.    COMP s'arrêtant à F91 !
  25.  
  26.  
  27.    Cahier des charges :
  28.           - Structure des listes : IMPLEMENTEE
  29.           - Opérations sur les listes : IMPLEMENTEES
  30.           - Calcul et affichage de Fn : IMPLEMENTE
  31.           - Si n est premier alors Fn a des chances d'être premier :
  32.             IMPLEMENTE
  33.           - Algorithme naif de recherche d'un nombre Fn premier : EN COURS
  34.           - Utilisation de la propriété des diviseurs premiers
  35.             de la forme 4t+1 d'un terme d'indice premier :
  36.             NON ENCORE IMPLEMENTE
  37.           - Chronomètrage des 2 algorithmes : NON ENCORE IMPLEMENTE
  38.           - Améliorations graphiques ? : NON ENCORE IMPLEMENTEES (?)
  39.  
  40.  
  41.    !!ATTENTION VERSION NON FINALISEE : PREVERSION DU 10 Mai 1995 !!
  42.  
  43. *)
  44.  
  45. {$G+} (* Activation du coprocesseur arithmétique ! *)
  46. {$N+}
  47.  
  48. Uses CRT;
  49.  
  50. {***************************** GESTION DES LISTES ***************************}
  51. Type
  52.     Liste   = ^Cellule;
  53.     Cellule = Record
  54.                     Caract  : Char;
  55.                     Suivant : Liste;
  56.               End;
  57.  
  58. Function Cons (Element : Char; L : Liste) : Liste;
  59. Var
  60.    Nouv_Liste : Liste;
  61.  
  62. Begin
  63.      New(Nouv_Liste);
  64.      Nouv_Liste^.Caract := Element;
  65.      Nouv_Liste^.Suivant := L;
  66.      Cons:=Nouv_Liste;
  67.      {Dispose(nouv_liste);}
  68. End;
  69.  
  70. Function Init : Liste;
  71. Begin
  72.      Init := Nil
  73. end;
  74.  
  75. Function Liste_Est_Vide(L : Liste) : Boolean;
  76. Begin
  77.      Liste_Est_Vide := (L=Nil)
  78. End;
  79.  
  80. Function Premier (L : Liste) : Char;
  81. Begin
  82.      Premier := L^.Caract
  83. End;
  84.  
  85. Function Reste (L : Liste) : Liste;
  86. Begin
  87.      Reste := L^.Suivant
  88. End;
  89. {************************ FIN DE LA GESTION DES LISTES **********************}
  90.  
  91.  
  92.  
  93. Const
  94.    zero=ord('0');
  95.  
  96. Var
  97.    Fi:     Liste;(*Fi et Fj sont 2 termes de la suite de Fibo qui se suivent*)
  98.    Fj:     Liste;
  99.  
  100.    L_tmp:  Liste;
  101.  
  102.    NB:     Integer;(* Le nombre de termes de la suite de Fibo que l'on veut *)
  103.    INDICE: Integer;(* Indice de la suite de Fibo *)
  104.  
  105.  
  106.  
  107. {══════[ Taille mémoire ]═══════════════════════════════════════════13/05/95═}
  108.  
  109. {procedure get_ram;
  110. var reg : registers;
  111.     x,y : integer;
  112. begin
  113.  reg.ax:=$4800;
  114.  reg.bx:=$ffff;
  115.  msdos(reg);
  116.  x:=wherex;y:=wherey;
  117.  gotoxy(70,1);
  118.  writeln(reg.bx,' Ko.');
  119.  gotoxy(x,y);
  120. end;}
  121.  
  122.  
  123.  
  124. procedure get_heap1;
  125. var x,y : integer;
  126. begin
  127.   x:=wherex;y:=wherey;
  128.  gotoxy(70,1);
  129.  writeln(seg(Heapend)*16+ofs(heapend)-(seg(heapPtr)*16+ofs(heapPtr)),' Ko.');
  130.  gotoxy(x,y);
  131. end;
  132.  
  133. procedure get_heap2;
  134. var x,y : integer;
  135. begin
  136.   x:=wherex;y:=wherey;
  137.  gotoxy(70,2);
  138.  writeln(seg(Heapend)*16+ofs(heapend)-(seg(heapPtr)*16+ofs(heapPtr)),' Ko.');
  139.  gotoxy(x,y);
  140. end;
  141.  
  142. procedure libere(li:liste);
  143. var
  144.   p:liste;
  145.  
  146. begin
  147.  p:=init;
  148.  
  149.  while li<>nil do
  150.  begin
  151.    P:=li;
  152.    li:=p^.suivant;
  153.    dispose(p);
  154.  end;
  155. end;
  156.  
  157.  
  158. (************************ INITIALISATION DES DONNEES ************************)
  159. Procedure INITIALISE;
  160.  
  161. Begin
  162.      Fi:=Init;
  163.      Fj:=Init;
  164.      L_tmp:=init;
  165.      INDICE:=1;
  166.      Fi:=Cons('1',Fi);
  167.      Fj:=Cons('1',Fj);
  168.      NB:=NB-2;
  169. End;
  170. (****************************************************************************)
  171.  
  172.  
  173.  
  174. {************************* AFFICHAGE D'UNE LISTE ****************************}
  175. Procedure Affiche_Liste(L : Liste);
  176. Begin
  177.      If Not (Liste_Est_Vide(L)) Then
  178.         Begin
  179.              Write (Premier(L));
  180.              Affiche_Liste(Reste(L))
  181.         End
  182. End;
  183. {************************* FIN DE L'AFFICHAGE D'UNE LISTE *******************}
  184.  
  185.  
  186.  
  187. (************************ LONGUEUR D'UNE LISTE ******************************)
  188. Function Longueur (L:Liste):integer;
  189. Var
  190.    TAILLE: Integer;
  191. Begin
  192.      TAILLE:=0;
  193.      Repeat
  194.            L:=Reste(L);
  195.            TAILLE:=TAILLE+1;
  196.      Until Liste_est_vide (L);
  197.      LONGUEUR:=TAILLE;
  198. End;
  199. (************************** FIN DE LONGUEUR *********************************)
  200.  
  201.  
  202.  
  203. {************************** INVERSE D'UNE LISTE *****************************}
  204. Function Miroir (L: liste) : Liste;
  205. Var
  206.    L_inv : Liste;
  207.  
  208. Begin
  209.      L_inv:=init;
  210.      While not (Liste_est_vide(L)) do
  211.           Begin
  212.                L_inv:=cons(premier(L),L_inv);
  213.                L:=reste (L);
  214.           End;
  215.      Miroir:=L_inv;
  216. End;
  217. {************************** FIN DE L'INVERSE ********************************}
  218.  
  219.  
  220.  
  221. (************************ TEST DU PLUS GRAND (Optimisation !) ***************)
  222. Function Test_A_Plus_Grand_Que_B (NA,NB: Liste): Integer;
  223. Var
  224.    B: Integer;
  225.    (* NB : Valeurs possibles de B:
  226.            0: Egalité de NA et NB
  227.            1: NA>NB
  228.            2: NA<NB                 *)
  229.  
  230. Begin
  231.      If Longueur(NA)>Longueur(NB) then
  232.         B:=1
  233.      Else
  234.          If Longueur(NA)<Longueur(NB) then
  235.             B:=2
  236.          Else If Longueur(NA)=Longueur(NB) Then
  237.                  Begin
  238.                       NA:=Miroir(NA);
  239.                       NB:=Miroir(NB);
  240.                       While  (premier(NA)=premier(NB)) and (not Liste_est_vide(NA)) do
  241.                             Begin
  242.                                  NA:=Reste(NA);
  243.                                  NB:=Reste(NB);
  244.                             End;
  245.                       If (Liste_est_vide(NA) and Liste_est_vide(NB)) then
  246.                          B:=0
  247.                       Else
  248.                           If ( ord (premier(NA)) )> ( ord(premier(NB)) ) then
  249.                              B:=1
  250.                           Else
  251.                               If ( ord (premier(NA)) ) < ( ord (premier(NB)) ) then
  252.                                  B:=2
  253.                   End;
  254.       Test_A_plus_grand_que_B:=B;
  255. End;
  256. (************************ FIN DU TEST DU PLUS GRAND *************************)
  257.  
  258.  
  259.  
  260. (*************************** EXTRAIT LA TETE D'UNE LISTE ********************)
  261.  
  262. Function XTRACT (N:Liste; P: Integer) : Liste;
  263. Var
  264.    RES: Liste;
  265. Begin
  266.      RES:=Init;
  267.      N:=Miroir(N);
  268.      While (not(Liste_est_vide(N)) and (P>0)) do
  269.            Begin
  270.                 RES:=Cons(Premier(N),RES);
  271.                 N:=Reste(N);
  272.                 P:=P-1;
  273.            End;
  274.      XTRACT:=RES;
  275. End;
  276. (************************* FIN DE L'EXTRACTION DE LA TETE *******************)
  277.  
  278.  
  279.  
  280. {************************* ADDITION DE DEUX LISTES **************************}
  281. Function Addition (NA,NB:liste):liste;
  282. Var
  283.     NC     : Liste;
  284.     retenue: Integer;
  285.     a,b    : Integer;
  286.  
  287. Procedure fin_d_add(var ND:liste);
  288. Begin
  289.      While not (liste_est_vide(ND)) do
  290.         Begin
  291.            NC:=cons(chr( ((ord(premier(ND))+retenue-zero) mod 10)+zero),NC);
  292.            retenue:=(ord(premier(ND))+retenue-zero) div 10;
  293.             ND:=reste(ND);
  294.         End
  295. End;
  296.  
  297. Begin
  298.      If Liste_est_vide(NA) then NA:=cons('0',NA);
  299.      If Liste_est_vide(NB) then NB:=cons('0',NB);
  300.      NC:=init;
  301.      retenue:=0;
  302.      While not ((Liste_est_vide(NA)) and (Liste_est_vide(NB))) do
  303.        If ((Liste_est_vide(NA)) and (not(Liste_est_vide(NB)))) then
  304.                        fin_d_add(NB)
  305.        Else If ((Liste_est_vide(NB)) and (not(Liste_est_vide(NA)))) then
  306.                        fin_d_add(NA)
  307.             Else
  308.                Begin
  309.                    A:=ord(premier(NA))-zero;
  310.                    B:=ord(premier(NB))-zero;
  311.                    NC:=cons( chr( ( (a+b+retenue) mod 10)+zero) , NC);
  312.                    retenue:=( (a+b+retenue) div 10 );
  313.                    NA:=reste(NA);
  314.                    NB:=reste(NB);
  315.                End;
  316.             If retenue<>0 then
  317.                NC:=cons(chr(retenue+zero),NC);
  318.      Addition:=Miroir(NC);
  319. End;
  320. {************************* FIN DE L'ADDITION DE DEUX LISTES *****************}
  321.  
  322.  
  323.  
  324. (************************* SOUSTRACTION DE DEUX LISTES **********************)
  325. Function SOUSTRACTION (NA,NB: liste) : liste;
  326.  
  327. Function SOUSTRACT (NA,NB:liste) : liste;
  328. Var
  329.    NC: Liste;
  330.    Retenue : Integer;
  331.    a,b,ret : Integer;
  332.  
  333.  
  334. (********************* Fin de la soustraction quand liste vide **************)
  335. Procedure FIN_D_SOUS(Var ND: liste);
  336. Var
  337.    C: Integer;
  338. Begin
  339.      While not (liste_est_vide(ND)) do
  340.            Begin
  341.                 RET:=0;
  342.                 C:=ord(premier(ND))-zero;
  343.                 if C<retenue then
  344.                    Begin
  345.                         C:=C+10;
  346.                         Ret:=1;
  347.                    End;
  348.                 NC:=cons(chr(c-retenue+zero),NC);
  349.                 retenue:=ret;
  350.                 ND:=reste(ND);
  351.            End
  352. End;
  353.  
  354. Begin
  355.      NC:=Init;
  356.      Retenue:=0;
  357.      A:=0;
  358.      B:=0;
  359.      While not ((liste_est_vide(NA)) and (liste_est_vide(NB))) do
  360.            if liste_est_vide(NB) then
  361.               FIN_D_SOUS(NA)
  362.            else
  363.                Begin
  364.                     A:=ord(premier(NA))-zero;
  365.                     B:=ord(premier(NB))-zero;
  366.                     ret:=0;
  367.                     If A<(B+retenue) then
  368.                        Begin
  369.                             A:=A+10;
  370.                             RET:=1;
  371.                        End;
  372.                     NC:=cons(chr(a-(b+retenue)+zero),NC);
  373.                     retenue:=ret;
  374.                     NA:=Reste(NA);
  375.                     NB:=Reste(NB);
  376.                 End;
  377.      Soustract:=Miroir(NC);
  378. End;
  379.  
  380.  
  381. Var
  382.    T: Integer;
  383. Begin
  384.      T:=Test_A_Plus_Grand_Que_B(NA,NB);
  385.      If T=0 then
  386.         Soustraction:=cons('0',nil)
  387.      Else If T=1 then
  388.                  Soustraction:=Soustract(NA,NB)
  389.           Else If T=2 then
  390.                   Soustraction:=Soustract(NB,NA);
  391. End;
  392. (******************** FIN DE SOUSTRACTION DE DEUX LISTES ********************)
  393.  
  394.  
  395.  
  396. (********************* MULTIPLICATION DE DEUX LISTES ************************)
  397.  
  398. (********************* Multiplication par un digit **************************)
  399. Function MultC (L1:Liste; d: integer):Liste;
  400. Var
  401.    Multiplic: Liste;
  402.    Retenue: Integer;
  403.  
  404. Begin
  405.      If (d<>0) then
  406.         Begin
  407.              Multiplic:=init;
  408.              Retenue:=0;
  409.              While not (Liste_est_vide(L1)) do
  410.                    Begin
  411.                         Multiplic:=cons( chr((((ord(premier(L1))-zero)*d+retenue)
  412.                                          mod 10)+zero),Multiplic);
  413.                         Retenue:=((Ord(premier(L1))-zero)*d+Retenue) div 10;
  414.                         L1:=Reste(L1);
  415.                    End;
  416.               If (Retenue<>0) then
  417.                  Multiplic:=cons( chr (retenue+zero), multiplic);
  418.               MultC:=Miroir(Multiplic);
  419.         End
  420.      Else MultC:=cons('0',Nil);
  421. End;
  422.  
  423.  
  424. (******************** Multiplication généralisée ****************************)
  425. Function Multiplication (N1,N2: Liste) : Liste;
  426.  
  427. Function Multiplicat (L1,L2: Liste): Liste;
  428. Var
  429.    L_totale    : Liste;
  430.    L_partielle : Liste;
  431.    I           : Integer;
  432.    N           : Integer;
  433.    Puiss       : Integer;
  434.  
  435. Begin
  436.      L_Totale:=Init;
  437.      L_partielle:=Init;
  438.      Puiss:=1;
  439.      For I:=1 to Longueur (L2) do
  440.          Begin
  441.               L_partielle:=(MultC(L1,( ord(premier(L2))) - zero));
  442.               For N:=1 to (Puiss-1) do
  443.                   Begin
  444.                        L_partielle:=Cons('0',L_partielle);
  445.                   End;
  446.               Puiss:=Puiss+1;
  447.               L_totale:=Addition(L_totale,L_partielle);
  448.               L2:=Reste(L2);
  449.          End;
  450.      Multiplicat:=L_Totale;
  451. End;
  452.  
  453. Begin
  454.      If longueur(N1)<Longueur(N2) then
  455.         Multiplication:=Multiplicat(N2,N1)
  456.      Else Multiplication:=Multiplicat(N1,N2);
  457. End;
  458. (***************************** FIN DE MULTIPLICATION ************************)
  459.  
  460.  
  461.  
  462. (************************* PUISSANCE DE 10 **********************************)
  463. Function PUISS_10 (N:Liste; NB_ZEROS: Integer) : Liste;
  464. Var
  465.    I: Integer;
  466.  
  467. Begin
  468.      For I:=NB_Zeros Downto 0 do
  469.                      N:=Multiplication (N,Cons('1',Cons('0',nil)));
  470.      Puiss_10:=N;
  471. End;
  472. (************************** FIN DE PUISSANCE DE 10 **************************)
  473.  
  474.  
  475.  
  476. (***************************** DIVISION DE DEUX LISTES **********************)
  477. Function DIVISION (NA,NB:liste; Var RESTE: Liste):liste;
  478.  
  479.  
  480. Function Divis (N1,N2: Liste; RESULT : Liste; Var RESTE: Liste) : Liste;
  481.  
  482. Begin
  483.      If TEST_A_PLUS_GRAND_QUE_B (Xtract(N1,LONGUEUR(N2)),N2)=2 then
  484.       If TEST_A_PLUS_GRAND_QUE_B (Xtract(N1,LONGUEUR(N2)+1),N2)=2 then
  485.        Begin
  486.           Divis:=Miroir(Result);
  487.           Reste:=N1;
  488.        End
  489.       Else Divis:=Divis (Soustraction(N1,Puiss_10(N2,Longueur(N1)-Longueur(N2)-1))
  490.                          ,N2,Miroir(Addition(miroir(Result),Cons('1',nil)))
  491.                          ,reste)
  492.      Else Divis:=Divis (Soustraction(N1,Puiss_10(N2,Longueur(N1)-Longueur(N2))),
  493.                          N2,Miroir(Addition(Miroir(Result),Cons('1',nil)))
  494.                          ,reste)
  495. End;
  496.  
  497. Begin
  498.      If TEST_A_PLUS_GRAND_QUE_B(NA,NB)=1
  499.      Then Division:=Divis(NA,NB,nil,reste)
  500.      Else If TEST_A_PLUS_GRAND_QUE_B(NA,NB)=2
  501.           Then Division:=Divis(NB,NA,nil,reste)
  502.           Else Division:=nil
  503. End;
  504. (**************************** FIN DE LA DIVISION ****************************)
  505.  
  506.  
  507.  
  508. (**************************** MODULO SUR UNE LISTE **************************)
  509.  
  510. Function MODULO(NA,NB:Liste):Liste;
  511. Var
  512.    DIVI,RESTE:Liste;
  513.  
  514. Begin
  515.    Divi:=init;
  516.    Reste:=init;
  517.    Divi:=Division(NA,NB,RESTE);
  518.    Modulo:=reste;
  519. End;
  520. (**************************** FIN DU MODULO *********************************)
  521.  
  522.  
  523.  
  524. (***************************** INTEGER PREMIER ?  ***************************)
  525.  
  526.  
  527. Function ENT_PREMIER (ENTIER: Integer): Boolean;
  528. Var
  529.    I:      Integer;
  530.    VALEUR: Boolean;
  531.  
  532. Begin
  533.    (* Si l'indice n'est pas premier, alors le nombre de Fibonacci n'est pas premier *)
  534.    VALEUR:=True;
  535.    I:=2;
  536.    While ( (I<=(ENTIER div 2)) and VALEUR ) do
  537.          Begin
  538.          if ENTIER mod I=0
  539.          Then VALEUR:=False;
  540.          I:=I+1;
  541.          End;
  542.    ENT_PREMIER:=VALEUR;
  543. End;
  544. (****************************** FIN INTEGER PREMIER ? ***********************)
  545.  
  546.  
  547.  
  548. (***************************** LISTE PREMIER ? ALGO NAIF ********************)
  549. Function NAIF (L:Liste): Boolean;
  550. Begin
  551. End;
  552. (************************* FIN DE LISTE PREMIER ? ALGO NAIF *****************)
  553.  
  554.  
  555.  
  556.  
  557. (***************************** CORPS DU PROGRAMME ***************************)
  558. Begin
  559.      Clrscr;
  560.      Writeln ('SUITE DE FIBONACCI : APPLICATION A LA RECHERCHE DE GRANDS ENTIERS :');
  561.      Writeln ('===================================================================');
  562.      Writeln (' PREVERSION DU 13 MAI 1995 NON FINALISEE !');
  563.      Write ('Combien de termes voulez vous (nombre pair <= 479 ) ? ');
  564.      Readln (NB);
  565.  
  566.      (* L'affichage des résultats *)
  567.      INITIALISE;
  568.      Write ('   F 0= ');  Affiche_Liste(Fi);
  569.      Writeln;
  570.      Write ('   F 1= ');  Affiche_Liste(Fj);
  571.      Writeln;
  572.  
  573.      If INDICE<NB then
  574.      While INDICE<=NB do
  575.         Begin
  576.  
  577.           {L_tmp:=Addition(Fi,Fj);
  578.           libere(fi);
  579.           fi:=l_tmp;
  580.           libere(l_tmp);}
  581.           Fi:=Addition(Fi,Fj);
  582.  
  583.           INDICE:=INDICE+1;
  584.           Write ('   F',INDICE:2,'= '); Affiche_Liste(Miroir(Fi));
  585.           If ENT_PREMIER(INDICE) then Begin
  586.                                  write (' peut être premier (INDICE PREMIER)');
  587.                               (*If NAIF then write (' Premier (ALGO NAIF) ');
  588.                                         else write (' Divisible (ALGO NAIF) ');
  589.                                *)
  590.                                       End;
  591.           Writeln;
  592.  
  593.       {    L_tmp:=Addition(Fi,Fj);
  594.           libere(fj);
  595.           fj:=l_tmp;
  596.           libere(l_tmp);}
  597.           Fj:=Addition(Fi,Fj);
  598.  
  599.  
  600.           INDICE:=INDICE+1;
  601.           Write ('   F',INDICE:2,'= '); Affiche_Liste(Miroir(Fj));
  602.           If ENT_PREMIER(INDICE) then Begin
  603.                                  write (' peut être premier (INDICE PREMIER)');
  604.                               (*If NAIF then write (' Premier (ALGO NAIF) ');
  605.                                         else write (' Divisible (ALGO NAIF) ');
  606.                                *)
  607.                                       End;
  608.           Writeln;
  609.           If ((INDICE mod 39)=0) or ((INDICE mod 87)=0) then Readln;
  610.         End;
  611.      Readln;
  612.  
  613. End.
  614. (****************************************************************************)7
  615.