Stanislav_Panteleev — digital-flame

Понадобилось, было не очевидно, решил записать

Способ №1 — на примере замены текста на таг итема (взято отсюда)

procedure TTestReportConstructor.ReplaceItemToTag(RVData: TCustomRVData; const OldText, NewText: String);
var  i,r,c: Integer;
     table: TRVTableItemInfo;
     s:string; //TRVRawByteString;
begin
for i := 0 to RVData.Items.Count-1 do
  if RVData.GetItemStyle(i)>=0 then begin // this is a text item
    s := RVData.GetItemText(i); //RVData.Items[i];
    // call your function for replacing OldText with NewText in s here
    if s=OldText then s:=NewText;
    RVData.SetItemText(i,s);
    //RVData.Items[i] := s;
    end
  else if RVData.GetItemStyle(i)=rvsTable then begin
    table := TRVTableItemInfo(RVData.GetItem(i));
    for r := 0 to table.Rows.Count-1 do
      for c := 0 to table.Rows[r].Count-1 do
        if table.Cells[r,c]<>nil then
          ReplaceItemToTag(table.Cells[r,c].GetRVData, OldText, NewText);
    table.Changed;
  end;
end;

procedure TTestReportConstructor.ReplaceItemToTag(RVData: TCustomRVData; const OldText, NewText: String);

var i,r,c: Integer;

table: TRVTableItemInfo;

s:string; //TRVRawByteString;

begin

for i := 0 to RVData.Items.Count-1 do

if RVData.GetItemStyle(i)>=0 then begin // this is a text item

s := RVData.GetItemText(i); //RVData.Items[i];

// call your function for replacing OldText with NewText in s here

if s=OldText then s:=NewText;

RVData.SetItemText(i,s);

//RVData.Items[i] := s;

end

else if RVData.GetItemStyle(i)=rvsTable then begin

table := TRVTableItemInfo(RVData.GetItem(i));

for r := 0 to table.Rows.Count-1 do

for c := 0 to table.Rows[r].Count-1 do

if table.Cells[r,c]<>nil then

ReplaceItemToTag(table.Cells[r,c].GetRVData, OldText, NewText);

table.Changed;

end;

Применение, пусть текст задан так [R]Что-то[/R], а в этом итеме «Какой-то таг», тогда пройтись по всем итемам и заменить текст на таг можно так

procedure TTestReportConstructor.bTestClick(Sender: TObject);
var i: Integer;
    itemText,itemTag,leftBracket,rightBracket:string;
begin

with SRichViewEdit.ActiveEditor do begin
  for i := 0 to RVData.ItemCount-1 do begin
      itemText:=GetItemText(i);
      itemTag:=GetItemTag(i);
      leftBracket:=itemText.Substring(0,3);
      rightBracket:=itemText.Substring(itemText.Length-4,4);
      if (leftBracket='[R]') and (rightBracket='[/R]') and (itemTag<>'') then
      ReplaceItemToTag(SRichViewEdit.ActiveEditor.RVData,itemText,itemTag);
      Format;
  end;
end;

end;

procedure TTestReportConstructor.bTestClick(Sender: TObject);

var i: Integer;

itemText,itemTag,leftBracket,rightBracket:string;

begin

with SRichViewEdit.ActiveEditor do begin

for i := 0 to RVData.ItemCount-1 do begin

itemText:=GetItemText(i);

itemTag:=GetItemTag(i);

leftBracket:=itemText.Substring(0,3);

rightBracket:=itemText.Substring(itemText.Length-4,4);

if (leftBracket='[R]') and (rightBracket='[/R]') and (itemTag<>'') then

ReplaceItemToTag(SRichViewEdit.ActiveEditor.RVData,itemText,itemTag);

Format;

end;

Способ №2 (источник)

procedure SearchAndReplaceAll(InSearch, InReplace: string; Editor: TSRVRichViewEditType) ;
var
  startpos, Position, endpos: integer;
begin
//    if not SRichViewEdit.StartEditing(Editor) then  exit;
    SRichViewEdit.CanUpdate := False;

    SRichViewEdit.ActiveEditor.SetSelectionBounds(
      0, SRichViewEdit.ActiveEditor.GetOffsBeforeItem(0),
      0, SRichViewEdit.ActiveEditor.GetOffsBeforeItem(0)
      );

    while (SRichViewEdit.ActiveEditor.SearchText(
      InSearch,
      [
        RVEdit.TRVESearchOption.rvseoMatchCase,
        RVEdit.TRVESearchOption.rvseoDown,
        RVEdit.TRVESearchOption.rvseoWholeWord,
        RVEdit.TRVESearchOption.rvseoMultiItem,
        RVEdit.TRVESearchOption.rvseoSmartStart

      ]))

      do  SRichViewEdit.ActiveEditor.InsertText(InReplace, False);

      SRichViewEdit.CanUpdate := True;
end;

procedure SearchAndReplaceAll(InSearch, InReplace: string; Editor: TSRVRichViewEditType) ;

var

startpos, Position, endpos: integer;

begin

// if not SRichViewEdit.StartEditing(Editor) then exit;

SRichViewEdit.CanUpdate := False;

SRichViewEdit.ActiveEditor.SetSelectionBounds(

0, SRichViewEdit.ActiveEditor.GetOffsBeforeItem(0),

0, SRichViewEdit.ActiveEditor.GetOffsBeforeItem(0)

);

while (SRichViewEdit.ActiveEditor.SearchText(

InSearch,

[

RVEdit.TRVESearchOption.rvseoMatchCase,

RVEdit.TRVESearchOption.rvseoDown,

RVEdit.TRVESearchOption.rvseoWholeWord,

RVEdit.TRVESearchOption.rvseoMultiItem,

RVEdit.TRVESearchOption.rvseoSmartStart

]))

do SRichViewEdit.ActiveEditor.InsertText(InReplace, False);

SRichViewEdit.CanUpdate := True;

end;

Также понадобится справка для этого способа

