Data commit

Task/Hamming-numbers/Pascal/hamming-numbers-1.pas

@@ -0,0 +1,75 @@
+program HammNumb;
+{$IFDEF FPC}
+  {$MODE DELPHI}
+  {$OPTIMIZATION ON}
+{$ELSE}
+  {$APPTYPE CONSOLE}
+{$ENDIF}
+{
+type
+  NativeUInt = longWord;
+}
+var
+  pot   : array[0..2] of NativeUInt;
+
+function NextHammNumb(n:NativeUInt):NativeUInt;
+var
+  q,p,nr : NativeUInt;
+begin
+  repeat
+    nr := n+1;
+    n := nr;
+
+    p := 0;
+    while NOT(ODD(nr)) do
+    begin
+      inc(p);
+      nr := nr div 2;
+    end;
+    Pot[0]:= p;
+
+    p := 0;
+    q := nr div 3;
+    while q*3=nr do
+    Begin
+      inc(P);
+      nr := q;
+      q := nr div 3;
+    end;
+    Pot[1] := p;
+
+    p := 0;
+    q := nr div 5;
+    while q*5=nr do
+    Begin
+      inc(P);
+      nr := q;
+      q := nr div 5;
+    end;
+    Pot[2] := p;
+
+  until nr = 1;
+  result:= n;
+end;
+
+procedure Check;
+var
+  i,n: NativeUint;
+begin
+  n := 1;
+  for i := 1 to 20 do
+  begin
+    n := NextHammNumb(n);
+    write(n,' ');
+  end;
+  writeln;
+  writeln;
+  n := 1;
+  for i := 1 to 1690 do
+    n := NextHammNumb(n);
+  writeln('No ',i:4,' | ',n,' = 2^',Pot[0],' 3^',Pot[1],' 5^',Pot[2]);
+end;
+
+Begin
+  Check;
+End.

Task/Hamming-numbers/Pascal/hamming-numbers-2.pas

