Последовательность Хемминга...

Как найти K-ый член этой последовательности K<=1000?

Цитата AAR, 22.11.02, 18:12:03

Как найти K-ый член этой последовательности K<=1000?

Напиши хоть это за последовательность???

Последовательность Хемминга - это расположенные в возрастающем порядке числа, не имеющие простых делителей, отличных от 2,3, и 5. Ее начало имеет вид: 2,3,4,5,6,8,9,10,12,15... Мне надо найти K<=1000 член этой последовательности.

Сделал прогу, но она работает ужасно медленно! Может найдутся сабжы, которые предложат более оптимизированный код?  8)

здесь не смотрел?
http://www.research.att.com/~njas/sequences/

type
  tqueue=record
    num,parent:int64;
  end;
 
var
  queue:array[1..10000] of tqueue;
  head,tail,t2:int64;
 
function was(n:int64):boolean;
var
  i:integer;
begin
  was:=false;
  for i:=1 to tail do
    if queue[i].num=n then
    begin
      was:=true;
      exit;
    end;
end;
 
procedure add(n,p:int64);
begin
  inc(tail);
  queue[tail].num:=n;
  queue[tail].parent:=p;
end;
 
procedure buildqueue(max:int64);
var
  i,j:integer;
  n:int64;
begin
  head:=1;
  tail:=4;
  repeat
    t2:=tail;
    for i:=head to tail do
    begin
      n:=queue[i].num;
      if not was(n*2) then
        add(n*2,i);
      if not was(n*3) then
        add(n*3,i);
      if not was(n*5) then
        add(n*5,i);
    end;
    head:=t2+1;
  until tail>=max;
end;
 
Procedure Sort(Left,right:int64);
var
  l,r,m,s:int64;
Begin
  l:=left;
  r:=right;
  m:=queue[(l+r) div 2].num;
  repeat
    while queue[l].num<m do inc(l);
    while queue[r].num>m do dec(r);
    if l<=r then
    begin
      s:=queue[l].num;
      queue[l].num:=queue[r].num;
      queue[r].num:=s;
      dec(r);
      inc(l);
    end;
  until l>r;
  if r>left then sort(Left,r);
  if l<right then sort(l,right);
End;
 
procedure TForm1.Button1Click(Sender: TObject);
begin
  fillchar(queue,sizeof(queue),0);
  queue[1].num:=2;
  queue[2].num:=3;
  queue[3].num:=4;
  queue[4].num:=5;
  buildqueue(strtoint(edit1.text));
  sort(1,tail);
  edit2.text:=inttostr(queue[strtoint(edit1.text)].num);
end;

в edit1 вводишь K.
в edit2 выводится само число.
даже до 10000 пишет почти сразу.
Алгоритм полностью извращенный, но работает быстро.

Сообщение отредактировано: orb - 09.11.10, 12:54

Кстати, в массиве queue.num есть все элементы последовательности до K

Поскольку любое число f последовательности Хемминга представимо в виде

f(x,y,z) = (2^x)*(3^y)*(5^z) = exp( Kx*x + Ky*y + Kz*z) = exp( g(x,y,z) )

где x,y,z - натуральные числа, Kx = Log(2), Ky = Log(3), Kz = Log(5), и функция exp() является монотонной, то упорядочивать их по возрастанию можно упорядочивая числа g

g(x,y,z) = Kx*x + Ky*y + Kz*z,

которые вычислять чуть-чуть попроще. Если хорошенько подумать, то, быть может, числа g удастся упорядочить по возрастанию даже аналитически, т. е. отыскать такие целочисленные функции x(n), y(n), z(n), что

g(n+1) == g( x(n+1), y(n+1), z(n+1) )  >  g( x(n), y(n), z(n) ) == g(n)

Собственно, пока это все что я хотел сказать.

PropellerMan, у тебя прога работает как-то неправильно. 100-ный элемент последовательности должен быть равен 1600 (это все, что мне дано). Может быть ты не понял условие?

 Ок, я посмотрю.

Время вычисления меньше 1 сек (на P4 1800Mhz)
тысячное число в последовательности Хемминга получается
51 840 000 = 2^10 * 3^4 * 5^4

procedure TForm1.Button1Click(Sender: TObject);
const HVATIT_ZA_GLAZA = 100;
var x,y,z, h: integer;
    Kx,Ky,Kz: double;
    HemSeq : Array of double;
begin
  Kx := ln(2);
  Ky := ln(3);
  Kz := ln(5);
 
  SetLength(HemSeq, HVATIT_ZA_GLAZA*HVATIT_ZA_GLAZA*HVATIT_ZA_GLAZA);
  h := -1;
  for x:=0 to HVATIT_ZA_GLAZA-1 do
   for y:=0 to HVATIT_ZA_GLAZA-1 do
     for z:=0 to HVATIT_ZA_GLAZA-1 do
       begin
         inc(h);
         HemSeq[h] := Kx*x + Ky*y + Kz*z;
       end;
 
  qsort(HemSeq);
  
  ShowMessage(IntToStr(Round(exp(HemSeq[1000]))));
end;

qsort() - это стандартная процедура быстрой сортировки массива (Сортирует за N*Log(N) операций)