Замена контрола на текст( Жми, только сегодня, акция ))))

02.08.201702.08.2017

Delphi. Делаем template на свойства

В С# есть отличная конструкция при объявлении свойства {get;set}, при этом поля создаются автоматически. Отлично, подумал я и решил как-то упростить себе задачу объявления полей и свойств в Delphi. Вдохновившись постом Влада Баженова на тему создания шаблонов. я зашел в

C:\Program Files (x86)\Embarcadero\Studio\17.0\ObjRepos\en\Code_Templates\Delphi

1	C:\Program Files (x86)\Embarcadero\Studio\17.0\ObjRepos\en\Code_Templates\Delphi

Нашёл там шаблон propf.xml, и на основе его сделал свой шаблон и сохранил его как отдельный файл с новым именем

<?xml version="1.0" encoding="utf-8" ?>
<codetemplate	xmlns="http://schemas.borland.com/Delphi/2005/codetemplates"
				version="1.0.0">
	<template name="fieldAndProperty" invoke="auto">
		<description>
			Creates a read only property declaration
		</description>
		<author>
			Embarcadero
		</author>
        <point name="name">
            <text>
                name
            </text>
            <hint>
                The property name
            </hint>
        </point>
        <point name="type">
            <text>
                type
            </text>
            <hint>
                Type of the property
            </hint>
        </point>
        <point name="getter">
            <text>
                getter
            </text>
            <hint>
                Method or field name for getting the property value
            </hint>
        </point>
        <script language="Delphi" onenter="false" onleave="true">
          InvokeClassCompletion;
		</script>
		<code language="Delphi" delimiter="|"><![CDATA[

        F|name|:|type|;
        property |name|: |type| read F|name| write F|name|;|end|
]]>
		</code>
	</template>
</codetemplate>

<?xml version="1.0" encoding="utf-8" ?>

<codetemplate xmlns="http://schemas.borland.com/Delphi/2005/codetemplates"

version="1.0.0">

Creates a read only property declaration

</description>

Embarcadero

</author>

<text>

name

</text>

<hint>

The property name

</hint>

</point>

<text>

type

</text>

<hint>

Type of the property

</hint>

</point>

<text>

getter

</text>

<hint>

Method or field name for getting the property value

</hint>

</point>

InvokeClassCompletion;

</script>

<code language="Delphi" delimiter="|"><![CDATA[

F|name|:|type|;

]]>

</code>

</template>

</codetemplate>

Подумал я, что это прекрасно! Теперь, когда нужно объявить свойство, я просто жму на Ctrl+J

Нахожу там fieldAndProperty, жму на Enter и вставляется вот что

Теперь я меняю слово Fname, а оно меняется автоматом везде, аналогично для слова type и для всех слов, обведенных в рамки.

28.07.201728.07.2017

Алгоритм Дейкстеры — поиск минимального пути на графе при не отрицательных весах ребер

Информация с Интуита…

Итак, пусть граф задан матрицей смежности.

Линейный массив dist будет хранить длины текущих путей от вершины s до всех остальных вершин. В начале этот массив будет инициирован числами MaxLongInt, символизирующими «бесконечность». По окончании работы алгоритма в этом массиве останутся только минимальные значения длин путей, которые и являются расстояниями.

Еще один линейный массив done потребуется нам для того, чтобы хранить информацию о том, найден ли уже минимальный путь (он же расстояние) до соответствующей вершины и можно ли исключить эту вершину из дальнейшего рассмотрения.

Переменная last будет хранить номер последней помеченной вершины. Читать далее «Алгоритм Дейкстеры — поиск минимального пути на графе при не отрицательных весах ребер»

28.07.201728.07.2017

Алгоритмы. Топологическая сортировка методом DFS

На входе бесконтурный орграф (если есть контуры то привет тебе товарищ, не сработает в чистом виде этот алгоритм).

На выходе нужно получить упорядоченный список вершин графа.

Для простоты зададим граф матрицей смежности…

Берем за основу DFS и при каждом проходе добавляем пройденную вершину в наш список. Полученная последовательность и будет результатом сортировки.

Примерный код….

var

  IsVisitedGlobal:array [1..N] of boolean;
  NodesOrder:array [1..N] of integer;
  DirectParent:array [1..N] of integer;

  lastIndexGlobal:integer;
  lastIndexGlobal2:integer;

var

IsVisitedGlobal:array [1..N] of boolean;

NodesOrder:array [1..N] of integer;

DirectParent:array [1..N] of integer;

lastIndexGlobal:integer;

lastIndexGlobal2:integer;

Процедура рандомного заполнения массива

 procedure TMain.randomInitAdjMatrix( var AAdjencyMatrix:TAdjencyMatrix; AsizeOfAdjMatrix:integer  ); // to init random values of AdjMatrix
 var i,j:integer;
 begin
  SetLength(AAdjencyMatrix,AsizeOfAdjMatrix,AsizeOfAdjMatrix);
  for i := 0 to High(AsizeOfAdjMatrix) do begin
    for j := 0 to High(AsizeOfAdjMatrix) do begin
       AAdjencyMatrix[i,j]:=Random(1);
    end;
  end;
 end;

procedure TMain.randomInitAdjMatrix( var AAdjencyMatrix:TAdjencyMatrix; AsizeOfAdjMatrix:integer ); // to init random values of AdjMatrix

var i,j:integer;

begin

SetLength(AAdjencyMatrix,AsizeOfAdjMatrix,AsizeOfAdjMatrix);

for i := 0 to High(AsizeOfAdjMatrix) do begin

for j := 0 to High(AsizeOfAdjMatrix) do begin

AAdjencyMatrix[i,j]:=Random(1);

end;

Инициализация

constructor TMain.Create(AOwner: TComponent);
var
  i: Integer;
begin
  inherited;
for i := 0 to High(Graph) do Graph[i]:=nil;

for i := 0 to High(IsVisitedGlobal) do IsVisitedGlobal[i]:=false;
lastIndexGlobal:=0;
lastIndexGlobal2:=0;
randomInitAdjMatrix(AAdjencyMatrix, N);

