Добро пожаловать в форум, Guest  >>   Войти | Регистрация | Поиск | Правила | В избранное | Подписаться
Все форумы / Delphi Новый топик    Ответить
 Помогите придумать алгоритм  [new]
Кареглазая_зая
Member

Откуда:
Сообщений: 31
Здравствуйте! Помогите придумать алгоритм, может быть есть какая-то "умная" формула!

Есть такая задача, существует какое то кол-во N групп, у каждой группы есть стоимость (в моем случае группы - это разные программы страхования, где на каждой есть какая-то сумма денег). Необходимо уменьшить сумму этих групп на число S. Причем уменьшить равномерно, вычитая из из каждой примерно одинаковое число. Но в минус уходить нельзя.

Например,
p1 - 0 руб.
p2- 40 руб.
p3- 100 руб
P4- 5 руб.

Надо вычесть 60 рублей.

т.е. в итоге должно быть

p1 - 0 руб.
p2- 12,5 руб.
p3- 72,5 руб
P4- 0 руб.

Вычитать по 1 копейке с каждой пока не получится уменьшить на нужную сумму - слишком долгий алгоритм. Может можно как-то проще?
31 окт 18, 17:37    [21720657]     Ответить | Цитировать Сообщить модератору
 Re: Помогите придумать алгоритм  [new]
Мимопроходящий
Member

Откуда: бурятский тундрюк, эсквайр
Сообщений: 29244

31.10.2018 17:37, Кареглазая_зая пишет:
> слишком долгий алгоритм.

компьютер железный.
ему пофиг.
работает - не трожь!

Posted via ActualForum NNTP Server 1.5

31 окт 18, 17:47    [21720671]     Ответить | Цитировать Сообщить модератору
 Re: Помогите придумать алгоритм  [new]
AWSVladimir
Member

Откуда:
Сообщений: 842
Кареглазая_зая
Необходимо уменьшить сумму этих групп на число S. Причем уменьшить равномерно, вычитая из из каждой примерно одинаковое число. Но в минус уходить нельзя.
...
Вычитать по 1 копейке с каждой пока не получится уменьшить на нужную сумму - слишком долгий алгоритм. Может можно как-то проще?


S:=ФормулаРасчета_S
for i:=low(МаcсивP) to High(МаcсивP) do begin
МаcсивP[i]:=МаcсивP[i]-S;
if МаcсивP[i]<0 then МаcсивP[i]:=0;
end;
31 окт 18, 17:50    [21720675]     Ответить | Цитировать Сообщить модератору
 Re: Помогите придумать алгоритм  [new]
Dimitry Sibiryakov
Member

Откуда:
Сообщений: 46152

Кареглазая_зая
Может можно как-то проще?
Можно: вычитать по (оставшаяся сумма скидки/количество оставшихся групп)

Posted via ActualForum NNTP Server 1.5

31 окт 18, 17:51    [21720676]     Ответить | Цитировать Сообщить модератору
 Re: Помогите придумать алгоритм  [new]
Гаджимурадов Рустам
Member

Откуда:
Сообщений: 59340
Кареглазая_зая> Необходимо уменьшить сумму этих групп на число S.
Кареглазая_зая> Причем уменьшить равномерно, вычитая из из каждой
Кареглазая_зая> примерно одинаковое число.

Стандартный алгоритм веса объекта в группе
(соотв. уменьшать по удельному весу).

Кареглазая_зая> т.е. в итоге должно быть
>
> p1 - 0 руб.
> p2- 12,5 руб.
> p3- 72,5 руб
> P4- 0 руб.

По какому алгоритму получен данный ответ? Это - не "равномерно".

Posted via ActualForum NNTP Server 1.5

31 окт 18, 18:04    [21720696]     Ответить | Цитировать Сообщить модератору
 Re: Помогите придумать алгоритм  [new]
Dimonka
Member

Откуда:
Сообщений: 1107
Алгоритм примерно такой - вычислить сумму всех элементов, а затем пропорционально разделить между элементами с суммой > 0

Например,
p1 - 0 руб.
p2- 40 руб.
p3- 100 руб
P4- 5 руб.

Сумма = 145

p1 - 0 руб.
p2- 40 - 40 * 60 / 145
p3- 100 - 100 * 60 / 145
P4- 5 - 5 * 60 / 145

Единственная небольшая проблемка будет красиво раскидать дробные части копеек, чтобы получилось ровно 60 рублей. Поскольку подозреваю, что дробные числа меньше копейки тебя не интересуют.
31 окт 18, 18:23    [21720729]     Ответить | Цитировать Сообщить модератору
 Re: Помогите придумать алгоритм  [new]
