Главная страница
    Top.Mail.Ru    Яндекс.Метрика
Форум: "Потрепаться";
Текущий архив: 2004.08.22;
Скачать: [xml.tar.bz2];

Вниз

Пятничная на оптимизацию   Найти похожие ветки 

 
Anatoly Podgoretsky ©   (2004-08-06 09:08) [0]

Постановка задачи
удалить часть динамического массива

Дано
есть динамический отсортированый массив (Ar), допустим TDateTime, в находятся данные только одного года, даты могут повторяться.
Требуется</
B> удалить все записи за один месяц (переменная M)

Задача два
Тоже самое только вместо удаления, добавить уже отсортированй массив Ar2 один месяц в массив Ar1, добавляемый месяц отсутствует в Ar1, пускай он удален в задаче 1

Цель- пятничная разминка с программистким уклоном, а то надоело собак и котов прогонять через строй. Можно предоставлять как коды, так и четко описаные алгоритмы.

Оценка - оценки не будет, только флейм :-)
Практическое применение, тренировка мозгов, кому ни будь пригодится в будущем.

ЗЫ: заразился от MBo :-)


 
Anatoly Podgoretsky ©   (2004-08-06 09:16) [1]

Дополнение, ассемблер не использовать, только чистый Паскаль. Хотя если есть большое желание то тоже можно, но лучше не стоит, суть залания все таки оптимальные алгоритмы.


 
TUser ©   (2004-08-06 09:22) [2]

Не силен я пока в алгоритмах, но все же.
1. Наверное, сначала бинарным поиском (или интерпляционным) находим начало и конец удаляемого участка, затем смещаем все, что после них, назад на соотв. число, потом SetLength.
2. Опять же ищем место, куда вставить, увеличиваем размер массива, смещаем вперед, и копируем вставку.
3. Вообще, если такие задачи возникают, логичнее испозовать связные списки.


 
Владислав ©   (2004-08-06 10:36) [3]

> TUser ©   (06.08.04 09:22) [2]
"... бинарным поиском..."

Даты могут повторяться.


 
Думкин ©   (2004-08-06 10:37) [4]

> [3] Владислав ©   (06.08.04 10:36)

Ну и?


 
Sha ©   (2004-08-06 10:39) [5]

Anatoly Podgoretsky ©   (06.08.04 09:08)

Мне кажется, лучше будет в качестве задачи оставить только определение начала и конца данных за указанный интервал времени.
Удаление и вставка - это самостоятельные сравнительно легкие задачи и соответственно отдельные процедуры.


 
Anatoly Podgoretsky ©   (2004-08-06 10:44) [6]

Владислав ©   (06.08.04 10:36) [3]
Нормальный бинарный поиск должен дать первое вхождение.

Sha ©   (06.08.04 10:39) [5]
Конечно можно, но не интересно, интересно в комплексе. Вот вторую задачу можно и не рассматривать, поскольку она по сути первая. Просто так для полноты задачи. Суть же в первой.


 
Думкин ©   (2004-08-06 10:58) [7]

> [6] Anatoly Podgoretsky ©   (06.08.04 10:44)

В одной бинарном сразу искать 2 границы? На каком-то этапе распаралелиться?


 
Sandman25 ©   (2004-08-06 11:00) [8]

[7] Думкин ©   (06.08.04 10:58)

Боюсь, что это окажется медленнее, чем 2 бинарных.


 
Думкин ©   (2004-08-06 11:04) [9]

>  [8] Sandman25 ©   (06.08.04 11:00)

Из-за 2-х сравнений?


 
Sandman25 ©   (2004-08-06 11:05) [10]

+ из-за усложнения алгоритма.


 
Думкин ©   (2004-08-06 11:05) [11]

>  Sandman25 ©   (06.08.04 11:00)

Мне каааажется, что нет. Но надо реализацию, или креститься.


 
Sandman25 ©   (2004-08-06 11:10) [12]

[11] Думкин ©   (06.08.04 11:05)

Все зависит от длины периода. Если почти всегда начало будет в первой половине, а конец - во второй, то разделяться нужно будет сразу же. Обычный поиск окажется быстрее.
Если же, наоборот, разделение будет на 25 шаге, то возможно ускорение.


 
Anatoly Podgoretsky ©   (2004-08-06 11:10) [13]

Думкин ©   (06.08.04 10:58) [7]
Сам решай и приводи решение, это же задача, а не заказ работы.


 
Думкин ©   (2004-08-06 11:14) [14]

> [13] Anatoly Podgoretsky ©   (06.08.04 11:10)

Да, конечно. Но код только дома - вечером, или завтра. Потому как тут - заказ и работа. А по пути я не смогу, только трепаться. :)


 
Sha ©   (2004-08-06 11:21) [15]