@@ -0,0 +1,244 @@
+{$OPTIMIZATION LEVEL4}
+program Hammings(output);
+
+{$mode objfpc}
+uses Math, SysUtils;
+
+const
+  lb22 : Double = 1.0; (* log base 2 of 2 *)
+  lb23 : Double = 1.58496250072115618147; (* log base 2 of 3 *)
+  lb25 : Double = 2.32192809488736234781; (* log base 2 of 5 *)
+
+type
+  TLogRep = record
+    lr : Double;
+    x2, x3, x5 : Word;
+  end;
+
+const oneLogRep : TLogRep = (lr:0.0; x2:0; x3:0; x5:0);
+
+function LogRepMult2(lr : TLogRep) : TLogRep;
+begin
+  Result := lr;
+  Result.lr := lr.lr + lb22;
+  Result.x2 := lr.x2 + 1
+end;
+
+function LogRepMult3(lr : TLogRep) : TLogRep;
+begin
+  Result := lr;
+  Result.lr := lr.lr + lb23;
+  Result.x3 := lr.x3 + 1
+end;
+
+function LogRepMult5(lr : TLogRep) : TLogRep;
+begin
+  Result := lr;
+  Result.lr := lr.lr + lb25;
+  Result.x5 := lr.x5 + 1
+end;
+
+function LogRep2QWord(lr : TLogRep) : QWord;
+function xpnd(x : Word; m : QWord) : QWord;
+var mlt : QWord;
+begin
+  mlt := m;
+  Result := 1;
+  while x > 0 do
+  begin
+    if x and 1 > 0 then Result := Result * mlt;
+    mlt := mlt * mlt; x := x shr 1
+  end
+end;
+begin
+  Result := xpnd(lr.x2, 2) * xpnd(lr.x3, 3) * xpnd(lr.x5, 5)
+end;
+
+function LogRep2String(lr : TLogRep) : AnsiString;
+type TBI = array of LongWord;
+     TDigitStr = String[1];
+function mul2(bi : TBI) : TBI;
+var cry : QWord;
+    i : Integer;
+begin
+  cry := 0;
+  for i := 0 to High(bi) do
+  begin
+    cry := (QWord(bi[i]) shl 1) + cry; bi[i] := cry; cry := cry shr 32
+  end;
+  if cry <> 0 then
+  begin
+    SetLength(bi, Length(bi) + 1); bi[High(bi)] := cry
+  end;
+  Result := bi
+end;
+function add(bia : TBI; bib : TBI) : TBI;
+var cry : QWord;
+    i : Integer;
+begin
+  cry := 0;
+  for i := 0 to High(bia) do
+  begin
+    cry := QWord(bia[i]) + QWord(bib[i]) + cry;
+    bia[i] := cry; cry := cry shr 32
+  end;
+  if cry <> 0 then
+  begin
+    SetLength(bia, Length(bia) + 1); bia[High(bia)] := cry
+  end;
+  Result := bia
+end;
+function div10(bi : TBI) : TDigitStr;
+var brw : QWord;
+    i : Integer;
+begin
+  brw := 0;
+  for i := High(bi) downto 0 do
+  begin
+    brw := (brw shl 32) + QWord(bi[i]);
+    bi[i] := brw div 10; brw := brw - QWord(bi[i]) * 10
+  end;
+  Result := IntToStr(brw)
+end;
+var v : Word;
+    xpnd, xpndt : TBI;
+begin
+  Result := '';
+  SetLength(xpnd, 1); xpnd[0] := 1;
+  for v := lr.x2 downto 1 do xpnd := mul2(xpnd);
+  for v := lr.x3 downto 1 do
+  begin
+    xpndt := Copy(xpnd, 0, Length(xpnd));
+    xpnd := mul2(xpnd); xpnd := add(xpnd, xpndt)
+  end;
+  for v := lr.x5 downto 1 do
+  begin
+    xpndt := Copy(xpnd, 0, Length(xpnd)); xpnd := mul2(xpnd);
+    xpnd := mul2(xpnd); xpnd := add(xpnd, xpndt)
+  end;
+  while Length(xpnd) > 0 do
+  begin
+    Result := div10(xpnd) + Result;
+    if xpnd[High(xpnd)] <= 0 then SetLength(xpnd, Length(xpnd) - 1)
+  end
+end;
+
+type
+  TLogReps = array of TLogRep;
+  THammings = class
+  private
+    FCurrent : TLogRep;
+    FBA, FMA : TLogReps;
+    Fnxt2, Fnxt3, Fnxt5, Fmrg35 : TLogRep;
+    FBb, FBe, FMb, FMe : Integer;
+  public
+    constructor Create;
+    function GetEnumerator : THammings;
+    function MoveNext : Boolean;
+    property Current : TLogRep read FCurrent;
+  end;
+
+constructor THammings.Create;
+begin
+  inherited Create;
+  FCurrent := oneLogRep; FCurrent.lr := -1.0;
+  SetLength(FBA, 4); SetLength(FMA, 4);
+  Fnxt5 := LogRepMult5(oneLogRep);
+  Fmrg35 := LogRepMult3(oneLogRep);
+  Fnxt3 := LogRepMult3(Fmrg35);
+  Fnxt2 := LogRepMult2(oneLogRep);
+  FBb := 0; FBe := 0; FMb := 0; FMe := 0
+end;
+
+function THammings.GetEnumerator : THammings;
+begin
+  Result := Self
+end;
+
+function THammings.MoveNext : Boolean;
+var blen, mlen, i, j : Integer;
+begin
+  if FCurrent.lr < 0.0 then FCurrent.lr := 0.0 else
+  begin
+    blen := Length(FBA);
+    if FBb >= blen shr 1 then
+    begin
+      i := 0;
+      for j := FBb to FBe - 1 do
+      begin
+        FBA[i] := FBA[j]; Inc(i)
+      end;
+      FBe := FBe - FBb; FBb := 0
+    end;
+    if FBe >= blen then SetLength(FBA, blen shl 1);
+    if Fnxt2.lr < Fmrg35.lr then
+    begin
+      FCurrent := Fnxt2; FBA[FBe] := FCurrent;
+      Fnxt2 := LogRepMult2(FBA[FBb]); Inc(FBb)
+    end
+    else
+    begin
+      mlen := Length(FMA);
+      if FMb >= mlen shr 1 then
+      begin
+        i := 0;
+        for j := FMb to FMe - 1 do
+        begin
+          FMA[i] := FMA[j]; Inc(i)
+        end;
+        FMe := FMe - FMb; FMb := 0
+      end;
+      if FMe >= mlen then SetLength(FMA, mlen shl 1);
+      if Fmrg35.lr < Fnxt5.lr then
+      begin
+        FCurrent := Fmrg35; FMA[FMe] := FCurrent;
+        Fnxt3 := LogRepMult3(FMA[FMb]); Inc(FMb)
+      end
+      else
+      begin
+        FCurrent := Fnxt5; FMA[FMe] := FCurrent;
+        Fnxt5 := LogRepMult5(Fnxt5)
+      end;
+      if Fnxt3.lr < Fnxt5.lr then Fmrg35 := Fnxt3 else Fmrg35 := Fnxt5;
+      FBA[FBe] := FCurrent; Inc(FMe)
+    end;
+    Inc(FBe)
+  end;
+  Result := True
+end;
+
+var elpsd : QWord;
+    count : Integer;
+    h : TLogRep;
+
+begin
+  write('The first 20 Hamming numbers are: ');
+  count := 0;
+  for h in THammings.Create do
+  begin
+    Inc(count);
+    if count > 20 then break;
+    write(' ', LogRep2QWord(h));
+  end;
+  writeln('.');
+  count := 1;
+  for h in THammings.Create do
+  begin
+    Inc(count);
+    if count > 1691 then break;
+  end;
+  writeln('The 1691st Hamming number is ', LogRep2QWord(h), '.');
+  elpsd := GetTickCount64;
+  count := 1;
+  for h in THammings.Create do
+  begin
+    Inc(count);
+    if count > 1000000 then break;
+  end;
+  elpsd := GetTickCount64 - elpsd;
+  writeln('The millionth Hamming number is approximately ', 2.0**h.lr, '.');
+  write('The millionth Hamming triplet is ');
+  writeln('2^', h.x2, ' * 3^', h.x3, ' * 5^', h.x5, '.');
+  writeln('The millionth Hamming number is ', LogRep2String(h), '.');
+  writeln('This last took ', elpsd, ' milliseconds.')
+end.