_Vasilisk_
Member

Откуда: Украина, Харьков
Сообщений: 10605
Кареглазая_зая
вычитая из из каждой примерно одинаковое число

1. Делим число на количество ненулевых групп
2. Вычитаем из каждой группы полученное среднее
3. Если в группе меньше, чем нужно, вычитаем в 0, а невучтенный остаток запоминаем
4. Складываем все остатки и переходим к шагу 1

+
procedure Sub(var AData: array of Integer; ASub: Integer);
var
  Li: Integer;
  LCnt: Integer;
  LRest: Integer;
  LDelta: Integer;
begin
  if ASub <= 0 then
    Exit;
  LCnt := 0;
  for Li := 0 to Length(AData) - 1 do begin
    if AData[Li] > 0 then
      Inc(LCnt);
  end;
  if LCnt = 0 then
    raise Exception.Create('Groups not found');

  if ASub < LCnt then begin
    for Li := 0 to Length(AData) - 1 do begin
      if AData[Li] > 0 then begin
        Dec(AData[Li]);
        Dec(ASub);
        if ASub = 0 then
          Exit;
      end;
    end;
  end;

  LDelta := ASub div LCnt;
  LRest := ASub mod LCnt;
  for Li := 0 to Length(AData) - 1 do begin
    if AData[Li] > 0 then begin
      Dec(AData[Li], LDelta);
      if AData[Li] < 0 then begin
        Dec(LRest, AData[Li]);
        AData[Li] := 0;
      end;
    end;
  end;

  if LRest > 0 then
    Sub(AData, LRest);
end;
31 окт 18, 19:12    [21720783]     Ответить | Цитировать Сообщить модератору
 Re: Помогите придумать алгоритм  [new]
_Vasilisk_
Member

Откуда: Украина, Харьков
Сообщений: 10605
_Vasilisk_,

Все дробные числа переводим в целые, путем умножения на 100
31 окт 18, 19:13    [21720784]     Ответить | Цитировать Сообщить модератору
 Re: Помогите придумать алгоритм  [new]
Кареглазая_зая
Member

Откуда:
Сообщений: 31
_Vasilisk_,

Спасибо большое. То что нужно)
1 ноя 18, 09:59    [21721122]     Ответить | Цитировать Сообщить модератору
 Re: Помогите придумать алгоритм  [new]
Aleksandr Sharahov
Member

Откуда: Москва
Сообщений: 1670
Кареглазая_зая,

как вариант, чтобы делать меньше вычитаний, на промежуточных проходах цикла (когда есть элементы ниже среднего) можно не трогать те, которые выше среднего
1 ноя 18, 10:22    [21721153]     Ответить | Цитировать Сообщить модератору
 Re: Помогите придумать алгоритм  [new]
Aleksandr Sharahov
Member

Откуда: Москва
Сообщений: 1670
Кареглазая_зая,

в принципе, все вычитания можно сделать за один последний проход по массиву:
+
function DecrementArray(var a: array of integer; val: integer= 1): boolean;
var
  i, d, m, len, sum, cnt, old: integer;
begin;
  if val<=0 then begin;
    Result:=(val=0);
    exit;
    end;

  len:=Length(a);
  sum:=0;
  for i:=0 to len-1 do sum:=sum+a[i];
  Result:=(val<=sum);
  if not Result then exit;
  if val=sum then begin;
    for i:=0 to len-1 do a[i]:=0;
    exit;
    end;

  cnt:=0; sum:=0;
  repeat;
    d:=(val-sum) div (len-cnt); m:=(val-sum)-d*(len-cnt);
    old:=cnt; cnt:=0; sum:=0;
    for i:=0 to len-1 do if a[i]<=d then begin;
      sum:=sum+a[i];
      inc(cnt);
      end;
    until (old=cnt) and (len-cnt>=m);

  for i:=0 to len-1 do begin;
    if a[i]<=d then a[i]:=0
    else if m>0 then begin;
      dec(m);
      a[i]:=a[i]-(d+1);
      end
    else a[i]:=a[i]-d;
    end;
  end;


особо не отлаживал, проверял работу этим:
+
procedure TForm1.Button1Click(Sender: TObject);
var
  a: array of integer;
  i: integer;
begin;
  SetLength(a, 4);
  a[0]:=0;
  a[1]:=40;
  a[2]:=100;
  a[3]:=5;

  DecrementArray(a, 60);
  for i:=0 to Length(a)-1 do Memo1.Lines.Add(IntToStr(a[i]));
  end;
1 ноя 18, 11:55    [21721279]     Ответить | Цитировать Сообщить модератору
Все форумы / Delphi Ответить