end;

constructor TMain.Create(AOwner: TComponent);

var

i: Integer;

begin

inherited;

for i := 0 to High(Graph) do Graph[i]:=nil;

for i := 0 to High(IsVisitedGlobal) do IsVisitedGlobal[i]:=false;

lastIndexGlobal:=0;

lastIndexGlobal2:=0;

randomInitAdjMatrix(AAdjencyMatrix, N);

end;

Рекурсивная процедура обхода в глубину для 1 узла

procedure TMain.DFS(AAdjencyMatrix: TAdjencyMatrix; AsizeOfAdjMatrix, AStartNode: integer );
var i:Integer;

begin

   IsVisitedGlobal[AStartNode]:=true;
   // do something else here
   NodesOrder[lastIndexGlobal]:=AStartNode;  // what is order in topological sort?
   Inc(lastIndexGlobal);

    // no parent for AStartNode

   for i := 0 to AsizeOfAdjMatrix do if
   (AAdjencyMatrix[AStartNode,i]<>0) and not IsVisitedGlobal[i] then
   begin
   DFS(AAdjencyMatrix,AsizeOfAdjMatrix,i);
   DirectParent[lastIndexGlobal2]:=AStartNode;          // who is parent?
   Inc(lastIndexGlobal2);
   end;

end;

procedure TMain.DFS(AAdjencyMatrix: TAdjencyMatrix; AsizeOfAdjMatrix, AStartNode: integer );

var i:Integer;

begin

IsVisitedGlobal[AStartNode]:=true;

// do something else here

NodesOrder[lastIndexGlobal]:=AStartNode; // what is order in topological sort?

Inc(lastIndexGlobal);

// no parent for AStartNode

for i := 0 to AsizeOfAdjMatrix do if

(AAdjencyMatrix[AStartNode,i]<>0) and not IsVisitedGlobal[i] then

begin

DFS(AAdjencyMatrix,AsizeOfAdjMatrix,i);

DirectParent[lastIndexGlobal2]:=AStartNode; // who is parent?

Inc(lastIndexGlobal2);

end;

Полный проход методом DFS для всех узлов

procedure TMain.DFSFull(AAdjencyMatrix: TAdjencyMatrix; AsizeOfAdjMatrix );
var i:integer;
begin
for i := 0 to AsizeOfAdjMatrix-1 do DFS(AAdjencyMatrix, AsizeOfAdjMatrix,i);
end;

procedure TMain.DFSFull(AAdjencyMatrix: TAdjencyMatrix; AsizeOfAdjMatrix );

var i:integer;

begin

for i := 0 to AsizeOfAdjMatrix-1 do DFS(AAdjencyMatrix, AsizeOfAdjMatrix,i);

end;

27.07.201728.07.2017

Delphi. Алгоритмы. DFS. Поиск в глубину рекурсивно

Своими словами. Берем первую вершину, смотрим, нет ли у нее инцидентных ребер (прямых потомков), если есть помечаем, повторяем процедуру для найденной вершины, и так до конца глубины. Возвращаемся, идем к соседней вершине, и так далее.

interface

var
  IsVisitedGlobal:array [1..N] of boolean;

1 2	var IsVisitedGlobal:array [1..N] of boolean;

init visited array

for i := 0 to High(IsVisitedGlobal) do IsVisitedGlobal[i]:=false;

1	for i := 0 to High(IsVisitedGlobal) do IsVisitedGlobal[i]:=false;

dfs

procedure TMain.DFS(AAdjencyMatrix: TAdjencyMatrix; AsizeOfAdjMatrix, AStartNode: integer );
var i:Integer;
begin
   IsVisitedGlobal[AStartNode]:=true;
   // do somesting else here
   for i := 0 to AsizeOfAdjMatrix do if
   (AAdjencyMatrix[AStartNode,i]<>0) and not IsVisitedGlobal[i] then
   DFS(AAdjencyMatrix,AsizeOfAdjMatrix,i);
end;

procedure TMain.DFS(AAdjencyMatrix: TAdjencyMatrix; AsizeOfAdjMatrix, AStartNode: integer );

var i:Integer;

begin

IsVisitedGlobal[AStartNode]:=true;

// do somesting else here

for i := 0 to AsizeOfAdjMatrix do if

(AAdjencyMatrix[AStartNode,i]<>0) and not IsVisitedGlobal[i] then

DFS(AAdjencyMatrix,AsizeOfAdjMatrix,i);

end;

Теперь, если наш граф не дерево с единственным корнем, обходим по всем узлам

procedure TMain.DFSFull(AAdjencyMatrix: TAdjencyMatrix; AsizeOfAdjMatrix );
var i:integer;
begin
for i := 0 to AsizeOfAdjMatrix-1 do DFS(AAdjencyMatrix, AsizeOfAdjMatrix,i);
end;

procedure TMain.DFSFull(AAdjencyMatrix: TAdjencyMatrix; AsizeOfAdjMatrix );

var i:integer;

begin

for i := 0 to AsizeOfAdjMatrix-1 do DFS(AAdjencyMatrix, AsizeOfAdjMatrix,i);

end;

27.07.201727.07.2017

Delphi. Алгоритмы. BFS — обход графа в ширину

Теория хорошо описана на Вики. Суть в этой гифке ниже.

Моя скромная реализация для представления графа в виде матрицы смежности. Ноль в матрице смежности означает отсутствие ребра между вершинами. Единица — наличие. В основе обхода в ширину — такая структура как очередь. Первым вошел, первым вышел.

Своими словами (самое ценное, когда своими словами).

1 Берем стартовую вершину. Добавляем ее в очередь.

2 Ищем у этой вершины все инцидентные ребра. Добавляем их в очередь.

3 При добавлении каждой вершины что-то делаем.

4 Первая вершина отработала, удаляем ее из очереди.

5 Берем следующую по очереди вершину (в моей реализации left+1) и повторяем с п. 2