unit FindDateMain;

interface

uses
 Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
 Dialogs, ExtCtrls, Grids, StdCtrls, Spin;

type
 Tfrm = class(TForm)
   sg: TStringGrid;
   Panel1: TPanel;
   se1: TSpinEdit;
   se2: TSpinEdit;
   bSolution: TButton;
   bRandom: TButton;
   bClear: TButton;
   procedure FormCreate(Sender: TObject);
   procedure seChange(Sender: TObject);
   procedure bClearClick(Sender: TObject);
   procedure bRandomClick(Sender: TObject);
   procedure bSolutionClick(Sender: TObject);
   procedure sgDrawCell(Sender: TObject; ACol, ARow: Integer; Rect: TRect;
     State: TGridDrawState);
 private
   { Private declarations }
 public
   { Public declarations }
 end;

var
 frm: Tfrm;

implementation

{$R *.dfm}

var
 d: array of integer;
 c1, c2: integer;

procedure sgFill;
var
 c, r, v: integer;
begin;
 with frm do begin;
   for r:=1 to sg.RowCount-1 do for c:=1 to sg.ColCount-1 do sg.Cells[c,r]:="";
   for r:=1 to sg.RowCount-1 do sg.Cells[0,r]:=IntToStr(r);
   for c:=1 to sg.ColCount-1 do sg.Cells[c,0]:=IntToStr(d[c-1]);
   c1:=sg.ColCount-1; c2:=-1;
   for c:=1 to sg.ColCount-1 do begin;
     v:=StrToIntDef(sg.Cells[c,0],-1);
     if (v>=se1.Value) and (v<=se2.Value) then begin;
       if c1>c then c1:=c;
       if c2<c then c2:=c;
       end;
     end;
   //for r:=1 to sg.RowCount-1 do for c:=c1 to c2 do sg.Cells[c,r]:=".";
   end;
 end;

procedure dInit;
var
 i, t: integer;
 done: boolean;
begin;
 with frm do begin;
   SetLength(d,sg.ColCount-1);
   for i:=0 to High(d) do d[i]:=Random(31)+1;
   //Sort
   repeat;
     done:=true;
     for i:=0 to High(d)-1 do if d[i]>d[i+1] then begin;
       t:=d[i]; d[i]:=d[i+1]; d[i+1]:=t; done:=false;
       end;
     until done;
   end;
 end;

procedure Tfrm.FormCreate(Sender: TObject);
begin;
 bRandomClick(Sender);
 Randomize; //After - to debug
 end;

procedure Tfrm.seChange(Sender: TObject);
begin;
 sgFill;
 end;

procedure Tfrm.bClearClick(Sender: TObject);
begin;
 sgFill;
 end;

procedure Tfrm.bRandomClick(Sender: TObject);
begin;
 dInit;
 sgFill;
 end;

procedure Tfrm.bSolutionClick(Sender: TObject);
var
 no: integer;
 lt, rt, mt, lt2, rt2: integer;
 lfound, rfound: integer;
 v: integer;
begin;
 sgFill;
 no:=0;

 lt:=-1; rt:=high(d);
 lt2:=lt+1; rt2:=rt+1;
 while lt<rt do begin;
   mt:=(lt+rt+1) shr 1; // Round to right

   inc(no);
   if lt>=0 then sg.Cells[lt+1,no]:=sg.Cells[lt+1,no]+"-";
   sg.Cells[rt+1,no]:=sg.Cells[rt+1,no]+"+";
   sg.Cells[mt+1,no]:=sg.Cells[mt+1,no]+"?";

   v:=d[mt];
   if v<se1.Value
   then lt:=mt
   else begin;
     rt:=mt-1;
     if v>se2.Value
     then rt2:=mt
     else if lt2<mt
          then lt2:=mt;
     end;
   end;
 lfound:=lt+1;
 sg.Cells[lfound+1,no]:=sg.Cells[lfound+1,no]+"L";

 lt:=lt2; rt:=rt2;
 while lt<rt do begin;
   mt:=(lt+rt) shr 1; // Round to left

   inc(no);
   sg.Cells[lt+1,no]:=sg.Cells[lt+1,no]+"+";
   if rt+1<sg.ColCount then sg.Cells[rt+1,no]:=sg.Cells[rt+1,no]+"-";
   sg.Cells[mt+1,no]:=sg.Cells[mt+1,no]+"?";

   if d[mt]>se2.Value then rt:=mt else lt:=mt+1;
   end;
 rfound:=rt-1;
 sg.Cells[rfound+1,no]:=sg.Cells[rfound+1,no]+"R";

 end;