procedure qsort(var A: array of double);
    procedure sort(l,r: integer);
      var i,j: integer;
          x,y: double;
    begin
      i := l;
      j := r;
      x := A[ (l + r) div 2 ];
      repeat
        while A[i] < x do inc(i);
        while x < A[j] do dec(j);
        if not (i>j) then
          begin
            y    := A[i];
            A[i] := A[j];
            A[j] := y;
            inc(i);
            dec(j);
          end;
      until i>j;
      if l < j then sort(l,j);
      if i < r then sort(i,r);
    end;
begin
  sort(0,High(A));
end;

Сообщение отредактировано: orb - 09.11.10, 12:53

Вот программа, осуществляющая то, что тебе нужно. По-моему, работает весьма быстро. Проблемы могут быть лишь с переполнением LongInt, но допиcывать работу с длинными целыми как-то было лень.

Основная программа.

{$DEFINE NoInput}
{Writes the first l numbers that contain prime numbers p1, p2, p3 as deviders}
{$A+,B-,D+,E+,F-,G+,I+,L+,N+,O-,P-,Q-,R+,S+,T-,V+,X+,Y+}
{$M 16384,0,655360}
uses queue;
 
Function Min(a, b, c: LongInt): LongInt;
 
begin
  if a >= b then
    begin
      if b >= c then
        min := c
      else
        min := b;
    end
  else
    begin
      if c <= a then
        min := c
      else
        min := a;
    end;
end;
 
Procedure Primes(p1, p2, p3, l: LongInt);
 
var
  q1, q2, q3: TQueue;
  x, y, z, a, i: LongInt;
 
begin
  q1.Init;
  q2.Init;
  q3.Init;
  q1.Push(p1);
  q2.Push(p2);
  q3.Push(p3);
  i := 0;
  while i < l do
    begin
      x := q1.Top;
      y := q2.Top;
      z := q3.Top;
      a := min(x, y, z);
      write(a, ' ');
      q1.Push(a * p1);
      q2.Push(a * p2);
      q3.Push(a * p3);
      if x = a then q1.Pop;
      if y = a then q2.Pop;
      if z = a then q3.Pop;
      Inc(i);
    end;
  q1.Done;
  q2.Done;
  q3.Done;
end;
 
var
  p1, p2, p3, l: LongInt;
 
begin
{$IFNDEF NoInput}
  WriteLn('Enter first prime: ');
  ReadLn(p1);
  WriteLn('Enter second prime: ');
  ReadLn(p2);
  WriteLn('Enter third prime: ');
  ReadLn(p3);
{$ELSE}
  p1 := 2; p2 := 3; p3 := 5;
{$ENDIF}
  WriteLn('Enter number of primes: ');
  ReadLn(l);
  Primes(p1, p2, p3, l);
end.

Юнит с очередью.

{Queue of Integer}
{$A+,B-,D+,E+,F-,G+,I+,L+,N+,O-,P-,Q-,R+,S+,T-,V+,X+,Y+}
{$M 16384,0,655360}
unit Queue;
 
interface
 
Type
  PNode = ^TNode;
  TNode = object
    private
      data: LongInt;
      pNext: pNode;
  end;
 
  PQueue = ^TQueue;
  TQueue = object
    private
      pTop : pNode;
      pLast: pNode;
    public
      Constructor Init;
      Destructor Done;
      Procedure Push(x: LongInt);
      Function  Pop: LongInt;
      Function  Top: LongInt;
      Function  Empty: Boolean;
      Procedure Show;
  end;
 
implementation
 
Constructor TQueue.Init;
 
begin
  pTop := nil;
  pLast := nil;
end;
 
Destructor TQueue.Done;
 
var
  tmp: PNode;
 
begin
  while pTop <> nil do
    begin
      tmp := pTop;
      pTop := pTop^.pNext;
      Dispose(tmp);
    end;
end;
 
Procedure TQueue.Push(x: LongInt);
 
var
  tmp: PNode;
 
begin
  New(tmp);
  tmp^.pNext := nil;
  tmp^.Data := x;
  if pLast = nil then
    pTop := tmp
  else
    pLast^.pNext := tmp;
  pLast := tmp;
end;
 
Function TQueue.Pop: LongInt;
 
var
  tmp: PNode;
 
begin
  if Empty then
    begin
      WriteLn('Error in Queue.Pop: Queue is empty');
      Halt;
    end
  else
    begin
      Pop := pTop^.Data;
      tmp := pTop;
      pTop := pTop^.pNext;
      Dispose(tmp);
      if pTop = nil then pLast := nil;
    end;
end;
 
Function TQueue.Top: LongInt;
 
begin
  if Empty then
    begin
      WriteLn('Error in Queue.Top: Queue is empty');
      Halt;
    end
  else
    Top := pTop^.Data;
end;
 
Function TQueue.Empty: Boolean;
 
begin
  Empty := pTop = nil;
end;
 
Procedure TQueue.Show;
 
var
  tmp: pNode;
 
begin
  write('Queue: ');
  tmp := pTop;
  while tmp <> nil do
    begin
      Write(tmp^.data, ' ');
      tmp := tmp^.pNext;
    end;
  Writeln;
end;
end.

Сообщение отредактировано: orb - 09.11.10, 12:53

Огроооомное вам СПАСИБО!!!