Premier.pas

Un article de Wikipedia.

Factorisation en nombres premiers

  1. program premier;
  2. {$i PalmAPI2.pas}
  3. {$i Menu.pas}
  4. type plistint=^listint;
  5. listint=record
  6. val:integer;
  7. next:plistint;
  8. end;
  9. var premier,resultat:plistint;
  10. num,dummy:integer;
  11. function addint(plist:plistint;val:integer):plistint;
  12. var pactuel:plistint;
  13. begin
  14. pactuel:=plist;
  15. if (pactuel <> nil) then
  16. begin
  17. while (pactuel^.next <> nil)
  18. do
  19. pactuel:=pactuel^.next;
  20. new(pactuel^.next);
  21. pactuel^.next^.val:=val;
  22. pactuel^.next^.next:=nil;
  23. end
  24. else
  25. begin
  26. new(pactuel);
  27. pactuel^.val:=val;
  28. pactuel^.next:=nil;
  29. plist:=pactuel;
  30. end;
  31. addint:=plist;
  32. end;
  33. procedure viewlist(list:plistint);
  34. var pactuel:plistint;
  35. begin
  36. if (list <> nil) then
  37. begin
  38. pactuel:=list;
  39. while (pactuel^.next <> nil) do
  40. begin
  41. write(pactuel^.val,',');
  42. pactuel:=pactuel^.next;
  43. end;
  44. writeln(pactuel^.val);
  45. end
  46. else
  47. writeln('aucun');
  48. end;
  49. function nextprime:integer;
  50. var pactuel:plistint;
  51. candidat:integer;
  52. found,search:boolean;
  53. begin
  54. if (premier = nil) then
  55. begin
  56. premier:=addint(premier,2);
  57. premier:=addint(premier,3);
  58. end;
  59. pactuel:=premier;
  60. while (pactuel^.next <> nil) do
  61. pactuel:=pactuel^.next;
  62. candidat:=pactuel^.val;
  63. found:=false;
  64. while (not found) do
  65. begin
  66. candidat:=candidat+2;
  67. pactuel:=premier;
  68. search:=true;
  69. while (search) do
  70. begin
  71. if (candidat mod pactuel^.val = 0) then
  72. search:=false
  73. else
  74. begin
  75. if (pactuel^.next <> nil) then
  76. pactuel:=pactuel^.next
  77. else
  78. search:=false;
  79. if (pactuel^.val > sqrt(candidat)) then
  80. begin
  81. search:=false;
  82. found:=true;
  83. end;
  84. end;
  85. end;
  86. end;
  87. premier:=addint(premier,candidat);
  88. nextprime:=candidat;
  89. gotoxy(20,1);
  90. write(candidat:10);
  91. end;
  92. function factorise(val:integer):plistint;
  93. var pactuel,presultat:plistint;
  94. num,prime:integer;
  95. begin
  96. presultat:=nil;
  97. num:=val;
  98. if (num < 0) then
  99. num:=-num;
  100. if (num > 1) then
  101. begin
  102. pactuel:=premier;
  103. prime:=pactuel^.val;
  104. while (prime <= sqrt(num)) do
  105. begin
  106. while (num mod prime = 0) do
  107. begin
  108. presultat:=addint(presultat,prime);
  109. num:=num div prime;
  110. end;
  111. if (pactuel^.next = nil) then
  112. prime:=nextprime;
  113. if (pactuel^.next <> nil) then
  114. begin
  115. pactuel:=pactuel^.next;
  116. prime:=pactuel^.val;
  117. end;
  118. end;
  119. if (num <> 1) then
  120. begin
  121. presultat:=addint(presultat,num);
  122. end;
  123. end
  124. else
  125. presultat:=addint(presultat,num);
  126. factorise:=presultat;
  127. end;
  128. procedure menu2;
  129. var select,num:integer;
  130. resultat:plistint;
  131. s:string;
  132. m:menu;
  133. begin
  134. initmenu(m);
  135. titlemenu(m,'Menu');
  136. addmenuitem(m,'Nombre a factoriser');
  137. repeat
  138. select:=selectmenu(m);
  139. case select of
  140. 1:begin
  141. write('Nombre : ');
  142. readln(s);
  143. num:=StrAtoI(s);
  144. resultat:=factorise(num);
  145. gotoxy(1,12);
  146. write(num,':');
  147. viewlist(resultat);
  148. read(s);
  149. end;
  150. end;
  151. until select = 0;
  152. clrscr;
  153. writeln;
  154. writeln;
  155. writeln;
  156. writeln(' ':5,'A bientot');
  157. end;
  158. begin
  159. premier:=nil;
  160. dummy:=nextprime;
  161. menu2;
  162. end.