type TAdjencyMatrix=array of array of Integer;

1	type TAdjencyMatrix=array of array of Integer;

procedure TMain.BFS(AAdjencyMatrix: TAdjencyMatrix; AsizeOfAdjMatrix, AStartNode: integer );

var  i,
     leftIndex,
     rightIndex:integer;

     isVisitedArray : array of boolean;
     queue : array of integer;
     sizeOfAdjMatrix:Integer;
begin
// initialization

 //AAdjencyMatrix must be inited before
 //randomInitAdjMatrix(AsizeOfAdjMatrix);

     SetLength(isVisitedArray,sizeOfAdjMatrix);
     for i := 0 to High(isVisitedArray) do isVisitedArray[i]:=false;

     SetLength(queue,sizeOfAdjMatrix); // max possible count of direct children
     for i := 0 to High(queue) do queue[i]:=0;

     leftIndex:=1;
     rightIndex:=1;

 queue[rightIndex]:=AStartNode;
 isVisitedArray[AStartNode]:=true;

 while leftIndex<=rightIndex do begin

   for i := 0 to sizeOfAdjMatrix-1 do

    if AAdjencyMatrix[AStartNode,i]<>0 then  // all direct children
       begin

         Inc(rightIndex);
         queue[rightIndex]:=i; // adding to queue new element
         isVisitedArray[i]:=true;
         // do something else

       end;

       Inc(leftIndex);  // removing from queue left element
       AStartNode:=queue[leftIndex];  // setting new start node

 end;

end;

procedure TMain.BFS(AAdjencyMatrix: TAdjencyMatrix; AsizeOfAdjMatrix, AStartNode: integer );

var i,

leftIndex,

rightIndex:integer;

isVisitedArray : array of boolean;

queue : array of integer;

sizeOfAdjMatrix:Integer;

begin

// initialization

//AAdjencyMatrix must be inited before

//randomInitAdjMatrix(AsizeOfAdjMatrix);

SetLength(isVisitedArray,sizeOfAdjMatrix);

for i := 0 to High(isVisitedArray) do isVisitedArray[i]:=false;

SetLength(queue,sizeOfAdjMatrix); // max possible count of direct children

for i := 0 to High(queue) do queue[i]:=0;

leftIndex:=1;

rightIndex:=1;

queue[rightIndex]:=AStartNode;

isVisitedArray[AStartNode]:=true;

while leftIndex<=rightIndex do begin

for i := 0 to sizeOfAdjMatrix-1 do

if AAdjencyMatrix[AStartNode,i]<>0 then // all direct children

begin

Inc(rightIndex);

queue[rightIndex]:=i; // adding to queue new element

isVisitedArray[i]:=true;

// do something else

end;

Inc(leftIndex); // removing from queue left element

AStartNode:=queue[leftIndex]; // setting new start node

end;

Также рандомная инициализация BFS

 procedure TMain.randomInitAdjMatrix( var AAdjencyMatrix:TAdjecyMatrix; AsizeOfAdjMatrix:integer  ); // to init random values of AdjMatrix
 var i,j:integer;
 begin
  SetLength(AAdjencyMatrix,AsizeOfAdjMatrix,AsizeOfAdjMatrix);
  for i := 0 to High(AsizeOfAdjMatrix) do begin
    for j := 0 to High(AsizeOfAdjMatrix) do begin
       AAdjencyMatrix[i,j]:=Random(1);
    end;
  end;
 end;

procedure TMain.randomInitAdjMatrix( var AAdjencyMatrix:TAdjecyMatrix; AsizeOfAdjMatrix:integer ); // to init random values of AdjMatrix

var i,j:integer;

begin

SetLength(AAdjencyMatrix,AsizeOfAdjMatrix,AsizeOfAdjMatrix);

for i := 0 to High(AsizeOfAdjMatrix) do begin

for j := 0 to High(AsizeOfAdjMatrix) do begin

AAdjencyMatrix[i,j]:=Random(1);

end;

Список источников, которые мне помогли)

Отличная тема на форуме

27.07.201727.07.2017

Delphi. Алгоритмы. Создание графа на списках смежности

Повторяем основы. Теорию переписывать не буду, лишь моя скромная реализация базовых функций — добавить ребро, удалить ребро, найти ребро. Из которых впоследствии можно сделать граф на списках смежности.

Основная идея графа на списках смежности как я понял для себя ещё раз) — сделать массив списков смежности. Описывая граф, мы смотрим, связана ли его вершина с другими вершинами, если да, то создаем список смежности, скажем 1 вершина связана с 5 и 7, значит, можем создать такой список из 3 элементов, в котором из 1 вершины будет ссылка на 5, из 5 на 7, либо в другом порядке, но важно, что мы перечислили все вершины, с которыми смежна наша 1 вершина. Таким макаром проходим по всем другим вершинам, должно получиться что-то вроде…

Теория хорошо описана здесь.

Так как была ночь и я устал, бахаю весь модуль…

unit uMain;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.Samples.Spin, Vcl.StdCtrls, Vcl.Buttons;

type TadjencyListElement=^AdjencyListElement;

   AdjencyListElement=record

   vertex:integer; // number of adjency vertex
   weight:integer;
   next:TadjencyListElement; // pointer to next vertex

end;