procedure Tfrm.sgDrawCell(Sender: TObject; ACol, ARow: Integer;
 Rect: TRect; State: TGridDrawState);
begin;
 if (Sender is TStringGrid) then with TStringGrid(Sender) do begin;
   Canvas.Font:=Font;
   if (Acol>=c1) and (ACol<=c2)
   then Canvas.Brush.Color:=clYellow
   else Canvas.Brush.Color:=clWindow;
   Canvas.TextRect(Rect, Rect.Left+2, Rect.Top+2, sg.Cells[ACol, ARow]);
   end;
 end;

end.

object frm: Tfrm
 Left = 248
 Top = 164
 Width = 711
 Height = 485
 Caption = "frm"
 Color = clBtnFace
 Font.Charset = DEFAULT_CHARSET
 Font.Color = clWindowText
 Font.Height = -11
 Font.Name = "MS Sans Serif"
 Font.Style = []
 OldCreateOrder = False
 OnCreate = FormCreate
 PixelsPerInch = 96
 TextHeight = 13
 object sg: TStringGrid
   Left = 0
   Top = 0
   Width = 703
   Height = 417
   Align = alClient
   ColCount = 51
   DefaultColWidth = 19
   DefaultRowHeight = 19
   DefaultDrawing = False
   RowCount = 20
   TabOrder = 0
   OnDrawCell = sgDrawCell
 end
 object Panel1: TPanel
   Left = 0
   Top = 417
   Width = 703
   Height = 41
   Align = alBottom
   TabOrder = 1
   object se1: TSpinEdit
     Left = 56
     Top = 8
     Width = 73
     Height = 24
     Font.Charset = DEFAULT_CHARSET
     Font.Color = clWindowText
     Font.Height = -12
     Font.Name = "Courier New"
     Font.Style = []
     MaxValue = 31
     MinValue = 1
     ParentFont = False
     TabOrder = 0
     Value = 3
     OnChange = seChange
   end
   object se2: TSpinEdit
     Left = 144
     Top = 8
     Width = 73
     Height = 24
     Font.Charset = DEFAULT_CHARSET
     Font.Color = clWindowText
     Font.Height = -12
     Font.Name = "Courier New"
     Font.Style = []
     MaxValue = 31
     MinValue = 1
     ParentFont = False
     TabOrder = 1
     Value = 29
     OnChange = seChange
   end
   object bSolution: TButton
     Left = 504
     Top = 8
     Width = 75
     Height = 25
     Caption = "Solution"
     TabOrder = 2
     OnClick = bSolutionClick
   end
   object bRandom: TButton
     Left = 368
     Top = 8
     Width = 75
     Height = 25
     Caption = "Random"
     TabOrder = 3
     OnClick = bRandomClick
   end
   object bClear: TButton
     Left = 288
     Top = 8
     Width = 75
     Height = 25
     Caption = "Clear"
     TabOrder = 4
     OnClick = bClearClick
   end
 end
end


 
default ©   (2004-08-06 11:45) [16]

а как бинарным поиском найти сразу хоть одну границу?
такое может быть, но ведь не всегда
ведь не сказано что в массиве присут-ют даты всех дней в месяце
придётся видимо искать бинарным поиском на совп-ие элемента массива определённом месяцу в диап-не его дней с учётом года
потом двигаться влево и вправо для достижения обоих границ
[15]
а можно на словах?
уж больно лень разбирать код


 
Sha ©   (2004-08-06 11:50) [17]

> а как бинарным поиском найти сразу хоть одну границу?
> уж больно лень разбирать код

Там больше половины кода приходится как раз на объяснение :)
Все шаги алгоритма демонстрируются в гриде.


 
Anatoly Podgoretsky ©   (2004-08-06 11:55) [18]

default ©   (06.08.04 11:45) [16]
Даже более того, может даже не быть ни одной записи за указаный месяц, условия задачи не оговаривают эту обязательность, так же как и отсутствие промежутков, например может быть тысяца дат 23.02.2004 и никаких других. Одно оговорено явно, никаких других дат из других годов.


 
Sha ©   (2004-08-06 12:03) [19]

> Anatoly Podgoretsky ©   (06.08.04 11:55) [18]
> Даже более того, может даже не быть ни одной записи за указаный месяц

Этот случай корректно обрабатывается - в результате будет получено lfound>rfound.


 
DeadMeat ©   (2004-08-06 12:15) [20]

Ой... Даже *.dfm есть...
А вообще (в код правда не смотрел, мож повторюсь) я бы сделал так:
1) Найти все даты за этот месяц, записать вместо них нули (почти удалить), а вторым проходом - удалить нули. Свиду этот чуть проще, но правда может оказаться более медленно...


 
Anatoly Podgoretsky ©   (2004-08-06 12:17) [21]