Task/Hamming-numbers/Pascal/hamming-numbers-3.pas

@@ -0,0 +1,334 @@
+program hammNumb;
+{$IFDEF FPC}
+   {$MODE DELPHI}
+   {$OPTIMIZATION ON,ALL}
+   {$ALIGN 16}
+{$ELSE}
+  {$APPTYPE CONSOLE}
+{$ENDIF}
+uses
+  sysutils;
+const
+  maxPrimFakCnt = 3;//3 or 3+8 if tNumber= double, else -1 for extended to keep data aligned
+  minElemCnt = 10;
+type
+  tPrimList = array of NativeUint;
+  tnumber = double;
+  tpNumber= ^tnumber;
+  tElem = record
+             n   : tnumber;//ln(prime[0]^Pots[0]*...
+             Pots: array[0..maxPrimFakCnt] of word;
+           end;
+  tpElem  = ^tElem;
+  tElems  = array of tElem;
+  tElemArr  = array [0..0] of tElem;
+  tpElemArr  = ^tElemArr;
+
+  tpFaktorRec = ^tFaktorRec;
+  tFaktorRec = record
+                 frElems  : tElems;
+                 frInsElems: tElems;
+                 frAktIdx : NativeUint;
+                 frMaxIdx : NativeUint;
+                 frPotNo  : NativeUint;
+                 frActPot : NativeUint;
+                 frNextFr : tpFaktorRec;
+                 frActNumb: tElem;
+                 frLnPrime: tnumber;
+               end;
+  tArrFR = array of tFaktorRec;
+
+var
+  Pl : tPrimList;
+  ActIndex  : NativeUint;
+  ArrInsert : tElems;
+
+procedure PlInit(n: integer);
+const
+ cPl : array[0..11] of byte=(2,3,5,7,11,13,17,19,23,29,31,37);
+var
+  i : integer;
+Begin
+  IF n>High(cPl)+1 then
+     n := High(cPl)
+  else
+      IF n < 0 then
+         n := 1;
+  setlength(Pl,n);
+  dec(n);
+  For i := 0 to n do
+    Pl[i] := cPl[i];
+end;
+
+procedure AusgabeElem(pElem: tElem);
+var
+  i : integer;
+Begin
+  with pElem do
+  Begin
+    IF n < 23 then
+    begin
+      write(round(exp(n)),' ');
+      if n < ln(100)then
+         EXIT;
+    end
+    else
+      write('ln ',n:13:7);
+    For i := 0 to maxPrimFakCnt-1 do
+      write(' ',PL[i]:2,'^',Pots[i]);
+  end;
+  writeln
+end;
+
+//LoE == List of Elements
+function LoEGetNextNumber(pFR :tpFaktorRec):tElem;forward;
+
+procedure LoECreate(const Pl: tPrimList;var FA:tArrFR);
+var
+  i : integer;
+Begin
+  setlength(ArrInsert,100);
+  setlength(FA,Length(PL));
+  For i := 0 to High(PL) do
+    with FA[i] do
+    Begin
+      //automatic zeroing
+      IF i < High(PL) then
+      Begin
+        setlength(frElems,minElemCnt);
+        setlength(frInsElems,minElemCnt);
+        frNextFr := @FA[i+1]
+      end
+      else
+      Begin
+        setlength(frElems,2);
+        setlength(frInsElems,0);
+        frNextFr := NIL;
+      end;
+      frPotNo  := i;
+      frLnPrime:= ln(PL[i]);
+      frMaxIdx := 0;
+      frAktIdx := 0;
+      frActPot := 1;
+      With frElems[0] do
+      Begin
+        n := frLnPrime;
+        Pots[i]:= 1;
+      end;
+      frActNumb := frElems[0];
+  end;
+end;
+
+
+procedure LoEFree(var FA:tArrFR);
+var
+  i : integer;
+Begin
+  For i := High(FA) downto Low(FA) do
+    setlength(FA[i].frElems,0);
+  setLength(FA,0);
+end;
+
+function LoEGetActElem(pFr:tpFaktorRec):tElem;
+Begin
+  with pFr^ do
+    result := frElems[frAktIdx];
+end;
+
+function LoEGetActLstNumber(pFr:tpFaktorRec):tpNumber;
+Begin
+  with pFr^ do
+    result := @frElems[frAktIdx].n;
+end;
+
+procedure LoEIncInsArr(var a:tElems);
+Begin
+  setlength(a,Length(a)*8 div 5);
+end;
+
+procedure LoEIncreaseElems(pFr:tpFaktorRec;minCnt:NativeUint);
+var
+  newLen: NativeUint;
+Begin
+  with pFR^ do
+  begin
+    newLen := Length(frElems);
+    minCnt := minCnt+frMaxIdx;
+    repeat
+      newLen := newLen*8 div 5 +1;
+    until newLen > minCnt;
+    setlength(frElems,newLen);
+  end;
+end;
+
+procedure LoEInsertNext(pFr:tpFaktorRec;Limit:tnumber);
+var
+  pNum : tpNumber;
+  pElems : tpElemArr;
+  cnt,i,u : NativeInt;
+begin
+  with pFr^ do
+  Begin
+    //collect numbers of heigher primes
+    cnt := 0;
+    pNum := LoEGetActLstNumber(frNextFr);
+    while Limit > pNum^ do
+    Begin
+      frInsElems[cnt] := LoEGetNextNumber(frNextFr);
+//   writeln( 'Ins ',frInsElems[cnt].n:10:8,' < ',pNum^:10:8);
+
+      inc(cnt);
+      IF cnt > High(frInsElems) then
+        LoEIncInsArr(frInsElems);
+      pNum := LoEGetActLstNumber(frNextFr);
+    end;
+
+    if cnt = 0 then
+     EXIT;
+
+    i := frMaxIdx;
+    u := frMaxIdx+cnt+1;
+
+    IF u > High(frElems) then
+      LoEIncreaseElems(pFr,cnt);
+
+    IF frPotNo =  0 then
+      inc(ActIndex,u);
+    //Merge
+    pElems := @frElems[0];
+    dec(cnt);
+    dec(u);
+    frMaxIdx:= u;
+    repeat
+// writeln(i:10,cnt:10,u:10); writeln( pElems^[i].n:10:8,' < ',frInsElems[cnt].n:10:8);
+      IF pElems^[i].n < frInsElems[cnt].n then
+      Begin
+        pElems^[u] := frInsElems[cnt];
+        dec(cnt);
+      end
+      else
+      Begin
+        pElems^[u] := pElems^[i];
+        dec(i);
+      end;
+      dec(u);
+    until (i<0) or (cnt<0);
+    IF i < 0 then
+      For u := cnt downto 0 do
+        pElems^[u] := frInsElems[u];
+
+  end;
+end;
+
+procedure LoEAppendNext(pFr:tpFaktorRec;Limit:tnumber);
+var
+  pNum : tpNumber;
+  pElems : tpElemArr;
+  i : NativeInt;
+begin
+  with pFr^ do
+  Begin
+    i := frMaxIdx+1;
+    pElems := @frElems[0];
+    pNum := LoEGetActLstNumber(frNextFr);
+    while Limit > pNum^ do
+    Begin
+      IF i > High(frElems) then
+      Begin
+        LoEIncreaseElems(pFr,10);
+        pElems := @frElems[0];
+      end;
+      pElems^[i] := LoEGetNextNumber(frNextFr);
+      inc(i);
+      pNum := LoEGetActLstNumber(frNextFr);
+    end;
+    inc(ActIndex,i);
+    frMaxIdx:= i-1;
+  end;
+end;
+
+procedure LoENextList(pFr:tpFaktorRec);
+var
+  pElems : tpElemArr;
+  j : NativeUint;
+begin
+  with pFR^ do
+  Begin
+    //increase Elements by factor
+    pElems := @frElems[0];
+    for j := frMaxIdx Downto 0 do
+      with pElems^[j] do
+      Begin
+        n := n+frLnPrime;
+        inc(Pots[frPotNo]);
+      end;
+    //x^j -> x^(j+1)
+    j := frActPot+1;
+    with frActNumb do
+    begin
+      n:= j*frLnPrime;
+      Pots[frPotNo]:= j;
+    end;
+    frActPot := j;
+    //if something follows
+    IF frNextFr <> NIL then
+      LoEInsertNext(pFR,frActNumb.n);
+    frAktIdx := 0;
+  end;
+end;
+
+function LoEGetNextNumber(pFR :tpFaktorRec):tElem;
+Begin
+  with pFr^ do
+  Begin
+    result := frElems[frAktIdx];
+    inc(frAktIdx);
+    IF frMaxIdx < frAktIdx then
+      LoENextList(pFr);
+  end;
+end;
+
+procedure LoEGetNumber(pFR :tpFaktorRec;no:NativeUint);
+Begin
+  dec(no);
+  while ActIndex < no do
+    LoENextList(pFR);
+  with pFr^ do
+    frAktIdx := (no-(ActIndex-frMaxIdx)-1);
+
+end;
+
+var
+  T1,T0: tDateTime;
+  FA: tArrFR;
+  i : integer;
+Begin
+  PlInit(3);// 3 -> 2,3,5
+  LoECreate(Pl,FA);
+  i := 1;
+  i := 1;
+  T0 := time;
+  write('First 20 :');
+  For i := 1 to 20 do
+    AusgabeElem(LoEGetNextNumber(@FA[0]));
+  writeln;
+  write(' 1691.th :');
+  LoEGetNumber(@FA[0],1691);
+  AusgabeElem(LoEGetNextNumber(@FA[0]));
+
+  LoEGetNumber(@FA[0],1000*1000);
+  AusgabeElem(LoEGetNextNumber(@FA[0]));
+  T1 := time;
+  Writeln('Timed 1,000,000 in ',FormatDateTime('HH:NN:SS.ZZZ',T1-T0));
+
+  LoEGetNumber(@FA[0],1000*1000*1000);
+  AusgabeElem(LoEGetNextNumber(@FA[0]));
+  Writeln('Timed 1,000,000,000 in ',FormatDateTime('HH:NN:SS.ZZZ',time-T1));
+
+  Writeln('Actual Index ',ActIndex );
+  AusgabeElem(LoEGetNextNumber(@FA[0]));
+  For i := 0 to High(FA) do
+    writeln(pL[i]:2,
+     ' elemcount  ',FA[i].frMaxIdx+1:7,' out of',length(FA[i].frElems):7);
+  LoEFree(FA);
+End.