Promazani dvou Memo s hodne daty – Delphi – Fórum – Programujte.com

Cau lidi,

potrebuju promazat dve Mema se spoustou radku.
napsal jse na to tohle, ale neni to dobry,  Memo1 ma zhruba 50K radku a Memo2 asi 14K  a trva to strasne dlouho, kolem 20 hodin, nedalo by se to napsat nejak,aby to bylo rychlejsi ??

function zjisti(radek: string): integer;
var b: integer;
begin
 For b:= 0 to Form1.Memo1.Lines.Count-1 do
  begin
    If Form1.Memo1.Lines[b] = radek then
      begin
      Form1.Memo1.Lines.Delete(b);
      result:= 1;
      end;
  end;
  result:= 0;
end;

procedure TForm1.Button1Click(Sender: TObject);
var a,c: integer;
begin
  c:= 0;
  For a:= 0 to Memo2.Lines.Count-1 do
  begin
  c:= c + Zjisti(Memo2.Lines[a]);
  end;
  Label1.caption:= ('Odstraneno '+ IntToStr(c)+' zaznamu.');
end;

pokud mate nejakej napad, prosim poradte, dekuju.

ve skutecnosti to pocitani zaznamu by melo byt v te funkci, v Memo1 se radky muzou opakovat,
ale to je nepodstatny, problem je v tom case.
 

podle me by bylo rychlejsi mit dalsi objekt lines, kam bys zkopiroval co se nema odstranit a pak tim prepsat puvodni memo

Nevím, jak je implementovaný ten objekt Lines, ale pokud není úplně dementní, tak zbytečné zpomalení navíc asi udělá hlavně překreslování toho Mema. To by snad mělo jít potlačit přidáním Lines.BeginUpdate a EndUpdate kolem toho cyklu.

Předně, když v seznamu něco mažeš, tak ho procházej odzadu, jinak tě očekávají problémy.
S použitím prostředníka (dočasný seznam kam předávám to, co nemá být smazáno - jak píše KIIV) a hashování jsem se dostal na 5,1s pro porovnání a promazání 50k/14k záznamů (pseudonáhodné stringy o délce 20 - 50 znaků). Nevím, jaká máš vstupní data, ale řekl bych, že taková rychlost je dostatečná, takže tam bych to směřoval.
Nejsem si ale 100% jistý, čeho přesně chceš dosáhnout (podle kódu to vypadá, že z Memo1 chceš vymazat řádky, které se nachází i v Memo2), takže zatím nebudu postovat kód.

Dekuji za prispevky,

ano, je to tak, ze chci vymazat z Memo1 vsechny shodne zaznamy z Memo2.
jestli jsem to spravne pochopil, tak bych mel prohledavat Memo2 radkama z Memo1 a vytvorit treba StringList,kterej bych plnil vsema zaznamama,ktery se neshodujou a tim potom prepsal Memo1.
Akorat nevim u ceho pouzit BeginUpdate a EndUpdate ..
a tim odzadu myslis: 

For a:= Memo1.Lines.Count-1 downto 0 do

??

tak ono od zadu to pomuze jen trosku... (hodne pokud by se odmazavalo prakticky vse)

kazdopadne to ma hned nekolik tezkejch zadrhelu... uz jen to prohledavani jestli jsou jednotlive radky tam je docela narocny... lepsi by bylo spocitat si hashe... nebo aspon mit to druhe v binarnim stromu

pak samozrejme pokud se odmazava od prvniho radku k poslednimu, tak po kazdem odmazani se celej zbytek pameti posouva, prepocitavaji se lines a tak dale

proste slozitost je naprosto brutalni...

a ty updaty by mely zastavit prekreslovani a na konci se pak prekresli jen konecny vysledek... tj. by to melo patrit k tomu co menis a nechces prekreslovat s kazdym odmazanim radku

 Takhle nějak jsem to spíchnul:

{$DEFINE def_FullCompare}