Sha ©   (06.08.04 12:03) [19]
Это не к тебе, нормальный двоичный поиск даст правильный результат, надо только проверить, что границы попадают в месяц, если стартовая не попадает, то записей вообще нет, если стоповая не попадает то минус 1, если попадает то найти последнее вхождение. Твой код не анализировал, тяжел для прямого восприятия алгоритма, визуально надо смотреть и проверить отладчиком на корректность при разных условиях.


 
Anatoly Podgoretsky ©   (2004-08-06 12:18) [22]

DeadMeat ©   (06.08.04 12:15) [20]
Это не может быть оптимально, поскольку добавляется лишняя операция обнуления, для удаления не важно какие значения, удаляются нормально и с нулем и с правильным значением.


 
Igorek ©   (2004-08-06 12:20) [23]

1)
Поиск границ удаляемого участка стоит разделить на две фазы:
1. Поиск любого элемента, за удаляемый месяц - обычный бинарный поиск, за исключением того, что по ходу поиска храним в каком то виде две последние границы (можно явные индексы - вначале это начало и конец массива).
2. От этого элемента влево и вправо ищем первые элементы, выходящие за пределы данного месяца (может оказаться что это граница массива). Поиск ограничиваем с двух сторон используя сохраненные границы на фазе 1. Можно применить видоизмененный бинарный поиск:
- если посредине элемент не из данного месяца, то берем половинку со стороны елемента с фазы 1
- иначе берем другую половинку
- процесс повторяется, пока не останется только один элемент в диапазоне


 
Sha ©   (2004-08-06 12:23) [24]

> Anatoly Podgoretsky ©   (06.08.04 12:17) [21]
> Твой код не анализировал, тяжел для прямого восприятия алгоритма...

Весь алгоритм - порядка 20 строк:
оставляем только bSolutionClick,
затем из нее выкидвываем всю работу с гридом и подсчет количества шагов.


 
Sha ©   (2004-08-06 13:30) [25]

Примерно так:

type
 TValue= integer;
 TValueArray= array of TValue;
procedure FindInterval(const VArray: TValueArray; LValue, RValue: TValue;
 var Left, Right: integer);
var
 v: TValue;
 lt, rt, mt, lt2, rt2: integer;
begin;
 lt:=-1; rt:=High(VArray);
 lt2:=lt+1; rt2:=rt+1;
 while lt<rt do begin;
   mt:=(lt+rt+1) shr 1; // Round to right
   v:=VArray[mt];
   if v<LValue
   then lt:=mt
   else begin;
     rt:=mt-1;
     if v>RValue
     then rt2:=mt
     else if lt2<mt
          then lt2:=mt;
     end;
   end;
 Left:=lt+1;
 while lt2<rt2 do begin;
   mt:=(lt2+rt2) shr 1; // Round to left
   if VArray[mt]>RValue
   then rt2:=mt
   else lt2:=mt+1;
   end;
 Right:=rt2-1;
 end;



Страницы: 1 вся ветка

Форум: "Потрепаться";
Текущий архив: 2004.08.22;
Скачать: [xml.tar.bz2];

Наверх




Память: 0.54 MB
Время: 0.06 c
14-1091684804
REA
2004-08-05 09:46
2004.08.22
Нашествие


14-1091519097
DSKalugin
2004-08-03 11:44
2004.08.22
почему следующая фраза вешает ворд ХП???


1-1091795561
Konoko
2004-08-06 16:32
2004.08.22
Как отцентрировать текст в ячейках StringGrid?


4-1089358067
putrsa
2004-07-09 11:27
2004.08.22
работа с визуальными компонентами чужого приложения


6-1088090396
Dextor
2004-06-24 19:19
2004.08.22
Отправка звука





Afrikaans Albanian Arabic Armenian Azerbaijani Basque Belarusian Bulgarian Catalan Chinese (Simplified) Chinese (Traditional) Croatian Czech Danish Dutch English Estonian Filipino Finnish French
Galician Georgian German Greek Haitian Creole Hebrew Hindi Hungarian Icelandic Indonesian Irish Italian Japanese Korean Latvian Lithuanian Macedonian Malay Maltese Norwegian
Persian Polish Portuguese Romanian Russian Serbian Slovak Slovenian Spanish Swahili Swedish Thai Turkish Ukrainian Urdu Vietnamese Welsh Yiddish Bengali Bosnian
Cebuano Esperanto Gujarati Hausa Hmong Igbo Javanese Kannada Khmer Lao Latin Maori Marathi Mongolian Nepali Punjabi Somali Tamil Telugu Yoruba
Zulu
Английский Французский Немецкий Итальянский Португальский Русский Испанский