type
  TMain = class(TForm)
    MemoTest: TMemo;
    bAddEdge: TBitBtn;
    seVertex1: TSpinEdit;
    seVertex2: TSpinEdit;
    Vertex1: TLabel;
    Vertex2: TLabel;
    bRemoveEdge: TBitBtn;
    SpinEdit1: TSpinEdit;
    SpinEdit2: TSpinEdit;
    Label1: TLabel;
    Label2: TLabel;
    procedure bAddEdgeClick(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
  private
    { Private declarations }

    function addEdge(AVertex1, AVertex2:integer):boolean;
    {will add to the end of adjency list or will create a first element if empty or nil }

    procedure deleteEdge(AFirstAdjencyListElement,ADeletedAdjencyListElement:TadjencyListElement);
    {< will delete in adjency list ADeletedAdjencyListElement }

    function  searchByVertex(AFirstAdjencyListElement:TadjencyListElement; AVertex:integer):TadjencyListElement;
    {< will search in adjency list an AdjencyListElement (edge) with vertex=AVertex  }

    procedure clearMemory();

  public
    { Public declarations }
    constructor Create(AOwner: TComponent); override;
  end;

const N=10;
var
  Main: TMain;
  Graph:Array [1..N] of TadjencyListElement;

implementation

{$R *.dfm}

{ TMain }

function TMain.addEdge(AVertex1, AVertex2:integer):boolean;

var newAdjencyListElement:TadjencyListElement;
    tempAdjencyListElement:TadjencyListElement;

begin
result:=false;
// will insert edge beetwen vertex x and vertex y

 if Graph[AVertex1]<>nil then begin // if list in x vertex already sterted, add to the end of adjency list

  if searchByVertex( Graph[AVertex1],AVertex2)=nil then begin // if no such vertex

  New(newAdjencyListElement);
  newAdjencyListElement.vertex:=AVertex2;
  newAdjencyListElement.next:=nil;

  tempAdjencyListElement:=Graph[AVertex1];
  while tempAdjencyListElement^.Next<>nil do
  tempAdjencyListElement:=tempAdjencyListElement^.next; // now tempAdjencyListElement is the last in adjency list

  tempAdjencyListElement^.next:=newAdjencyListElement; // now it points to the last added adjency element
  result:=True;
  end;

 end else

 begin  // creating first new element of adjency list

    New(newAdjencyListElement);
    newAdjencyListElement^.vertex:=AVertex2;
    newAdjencyListElement^.next:=nil;
    Graph[AVertex1]:=newAdjencyListElement;
 result:=True;
 end;


end;



procedure TMain.bAddEdgeClick(Sender: TObject);
begin
if addEdge(seVertex1.Value,seVertex2.Value) then
MemoTest.Lines.Add('v1='+seVertex1.Value.ToString()+' '+'v2='+seVertex2.Value.ToString());
end;

procedure TMain.clearMemory;
var
  i: Integer;
begin
 for i := 0 to High(Graph) do if Graph[i]<>nil then  Dispose(TadjencyListElement(Graph[i]));
end;

constructor TMain.Create(AOwner: TComponent);
var
  i: Integer;
begin
  inherited;
for i := 0 to High(Graph) do Graph[i]:=nil;

end;

procedure TMain.deleteEdge(AFirstAdjencyListElement,ADeletedAdjencyListElement:TadjencyListElement);
var tempAdjencyListElement:TadjencyListElement;
    beforeDeletedAdjencyListElement:TadjencyListElement;

begin

// case 1 element in adjency list
 if  (AFirstAdjencyListElement.next=nil) and (ADeletedAdjencyListElement=AFirstAdjencyListElement) then
dispose(ADeletedAdjencyListElement)

else

// case deleted element is first
if AFirstAdjencyListElement=ADeletedAdjencyListElement then begin
//AFirstAdjencyListElement:=AFirstAdjencyListElement.next;
dispose(ADeletedAdjencyListElement)
end

 else

 begin

  // search for element before deleted
  tempAdjencyListElement:=AFirstAdjencyListElement;
  while tempAdjencyListElement<>ADeletedAdjencyListElement do
  begin
  beforeDeletedAdjencyListElement:=tempAdjencyListElement;
  tempAdjencyListElement:=tempAdjencyListElement.next;
  end;

  //change links
  if ADeletedAdjencyListElement.next<>nil then  // if not last element
  beforeDeletedAdjencyListElement.next:=ADeletedAdjencyListElement.next else
  beforeDeletedAdjencyListElement.next:=nil;

  //delete
  dispose(ADeletedAdjencyListElement);

 end;


end;

procedure TMain.FormClose(Sender: TObject; var Action: TCloseAction);
begin
ReportMemoryLeaksOnShutdown:=true;
clearMemory();
end;

function TMain.searchByVertex(AFirstAdjencyListElement: TadjencyListElement; AVertex: integer):TadjencyListElement;
var tempAdjencyListElement:TadjencyListElement;
begin
Result:=nil;

tempAdjencyListElement:=AFirstAdjencyListElement;

  repeat
    if tempAdjencyListElement.vertex=AVertex then
    begin
    Result:=tempAdjencyListElement;
    Break;
    end;
  tempAdjencyListElement:=tempAdjencyListElement.next;
  until tempAdjencyListElement=nil;

end;

end.

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

123

124

125

126

127

128

129

130

131

132

133

134

135

136

137

138

139

140

141

142

143

144

145

146

147

148

149

150

151

152

153

154

155

156

157

158

159

160

161

162

163

164

165

166

167

168

169

170

171

172

173

174

175

176

177

178

179

180

181

182

183

184

185

186

187

188

189

190

191

192

193

194

195

unit uMain;

interface

uses

Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,

Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.Samples.Spin, Vcl.StdCtrls, Vcl.Buttons;

type TadjencyListElement=^AdjencyListElement;

AdjencyListElement=record

vertex:integer; // number of adjency vertex

weight:integer;

next:TadjencyListElement; // pointer to next vertex

end;

type

TMain = class(TForm)

MemoTest: TMemo;

bAddEdge: TBitBtn;

seVertex1: TSpinEdit;

seVertex2: TSpinEdit;

Vertex1: TLabel;

Vertex2: TLabel;

bRemoveEdge: TBitBtn;

SpinEdit1: TSpinEdit;

SpinEdit2: TSpinEdit;

Label1: TLabel;

Label2: TLabel;

procedure bAddEdgeClick(Sender: TObject);

procedure FormClose(Sender: TObject; var Action: TCloseAction);

private

{ Private declarations }

function addEdge(AVertex1, AVertex2:integer):boolean;

{will add to the end of adjency list or will create a first element if empty or nil }

procedure deleteEdge(AFirstAdjencyListElement,ADeletedAdjencyListElement:TadjencyListElement);

{< will delete in adjency list ADeletedAdjencyListElement }

function searchByVertex(AFirstAdjencyListElement:TadjencyListElement; AVertex:integer):TadjencyListElement;

{< will search in adjency list an AdjencyListElement (edge) with vertex=AVertex }

procedure clearMemory();

public

{ Public declarations }

constructor Create(AOwner: TComponent); override;

end;

const N=10;

var

Main: TMain;

Graph:Array [1..N] of TadjencyListElement;

implementation

{$R *.dfm}

{ TMain }

function TMain.addEdge(AVertex1, AVertex2:integer):boolean;

var newAdjencyListElement:TadjencyListElement;

tempAdjencyListElement:TadjencyListElement;

begin

result:=false;

// will insert edge beetwen vertex x and vertex y

if Graph[AVertex1]<>nil then begin // if list in x vertex already sterted, add to the end of adjency list

if searchByVertex( Graph[AVertex1],AVertex2)=nil then begin // if no such vertex

New(newAdjencyListElement);

newAdjencyListElement.vertex:=AVertex2;

newAdjencyListElement.next:=nil;

tempAdjencyListElement:=Graph[AVertex1];

while tempAdjencyListElement^.Next<>nil do

tempAdjencyListElement:=tempAdjencyListElement^.next; // now tempAdjencyListElement is the last in adjency list

tempAdjencyListElement^.next:=newAdjencyListElement; // now it points to the last added adjency element

result:=True;

end;

end else

begin // creating first new element of adjency list

New(newAdjencyListElement);

newAdjencyListElement^.vertex:=AVertex2;

newAdjencyListElement^.next:=nil;

Graph[AVertex1]:=newAdjencyListElement;

result:=True;

end;

procedure TMain.bAddEdgeClick(Sender: TObject);

begin

if addEdge(seVertex1.Value,seVertex2.Value) then

MemoTest.Lines.Add('v1='+seVertex1.Value.ToString()+' '+'v2='+seVertex2.Value.ToString());

end;

procedure TMain.clearMemory;

var

i: Integer;

begin

for i := 0 to High(Graph) do if Graph[i]<>nil then Dispose(TadjencyListElement(Graph[i]));

end;

constructor TMain.Create(AOwner: TComponent);

var

i: Integer;

begin

inherited;

for i := 0 to High(Graph) do Graph[i]:=nil;

end;

procedure TMain.deleteEdge(AFirstAdjencyListElement,ADeletedAdjencyListElement:TadjencyListElement);

var tempAdjencyListElement:TadjencyListElement;

beforeDeletedAdjencyListElement:TadjencyListElement;

begin

// case 1 element in adjency list

if (AFirstAdjencyListElement.next=nil) and (ADeletedAdjencyListElement=AFirstAdjencyListElement) then

dispose(ADeletedAdjencyListElement)

else

// case deleted element is first

if AFirstAdjencyListElement=ADeletedAdjencyListElement then begin

//AFirstAdjencyListElement:=AFirstAdjencyListElement.next;

dispose(ADeletedAdjencyListElement)

end

else

begin

// search for element before deleted

tempAdjencyListElement:=AFirstAdjencyListElement;

while tempAdjencyListElement<>ADeletedAdjencyListElement do

begin

beforeDeletedAdjencyListElement:=tempAdjencyListElement;

tempAdjencyListElement:=tempAdjencyListElement.next;

end;

//change links

if ADeletedAdjencyListElement.next<>nil then // if not last element

beforeDeletedAdjencyListElement.next:=ADeletedAdjencyListElement.next else

beforeDeletedAdjencyListElement.next:=nil;

//delete

dispose(ADeletedAdjencyListElement);

end;

procedure TMain.FormClose(Sender: TObject; var Action: TCloseAction);

begin

ReportMemoryLeaksOnShutdown:=true;

clearMemory();

end;

function TMain.searchByVertex(AFirstAdjencyListElement: TadjencyListElement; AVertex: integer):TadjencyListElement;

var tempAdjencyListElement:TadjencyListElement;

begin

Result:=nil;

tempAdjencyListElement:=AFirstAdjencyListElement;

repeat

if tempAdjencyListElement.vertex=AVertex then

begin

Result:=tempAdjencyListElement;

Break;

end;

tempAdjencyListElement:=tempAdjencyListElement.next;

until tempAdjencyListElement=nil;

end;

end.

Ну и исходнички 412_Graph

Чуть позже на форуме дали более простой и элегантный способ сделать тоже самое

TNode = class
  ID:integer;
end;
TEdge = class
  Node1,Node2:TNode;
  weight:integer;
end;
TNodeList=class(TObjectList<TNode>)
end;
TEdgeList=class(TObjectList<TEdge>)
end;

TNode = class

ID:integer;

end;

TEdge = class

Node1,Node2:TNode;

weight:integer;

end;

TNodeList=class(TObjectList<TNode>)

end;

TEdgeList=class(TObjectList<TEdge>)

end;

Заводим список вершин и ребер

nodes:=TNodeList.Create;
edges:=TEdgeList.Create;

1 2	nodes:=TNodeList.Create; edges:=TEdgeList.Create;

Добавляем пару вершин и ребро, которое их соединяет

node:=TNode .Create();
node.ID:=nodes.Count;
nodes.Add(Node);
node:=TNode.Create();
node.ID:=nodes.Count;
nodes.Add(Node);
 
edge:=TEdge.Create;
edge.node1:=nodes[0];
edge.node2:=nodes[1];
edges.add(Edge);

node:=TNode .Create();

node.ID:=nodes.Count;

nodes.Add(Node);

node:=TNode.Create();

node.ID:=nodes.Count;

nodes.Add(Node);

edge:=TEdge.Create;

edge.node1:=nodes[0];

edge.node2:=nodes[1];

edges.add(Edge);

Уничтожаем

edges.free;
nodes.free;

1 2	edges.free; nodes.free;

18.07.201718.07.2017

MySQL — делаем swap 2 значений одной колонки

Понадобилось для задачи «Поднять, опустить» в списке клиента через базу.

Дергаем одну из процедур, описанных ниже и обновляем множество на клиенте. Вся работа происходит на сервере базы.

Вот таблица, для которой это сделано

главное здесь, это sortIndex

Все значения отсортированы по sortIndex. Простое и элегантное решение через хранимые процедуры в MySQL

Вариант № 1 Универсальный, записи могут находиться где угодно в этой таблице

CREATE PROCEDURE `swapSortIndex_testscales`(AID1 integer,AID2 integer)
BEGIN

#getting sortIndexes
SELECT sortIndex FROM testscales WHERE id=AID1 into @SortIndex1;
SELECT sortIndex FROM testscales WHERE id=AID2 into @SortIndex2;

# updating sortIndex1
   UPDATE testscales SET sortIndex = @SortIndex2 where id=AID1;

# updating sortIndex2
 UPDATE testscales SET sortIndex = @SortIndex1 where id=AID2;
 

END

CREATE PROCEDURE `swapSortIndex_testscales`(AID1 integer,AID2 integer)

BEGIN

#getting sortIndexes

SELECT sortIndex FROM testscales WHERE id=AID1 into @SortIndex1;

SELECT sortIndex FROM testscales WHERE id=AID2 into @SortIndex2;

# updating sortIndex1

UPDATE testscales SET sortIndex = @SortIndex2 where id=AID1;

# updating sortIndex2

UPDATE testscales SET sortIndex = @SortIndex1 where id=AID2;

END

Вариант №2 Записи должны находиться рядом друг с другом

swapDown

CREATE PROCEDURE `swapSortIndexDown_testscales`(AID integer)
BEGIN

#getting current previous value of sortIndex and id
SELECT sortIndex FROM testscales WHERE id > AID ORDER BY id DESC LIMIT 1 into @NextSortIndex;
SELECT id FROM testscales WHERE id > AID ORDER BY id DESC LIMIT 1 into @NextID;
#SELECT * FROM foo WHERE id > 4 ORDER BY id LIMIT 1;
SELECT sortIndex FROM testscales WHERE id=AID into @CurrSortIndex;


if (@NextID IS NOT NULL) and (@NextID<>AID) then begin 

# updating next ID
   UPDATE testscales SET sortIndex = @CurrSortIndex where id=@NextID;

# updating current
 UPDATE testscales SET sortIndex = @NextSortIndex where id=AID;
 #Set @PrevSortIndex = @temp;

   

end; 
 
else begin
#
end;
 
end if;


END

CREATE PROCEDURE `swapSortIndexDown_testscales`(AID integer)

BEGIN

#getting current previous value of sortIndex and id

SELECT sortIndex FROM testscales WHERE id > AID ORDER BY id DESC LIMIT 1 into @NextSortIndex;

SELECT id FROM testscales WHERE id > AID ORDER BY id DESC LIMIT 1 into @NextID;

#SELECT * FROM foo WHERE id > 4 ORDER BY id LIMIT 1;

SELECT sortIndex FROM testscales WHERE id=AID into @CurrSortIndex;

if (@NextID IS NOT NULL) and (@NextID<>AID) then begin

# updating next ID

UPDATE testscales SET sortIndex = @CurrSortIndex where id=@NextID;

# updating current

UPDATE testscales SET sortIndex = @NextSortIndex where id=AID;

#Set @PrevSortIndex = @temp;

end;

else begin

end;

end if;

END

swapUP

CREATE PROCEDURE `swapSortIndexUp_testscales`(AID integer)
BEGIN

#getting current previous value of sortIndex and id
SELECT sortIndex FROM testscales WHERE id < AID ORDER BY id DESC LIMIT 1 into @PrevSortIndex;
SELECT sortIndex FROM testscales WHERE id=AID into @CurrSortIndex;
SELECT id FROM testscales WHERE id < AID ORDER BY id DESC LIMIT 1 into @PrevID;

if (@PrevID IS NOT NULL) and (@PrevID<>AID) then begin 

# updating current
 UPDATE testscales SET sortIndex = @PrevSortIndex where id=AID;
 #Set @PrevSortIndex = @temp;

   # updating previous ID
   UPDATE testscales SET sortIndex = @CurrSortIndex where id=@PrevID;

end; 
 
else begin
#
end;
 
end if;


END

CREATE PROCEDURE `swapSortIndexUp_testscales`(AID integer)

BEGIN

#getting current previous value of sortIndex and id

SELECT sortIndex FROM testscales WHERE id < AID ORDER BY id DESC LIMIT 1 into @PrevSortIndex;

SELECT sortIndex FROM testscales WHERE id=AID into @CurrSortIndex;

SELECT id FROM testscales WHERE id < AID ORDER BY id DESC LIMIT 1 into @PrevID;

if (@PrevID IS NOT NULL) and (@PrevID<>AID) then begin

# updating current

UPDATE testscales SET sortIndex = @PrevSortIndex where id=AID;

#Set @PrevSortIndex = @temp;

# updating previous ID

UPDATE testscales SET sortIndex = @CurrSortIndex where id=@PrevID;

end;

else begin

end;

end if;

END

Дергаем примерно так…

set @AID = 0;
call coffeetest_db.swapSortIndexDown_testscales(@AID);
select @AID;

set @AID = 0;

call coffeetest_db.swapSortIndexDown_testscales(@AID);

select @AID;

Пример реализации для Delphi клиента

procedure TTestsAddEditForm.bScaleUpClick(Sender: TObject);

var idCurrScale:integer;
    idSL:TStringList;
    qSelectScalesWhereTestID_local:TFDQuery;
    myOwner: TTestsMF;
    searchIndex:integer;
begin

myOwner:=(Self.Owner.Owner as TTestsMF);

// gathering all id
idSL:=TStringList.Create;
qSelectScalesWhereTestID_local:=TFDQuery.Create(Self);
try

with qSelectScalesWhereTestID_local do begin
Connection:=myOwner.FDConnection_ExternalConnect;
SQL.Text:='SELECT * FROM coffeetest_db.testscales where tests_id=:tests_id order by SortIndex;';
params.ParamValues['tests_id']:=FTestID;
Disconnect();
Open();
 while not EOF do begin
 idSL.Add(FieldByName('id').AsInteger.ToString());
 Next();
 end;

 Close();
end;


//exchange indexes
idCurrScale:=qSelectScalesWhereTestID.FieldByName('id').AsInteger;

// is simething higher this id?
searchIndex:=idSL.IndexOf(idCurrScale.ToString());
if searchIndex<>-1 then begin

  //it it is not last element then swap sort Indexes
  if searchIndex<>0 then begin
    FDStoredProc.Connection:=myOwner.FDConnection_ExternalConnect;
    FDStoredProc.ExecProc('swapSortIndex_testscales', [ idCurrScale,idSL[searchIndex-1] ]);
  end;


end;

finally
idSL.Free;
qSelectScalesWhereTestID_local.Free();
end;

//update
qSelectScalesWhereTestID.Close();
qSelectScalesWhereTestID.Open();

//set cursor to previous place
qSelectScalesWhereTestID.Locate('id',idCurrScale,[]);

end;

procedure TTestsAddEditForm.bScaleUpClick(Sender: TObject);

var idCurrScale:integer;

idSL:TStringList;

qSelectScalesWhereTestID_local:TFDQuery;

myOwner: TTestsMF;

searchIndex:integer;

begin

myOwner:=(Self.Owner.Owner as TTestsMF);

// gathering all id

idSL:=TStringList.Create;

qSelectScalesWhereTestID_local:=TFDQuery.Create(Self);

try

with qSelectScalesWhereTestID_local do begin

Connection:=myOwner.FDConnection_ExternalConnect;

SQL.Text:='SELECT * FROM coffeetest_db.testscales where tests_id=:tests_id order by SortIndex;';

params.ParamValues['tests_id']:=FTestID;

Disconnect();

Open();

while not EOF do begin

idSL.Add(FieldByName('id').AsInteger.ToString());

Next();

end;

Close();

end;

//exchange indexes

idCurrScale:=qSelectScalesWhereTestID.FieldByName('id').AsInteger;

// is simething higher this id?

searchIndex:=idSL.IndexOf(idCurrScale.ToString());

if searchIndex<>-1 then begin

//it it is not last element then swap sort Indexes

if searchIndex<>0 then begin

FDStoredProc.Connection:=myOwner.FDConnection_ExternalConnect;

FDStoredProc.ExecProc('swapSortIndex_testscales', [ idCurrScale,idSL[searchIndex-1] ]);

end;

finally

idSL.Free;

qSelectScalesWhereTestID_local.Free();

end;

//update

qSelectScalesWhereTestID.Close();

qSelectScalesWhereTestID.Open();

//set cursor to previous place

qSelectScalesWhereTestID.Locate('id',idCurrScale,[]);

end;

18.07.201720.07.2017

Delphi. Ручное управление транзакциями

Работаю с MySQL InnoDB, там транзакции, коммиты и откаты идут автоматом, но товарищ мой сказал «хочу сам управлять этим». И вот что получилось, море кода, но да, управление есть…

На примере вставки записи в новую таблицу

 if not InputQuery('Название шкалы','',scaleName) then exit;

  myOwner:=(Self.Owner.Owner as TTestsMF);

  //add scale here
  with qSelectScalesWhereTestID do begin
  Connection:=myOwner.FDConnection_ExternalConnect;
      try
       Params.ParamValues['tests_id']:=FTestID;
       CachedUpdates:=true;
       Open();
       trWrite.StartTransaction();
       Insert();
       FieldByName('name').AsString:=scaleName;
       //Post();

       if ApplyUpdates<>0 then raise Exception.Create(RowError.Message);
       trWrite.Commit();
       scaleID_local:=myOwner.CommonMethods.getLastInsertID();
      except

       on E:Exception do begin
       if trWrite.Active then trWrite.Rollback;
       Cancel;
       CancelUpdates;
       Application.ShowException(E);
       end;
      end;
  end;

if not InputQuery('Название шкалы','',scaleName) then exit;

myOwner:=(Self.Owner.Owner as TTestsMF);

//add scale here

with qSelectScalesWhereTestID do begin

Connection:=myOwner.FDConnection_ExternalConnect;

try

Params.ParamValues['tests_id']:=FTestID;

CachedUpdates:=true;

Open();

trWrite.StartTransaction();

Insert();

FieldByName('name').AsString:=scaleName;

//Post();

if ApplyUpdates<>0 then raise Exception.Create(RowError.Message);

trWrite.Commit();

scaleID_local:=myOwner.CommonMethods.getLastInsertID();

except

on E:Exception do begin

if trWrite.Active then trWrite.Rollback;

Cancel;

CancelUpdates;

Application.ShowException(E);

end;

А как Вы обрабатываете транзакции?

Автор: Stanislav_Panteleev

Евгений Зуев о языках программирования

Delphi. TRichView. Замена текста на текст и контрола на текст

Замена контрола на текст( Жми, только сегодня, акция ))))

Delphi. Делаем template на свойства

Алгоритм Дейкстеры — поиск минимального пути на графе при не отрицательных весах ребер

Алгоритмы. Топологическая сортировка методом DFS

Delphi. Алгоритмы. DFS. Поиск в глубину рекурсивно

Delphi. Алгоритмы. BFS — обход графа в ширину

Delphi. Алгоритмы. Создание графа на списках смежности

MySQL — делаем swap 2 значений одной колонки

Вариант № 1 Универсальный, записи могут находиться где угодно в этой таблице

Вариант №2 Записи должны находиться рядом друг с другом

Пример реализации для Delphi клиента

Delphi. Ручное управление транзакциями