Function DeleteItems(Source, Compare: TMemo): Integer;
var
  i:              Integer;
  TempList:       TStringList;
  CompHashArray:  Array of LongWord;

  Function IsInCompare(const Line: String): Boolean;
  var
    ii:         Integer;
    LineCRC32:  LongWord;
  begin
    Result := False;
    LineCRC32 := CRC32(Line);
    For ii := Low(CompHashArray) to High(CompHashArray) do
      If LineCRC32 = CompHashArray[ii] then
    {$IFDEF def_FullCompare}
        If AnsiSameStr(Line,Compare.Lines[ii]) then
    {$ENDIF}
        begin
          Result := True;
          Break;
        end;
  end;

begin
Result := 0;
If Assigned(Source) and Assigned(Compare) then
  begin
    TempList := TStringList.Create;
    try
      SetLength(CompHashArray,Compare.Lines.Count);
      For i := 0 to (Compare.Lines.Count - 1) do
        CompHashArray[i] := CRC32(Compare.Lines[i]);
      For i := 0 to (Source.Lines.Count - 1) do
        If IsInCompare(Source.Lines[i]) then Inc(Result)
          else TempList.Add(Source.Lines[i]);
      Source.Lines.Assign(TempList);
    finally
      TempList.Free;
    end;
  end;
end;

CRC32 je ze synapse, asi by se dalo použít něco jinýho, ale tohle bylo při ruce. Dalo by se to nejspíš napsat líp, tak pokud máte někdo připomínky nebo postřehy, rád se přiučím. Jináč s tím procházením od konce jsem nemyslel kvůli rychlosti, ale protože při procházení cyklem FOR a při mazání takhle několik položek přeskočí (ty, co se "sesunou" na místo aktuálně vymazané) a na konci bude přistupovat k položkám které už neexistují.

Tak nevim, ..
udelal jsem,ze jsem Mema nahradil ListBoxama a pred prohledavanim jsem jjejich obsah prevedl do StringListu.
potom do SL3 vkladam radky,ktery nejsou shodny. viz:

function zjisti(radek: string): integer;
var e: integer;
begin
  For e:= 0 to Form1.SL2.Count-1 do
    begin
    If Form1.SL2[e] = radek then
      begin
      result:= 0;
      end else
     // Form1.SL3.BeginUpdate;
      Form1.SL3.Add(radek);
     // Form1.SL3.EndUpdate;
      result:= 1;
      end;
end;

procedure TForm1.Button3Click(Sender: TObject);
var a,b: integer;
begin
  b:=0;
  SL1.Assign(ListBox1.Items);
  SL2.Assign(ListBox2.Items);
  For a:= 0 to SL1.Count-1 do
    begin
    Label3.Caption:= SL1[a];
    Application.ProcessMessages;
    b:= b+ Zjisti(SL1[a]);
    Label4.Caption:= IntToSTr(b);
    end;
  ListBox3.Assign(SL3);
  Label5.Caption:= IntToStr(ListBox3.Count);
  ShowMessage('hotovo!!');
end;

s tim BeginUpdate a EndUpdate jsem to asi uplne nepochopil.
vyrazne se to zrychlilo a tohle by mi i stacilo, ale pri zhruba 4500 radku to vyhodi hlasku OutOfMemory ... 
da se nejak ta pamet cistit ??   rikal jsem si treba po kazdym prohlidlym radku SL1 napsat SL1.free, ale to je hrozna blbost, uprostred cyklu to nejde ...

To: Sniper ...  mohl bych te poprosit, jestli by jsi ten kod postnul, podival bych se ,co tam mas jinak a urcite lip ..
 dekuji

#8 Sniper
dekuju, tohle na me vypada dost slozite,ale zkusim se v tom pohrabat.

Co konkrétně ti není jasné?

