Data commit

Task/Prime-triangle/Free-Pascal/prime-triangle.pas

@@ -0,0 +1,116 @@
+program PrimePyramid;
+{$IFDEF FPC}
+  {$MODE delphi}{$Optimization ON,ALL}{$CodeAlign proc=32}
+{$IFEND}
+const
+  MAX = 21;//max 8 different  SumToPrime : array[0..MAX,0..7] of byte;
+  //MAX = 57;//max 16 different SumToPrime : array[0..MAX,0..15] of byte;
+  cMaxAlign32 = (((MAX-1)DIV 32)+1)*32-1;//MAX > 0
+type
+  tPrimeRange = set of 0..127;
+var
+  SetOfPrimes :tPrimeRange =[2,3,5,7,11,13,17,19,23,29,31,37,41,43,47,
+                             53,59,61,67,71,73,79,83,89,97,101,103,107,
+                             109,113,127];
+
+  SumToPrime : array[0..cMaxAlign32,0..7] of byte;
+//  SumToPrime : array[0..MAX,0..15] of byte;
+  SumToPrimeMaxIdx,
+  SumMaxIdx,
+  Solution,
+  FirstSolution    : array[0..cMaxAlign32] of byte;
+
+  free : array[0..cMaxAlign32] of boolean;
+
+  maxused : integer;
+  digitcount,SolCount : integer;
+
+procedure InitSumToPrime;
+var
+  i,j,idx : integer;
+begin
+  For i := 1 to MAX do
+  Begin
+    idx := 0;
+    For j := 1 to MAX do
+      If (i+j) in SetOfPrimes then
+      Begin
+        SumToPrime[i,idx] := j;
+        inc(idx);
+      end;
+    SumToPrimeMaxIdx[i] := idx;
+  end;
+end;
+
+procedure InitFree(maxused : integer);
+var
+  i,j : Integer;
+begin
+  For i := 0 to 1 do
+    Free[i] := false;
+  For i := 2 to maxused-1 do
+    Free[i] := true;
+  For i := maxused to MAX do
+    Free[i] := false;
+  // search maxidx of max neighour sum to prime
+  For i := 1 to maxused-1 do
+  begin
+    j := SumToPrimeMaxIdx[i]-1;
+    while SumToPrime[i,j] > maxused-1 do
+      j -= 1;
+    SumMaxIdx[i] := j+1;
+  end;
+end;
+
+procedure CountSolution(digit:integer);
+begin
+  // check if maxused can follow
+  if (digit+maxused) in SetOfPrimes then
+  Begin
+    if solcount = 0 then
+       FirstSolution := Solution;
+    inc(solCount);
+  end;
+end;
+
+procedure checkDigits(digit:integer);
+var
+  idx,nextDigit: integer;
+begin
+  idx := 0;
+  repeat
+    nextDigit := SumToPrime[digit,idx];
+    if Free[nextdigit] then
+    Begin
+      Solution[digitcount] := nextDigit;
+      dec(digitcount);
+      IF digitcount = 0 then
+        CountSolution(nextDigit);
+      free[nextdigit]:= false;
+      checkDigits(nextdigit);
+      inc(digitcount);
+      free[nextdigit]:= true;
+    end;
+    inc(idx);
+  until idx >= SumMaxIdx[digit];
+end;
+
+var
+  i,j : integer;
+Begin
+  InitSumToPrime;
+  writeln('number|   count|  first solution');
+  writeln('   2|         1|  1  2');
+  For i := 3 to 20 do
+  Begin
+    maxused := i;
+    InitFree(i);
+    digitcount := i-2;
+    solCount := 0;
+    checkDigits(1);
+    write(i:4,'|',solcount:10,'|  1');
+    For j := i-2 downto 1 do
+      write( FirstSolution[j]:3);
+    writeln(i:3);
+  end;
+end.