#11 Sniper
no celkem jsem to uz pochopil, ale kdyz to dam prelozit, tak mi pise, ze neni deklarovany CRC32, tak jsem vlezl na google, a po chvilce stahl  CRC32.pas, jenze kdyz ho dam Components/InstalComponents, tak mi zase pise, ze nenasel TntUnicodeVcl_R70; ..  tak jeste zkusim hledat tohle, treba se nakonec zadari a budu moct zkouset ..
jinak uz se v tom zacinam vyznavat, na prvni pohled mi to prislo slozity, ale druhym pohledem je to celkem prehledny ..  dekuju jeste jednou .
 

Jak jsem psal, ta funkce CRC32 je ze synapse, konkrétně unita synacode. Ale v podstatě půjde použít cokoliv, co spočítá CRC stringu (možná bude třeba změnit název volané funkce).

vim, ze se ptam jak hlupak, ale ze je ze synapse znamena, ze co mam pridat do uses ??

http://synapse.ararat.cz/doku.php

To si nainstaluješ, a do uses dáš synacode. A nebo použij samostatnou unitu na CRC, třeba tady odsud http://www.torry.net/pages.php?id=1548 (nezkoušel jsem nic).

tak uz mi to jede, dekuju moc ...  zase umim neco novyho ..

tak zatim nevim proc, ale vcera jsem pres den a noc nechal pustenej ten muj strasnej pomalej kod a dneska jsem zkusil ten superrychlej tvuj kod a je mezi tim rozdil nejakych 26 radku ..   tem muj jich smazal vic, ale mam to ulozeny, tak projdu ktery to jsou a zkusim najit proc.

Máš nějakej vzorek dat, že bych se na to kouknul?

Když koukám na vaše zdrojové kódy, zdá se mi, že jste zapoměli na funkci IndexOf.  Já osobně bych řešení problematiky implementoval následujícím způsobem, kde testovací data byla následující: seznam ve kterém se hledalo a mazalo měl 60K řádku, a druhý seznam měl 6K řádků. Výsledný čas byl 1:50 [min:sec]. 

procedure DeleteMatch(var lWhere: TStringList; const lProhibited: TStringList);
var
  I: Integer;
  iLine: Integer;
begin
  // Your prohibited list
  for I := 0 to lProhibited.Count - 1 do
  begin
    iLine := lWhere.IndexOf(lProhibited[I]);
    // Find all matches, if there is duplicite item
    while iLine <> -1 do
    begin
      lWhere.Delete(iLine);
      iLine := lWhere.IndexOf(lProhibited[I]);
    end;
  end;
end;

jinak největší zabiják je samozřejmě "softwarová" grafika - překreslení TLabel, překreslení TListBox, ... další věc, kterou bych podotknul je, že Application.ProccessMessage je také velice časově náročná záležitost a navíc ani nemáš možnost zjistit, jak dlouho se vlastně ztrácí na App.ProcMsg, páč je to předání řízení Windowsům, a ty si udělají svou operaci a pak zase dají řízení tvému programu, tudíž bych ani tento krok nezahrnoval do zdrojáku.

PS pokud chceš mermomocí vidět jak droják pokračuje, kde se zrovna nachází místo toho aby jsi překresloval label v každé iteraci použij například toto:

{Jednou za 500 iterací překresli komponentu.
  
Je mnohem^2 rychlejší vypočítat matematickou úlohu tohoto typu než překresli     komponentu.}

if i mod 500 = 0 then
begin
  repaint ...
  app.procMsg
end; 

A jinak jak jsis mohl všimnout, uživatel Sniper používal vnořené funkce ... to je taky dobrý krok ke zrychlení, to je ale dáno překladem do assembleru a to asi nestojí za vysvětlování v tomto příspěvku :)

super, dekuju, za dalsi moznosti,

na vterinach mi nezalezi, ale skoro 20 hodin je fakt moc :o))
je dobre znat i dalsi zpusoby reseni, takze dekuju.

To Sniper: ...  bohuzel vzorek ti dat nemuzu, jsou to interni data nasi firmy a nemam dovoleno je sirit, takze se omlouvam.

To Michal: ... jasny, vnoreni funkce jsem si vsiml jako prvniho, nikdy jsem nepouzil do te doby, ted uz pouzivam skoro vsude ,kde to jde.