### Bookstore

 Computer Math and Games in Pascal (preview) Lazarus Handbook (preview only)

### Author Topic: Example Code Question  (Read 1219 times)

#### JLWest

• Hero Member
• Posts: 550
##### Example Code Question
« on: April 22, 2019, 02:47:41 am »
Code: Pascal  [Select]
1. unit Unit1;
2.
3. {\$mode objfpc}{\$H+}
4.
5. interface
6.
7. uses
8.   Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, StdCtrls,
9.   Buttons;
10.
11. type
12.
13.   //intType = array [0..10] of integer;
14.   intType = array  of integer;
15.   { TForm1 }
16.
17.   TForm1 = class(TForm)
18.     btnFromArray: TBitBtn;
20.     btnClose: TButton;
21.     ListBox1: TListBox;
22.
23.
24.   procedure btnFromArrayClick(Sender: TObject);
26.   procedure btnCloseClick(Sender: TObject);
27.   procedure FormCreate(Sender: TObject);
28.   function  Search5(aInt : Integer) : Boolean;
29.   function Rnorm (mean, sd: real): real;
30.
31.   procedure SetIntegerArray;
32.   procedure SortIntegerArray;
33.
34.   private
35.
36.   public
37.
38.   end;
39.
40. var
41.   Form1: TForm1;
42.   Data2 :  intType;
43.
44. implementation
45.
46. {\$R *.lfm}
47.
48.  procedure TForm1.FormCreate(Sender: TObject);
49.   begin
50.     SetLength(Data2,10);
51.     Listbox1.Clear;
52.
53.   end;
54.
56.   var I   : Integer = -1;
57.     Bit1  : String  = '';
58.     iReal : Real;
59.     iInt  : Integer;
60.   begin
61.     for i := Low(Data2) to High(Data2)  do  begin
62.      iReal := RNorm(50,200);
63.      iReal := Round(iReal);
64.      Bit1 :=  FloatToStr(iReal);
66.      iInt := StrToInt(Bit1);
67.      if data2[0] = 0 then Begin Data2[0] := iInt; end;
68.      SortIntegerArray
69.     end;
70.
71.   end;
72.
73. procedure TForm1.btnFromArrayClick(Sender: TObject);
74.  var I   : Integer = -1;
75.     Bit1  : String  = '';
76.     iReal : Real;
77.     iInt  : Integer;
78.  begin
79.   ListBox1.Clear;
80.   for i := Low(Data2) to High(Data2)  do  begin
81.      iInt := Data2[i];
82.      Bit1 := IntToStr(iInt);
84.     end;
85. end;
86.
87.
88.  procedure TForm1.SortIntegerArray;
89.   var I : Integer = -1;
90.    SwapMade : Boolean = False;
91.    HoldInt  : Integer;
92.    Done : Boolean = False;
93.   begin
94.       repeat
96.         Done := True;
97.       for i := Low(Data2) to High(Data2) -1 do begin
98.          if Data2[i]  > Data2[i + 1] then begin
100.             Done := False;
101.             HoldInt := Data2[i];
102.             Data2[i]           := Data2[i + 1];
103.             Data2[i + 1] := HoldInt;
104.             end;
105.       end;
106.     until Done;
107.  end;
108.
109.  function TForm1.Search5(aInt : Integer) : Boolean;
110.   Var i : Integer;
111.    LB5Rcd : String = '';
112.    Bit1   : String = '';
113.    Idx    : Integer;
114.    Present : Boolean = False;
115.    begin
116.     for i := Low(Data2) to High(Data2) do begin
117.         if Data2[i] = aInt then begin
118.            present := True;
119.            Break;
120.         end;
121.     end;
122.      Result := Present;
123.    end;
124.
125.  procedure TForm1.btnCloseClick(Sender: TObject);
126.   begin
127.    SetLength(Data2,0);
128.    Close;
129.   end;
130.
131.  procedure TForm1.SetIntegerArray;
132.   Var i : Integer = -1;
133.   { Data2 : Array [0..100] of Integer;  }
134.   begin
135.    for i := Low(Data2) to High(Data2) do begin
136.        Data2[i] := 0;
137.    end;
138.   end;
139.
140.  function TForm1.Rnorm (mean, sd: real): real;
141.  {Calculates Gaussian random numbers according to the Box-Müller approach}
142.   var
143.    u1, u2: real;
144.  begin
145.    u1 := random;
146.    u2 := random;
147.    rnorm := mean * abs(1 + sqrt(-2 * (ln(u1))) * cos(2 * pi * u2) * sd);
148.   end;
149.
150. end.
151.

I needed an Array of integers Sorted for use in a program I have been working on (Started before rain was invented) and I managed to get this working.

Line 14 Created the array as a type.
Line 42 Created the array.
Line 50 SetLength to 10.

Then I add number to the array and sort the array after every add and add the number to a listbox.

When the array is full I clear the Listbox and reload with the sorted numbers.

GRANTED the code isn't probably the best; however here is my question.

Why isn't there a place where very simple demo programs like this can be posted for someone to read/download.

The Demo is 150 lines long and almost anyone could read it a understand what it is  doing.

Maybe have someone review and accept, reject or recommend changes before posting.

Just a question.

JLWEST
Lazuras ver 2.0.2
FPC 3.0.4, Lazarus IDE v1.8.2 Windows 10 Pro
Intel i7 770K CPU 4.2GHz 32702MB Ram
GeForce GTX 1080 Graphics - 8 Gig
3952 GB (1.5 SSD)

#### Handoko

• Hero Member
• Posts: 3103
• My goal: build my own game engine using Lazarus
##### Re: Example Code Question
« Reply #1 on: April 22, 2019, 04:12:34 am »
I tested your code quickly, it seems to work.

- TListBox.Sorted
- Other containers that have sorting feature like TList, TFPList, TStringList, etc

About the sorting array example, it can be found here:
http://wiki.freepascal.org/Array_sort
« Last Edit: April 22, 2019, 04:16:06 am by Handoko »

#### lainz

• Hero Member
• Posts: 3179
##### Re: Example Code Question
« Reply #2 on: April 22, 2019, 04:14:31 am »
Quote
Why isn't there a place where very simple demo programs like this can be posted for someone to read/download.

Its called GitHub.

#### bytebites

• Full Member
• Posts: 190
##### Re: Example Code Question
« Reply #3 on: April 22, 2019, 05:02:37 am »
The array is sorted ten times in btnAddClick-procedure, maybe once is enough.

#### JLWest

• Hero Member
• Posts: 550
##### Re: Example Code Question
« Reply #4 on: April 22, 2019, 06:31:00 am »
@bytebits

Yes maybe your right but I was testing something.

In the program I'm writing I  need the ability to sort an array of integers (varies, but 10 to 20) integers.
It is constantly being cleared and filled.
With each sort the numbers are used.
When the array is full it is cleared and the process starts over again.

The sort will execute at least 10,000 (Maybe a lot more) times during the execution of the program.

It has to do with Haversine formula.

JLWEST
Lazuras ver 2.0.2
FPC 3.0.4, Lazarus IDE v1.8.2 Windows 10 Pro
Intel i7 770K CPU 4.2GHz 32702MB Ram
GeForce GTX 1080 Graphics - 8 Gig
3952 GB (1.5 SSD)

#### JLWest

• Hero Member
• Posts: 550
##### Re: Example Code Question
« Reply #5 on: April 22, 2019, 06:38:05 am »
@Handoko

Hi, Yea I saw the sort example and was going to make a demo out of it and then I found something written and posted on sorting.

I think it was by WP, or one of the brain trust guys. It was just a bit of code posted in an discussion on sorting, not a complete working function.

JLWEST
Lazuras ver 2.0.2
FPC 3.0.4, Lazarus IDE v1.8.2 Windows 10 Pro
Intel i7 770K CPU 4.2GHz 32702MB Ram
GeForce GTX 1080 Graphics - 8 Gig
3952 GB (1.5 SSD)

#### JLWest

• Hero Member
• Posts: 550
##### Re: Example Code Question
« Reply #6 on: April 22, 2019, 06:44:25 am »
Quote
Why isn't there a place where very simple demo programs like this can be posted for someone to read/download.

Its called GitHub.

I wan't aware of this feature of GitHub, Maybe I need to do a little exploring over there. However, every time I go there I can never fined anything, give up and leave. But I'll take a second look.

I just thought it would be nice if this org has stuff like this. I'm aware of the example programs that come with the compiler.  Tried a lot of them. They are in desperate need of an upgrade. A lot won't compile and there are many that are Programs and not GUI.

JLWEST
Lazuras ver 2.0.2
FPC 3.0.4, Lazarus IDE v1.8.2 Windows 10 Pro
Intel i7 770K CPU 4.2GHz 32702MB Ram
GeForce GTX 1080 Graphics - 8 Gig
3952 GB (1.5 SSD)

#### Thausand

• Full Member
• Posts: 227
##### Re: Example Code Question
« Reply #7 on: April 22, 2019, 07:21:18 am »
Manual, wiki, website tutor, video tutor.... then github... all many complicate ....

Then have other answer is have snippet https://github.com/taazz/CodeLibrarian ... make old-skool

#### JLWest

• Hero Member
• Posts: 550
##### Re: Example Code Question
« Reply #8 on: April 22, 2019, 08:04:06 am »
I went over to GetHub, created an account and found Tazz Code Libary. I don't know SQL or Database really.

How difficult is this to install and get running?
JLWEST
Lazuras ver 2.0.2
FPC 3.0.4, Lazarus IDE v1.8.2 Windows 10 Pro
Intel i7 770K CPU 4.2GHz 32702MB Ram
GeForce GTX 1080 Graphics - 8 Gig
3952 GB (1.5 SSD)

#### Thausand

• Full Member
• Posts: 227
##### Re: Example Code Question
« Reply #9 on: April 22, 2019, 08:18:04 am »
I went over to GetHub, created an account and found Tazz Code Libary. I don't know SQL or Database really.
3) no need SQL and no need database if no import.

Quote
How difficult is this to install and get running?
2) open source use lazarus (need packages, lazarus tell. Use OPM install package if not there)
3) build

or have release if you machine intel windows/linux

#### Thausand

• Full Member
• Posts: 227
##### Re: Example Code Question
« Reply #10 on: April 22, 2019, 08:41:40 am »
Ok. i have write i sorry.

I have old librarian sourceforge. I have no try github. Github source have error

Maybe if user taazz read: "source have broken use wrong patch".

Diff tool make many error for source

Quote
CopyAttributes(vNewFolder, InclPathDel(aSourceFolder) + vFolders[vCnt]);
=======
CopyAttributes(vNewFolder, vNewFolder);
>>>>>>> 747aae165a283c89228d908bb5cbe9c7cd942bda

I have find merge conflict and taazz not solve. https://github.com/taazz/CodeLibrarian/commit/c262f093353e452ea99f256b6f46f74804094f83

I sorry and know not how solve now
« Last Edit: April 22, 2019, 08:56:48 am by Thausand »

#### JLWest

• Hero Member
• Posts: 550
##### Re: Example Code Question
« Reply #11 on: April 22, 2019, 09:28:35 am »
thanks for the try.
JLWEST
Lazuras ver 2.0.2
FPC 3.0.4, Lazarus IDE v1.8.2 Windows 10 Pro
Intel i7 770K CPU 4.2GHz 32702MB Ram
GeForce GTX 1080 Graphics - 8 Gig
3952 GB (1.5 SSD)

• Hero Member
• Posts: 8508
##### Re: Example Code Question
« Reply #12 on: April 22, 2019, 10:13:37 am »
Basic sorts with explanation:
Code: Pascal  [Select]
1. {*********************************************************}
2. {* sorts.pas                                             *}
3. {* Copyright (c) Julian M Bucknall 1998                  *}
6. {*********************************************************}
7. {* Sort routines                                         *}
8. {*********************************************************}
9.
10. {Note: this unit is released as freeware. In other words, you are free
11.        to use this unit in your own applications, however I retain all
12.        copyright to the code. JMB}
13.
14. unit sorts;
15. {\$ifdef fpc}{\$mode delphi}{\$endif}
16. interface
17. type
18.   TSortElement = double;  // what you need to sort.
19.
20.   TLessFunction = function (const X, Y : TSortElement) : boolean;
21.     {function prototype to compare two items and return true if item X
22.      is STRICTLY LESS than item Y}
23.
24. procedure BubbleSort(var aItemArray    : array of TSortElement;
25.                          aLeft, aRight : integer;
26.                          aLessThan     : TLessFunction);
27.
28. procedure ShakerSort(var aItemArray    : array of TSortElement;
29.                          aLeft, aRight : integer;
30.                          aLessThan     : TLessFunction);
31.
32. procedure SelectionSort(var aItemArray    : array of TSortElement;
33.                             aLeft, aRight : integer;
34.                             aLessThan     : TLessFunction);
35.
36. procedure InsertionSort(var aItemArray    : array of TSortElement;
37.                             aLeft, aRight : integer;
38.                             aLessThan     : TLessFunction);
39.
40. procedure ShellSort(var aItemArray    : array of TSortElement;
41.                         aLeft, aRight : integer;
42.                         aLessThan     : TLessFunction);
43.
44. procedure QuickSort(var aItemArray    : array of TSortElement;
45.                         aLeft, aRight : integer;
46.                         aLessThan     : TLessFunction);
47.
48. procedure UsualInsertionSort(var aItemArray    : array of TSortElement;
49.                                  aLeft, aRight : integer;
50.                                  aLessThan     : TLessFunction);
51.
52. procedure UsualQuickSort(var aItemArray    : array of TSortElement;
53.                              aLeft, aRight : integer;
54.                              aLessThan     : TLessFunction);
55.
56. implementation
57.
58. procedure BubbleSort(var aItemArray    : array of TSortElement;
59.                          aLeft, aRight : integer;
60.                          aLessThan     : TLessFunction);
61. var
62.   i, j : integer;
63.   Temp : TSortElement;
64. begin
65.   for i := aLeft to pred(aRight) do
66.     for j := aRight downto succ(i) do
67.       if aLessThan(aItemArray[j], aItemArray[j-1]) then begin
68.         Temp := aItemArray[j];
69.         aItemArray[j] := aItemArray[j-1];
70.         aItemArray[j-1] := Temp;
71.       end;
72. end;
73.
74. procedure ShakerSort(var aItemArray    : array of TSortElement;
75.                          aLeft, aRight : integer;
76.                          aLessThan     : TLessFunction);
77. var
78.   i : integer;
79.   Temp : TSortElement;
80. begin
81.   while (aLeft < aRight) do begin
82.     for i := aRight downto succ(aLeft) do
83.       if aLessThan(aItemArray[i], aItemArray[i-1]) then begin
84.         Temp := aItemArray[i];
85.         aItemArray[i] := aItemArray[i-1];
86.         aItemArray[i-1] := Temp;
87.       end;
88.     inc(aLeft);
89.     for i := succ(aLeft) to aRight do
90.       if aLessThan(aItemArray[i], aItemArray[i-1]) then begin
91.         Temp := aItemArray[i];
92.         aItemArray[i] := aItemArray[i-1];
93.         aItemArray[i-1] := Temp;
94.       end;
95.     dec(aRight);
96.   end;
97. end;
98.
99. procedure SelectionSort(var aItemArray    : array of TSortElement;
100.                             aLeft, aRight : integer;
101.                             aLessThan     : TLessFunction);
102. var
103.   i, j : integer;
104.   IndexOfMin : integer;
105.   Temp : TSortElement;
106. begin
107.   for i := aLeft to pred(aRight) do begin
108.     IndexOfMin := i;
109.     for j := succ(i) to aRight do
110.       if aLessThan(aItemArray[j], aItemArray[IndexOfMin]) then
111.         IndexOfMin := j;
112.     Temp := aItemArray[i];
113.     aItemArray[i] := aItemArray[IndexOfMin];
114.     aItemArray[IndexOfMin] := Temp;
115.   end;
116. end;
117.
118. procedure UsualInsertionSort(var aItemArray    : array of TSortElement;
119.                                  aLeft, aRight : integer;
120.                                  aLessThan     : TLessFunction);
121. var
122.   i, j : integer;
123.   Temp : TSortElement;
124. begin
125.   for i := succ(aLeft) to aRight do begin
126.     Temp := aItemArray[i];
127.     j := i;
128.     while (j > aLeft) and aLessThan(Temp, aItemArray[j-1]) do begin
129.       aItemArray[j] := aItemArray[j-1];
130.       dec(j);
131.     end;
132.     aItemArray[j] := Temp;
133.   end;
134. end;
135.
136. procedure InsertionSort(var aItemArray    : array of TSortElement;
137.                             aLeft, aRight : integer;
138.                             aLessThan     : TLessFunction);
139. var
140.   i, j : integer;
141.   IndexOfMin : integer;
142.   Temp : TSortElement;
143. begin
144.   {find the smallest element and put it in the first position}
145.   IndexOfMin := aLeft;
146.   for i := succ(aLeft) to aRight do
147.     if aLessThan(aItemArray[i], aItemArray[IndexOfMin]) then
148.       IndexOfMin := i;
149.   if (aLeft <> IndexOfMin) then begin
150.     Temp := aItemArray[aLeft];
151.     aItemArray[aLeft] := aItemArray[IndexOfMin];
152.     aItemArray[IndexOfMin] := Temp;
153.   end;
154.   {now sort via insertion method}
155.   for i := aLeft+2 to aRight do begin
156.     Temp := aItemArray[i];
157.     j := i;
158.     while aLessThan(Temp, aItemArray[j-1]) do begin
159.       aItemArray[j] := aItemArray[j-1];
160.       dec(j);
161.     end;
162.     aItemArray[j] := Temp;
163.   end;
164. end;
165.
166. procedure ShellSort(var aItemArray    : array of TSortElement;
167.                         aLeft, aRight : integer;
168.                         aLessThan     : TLessFunction);
169. var
170.   i, j : integer;
171.   h    : integer;
172.   Temp : TSortElement;
173. begin
174.   {firstly calculate the first h value we shall use: it'll be about
175.    one ninth of the number of the elements}
176.   h := 1;
177.   while (h <= (aRight - aLeft) div 9) do
178.     h := (h * 3) + 1;
179.   {start a loop that'll decrement h by one third each time through}
180.   while (h > 0) do begin
181.     {now insertion sort each h-subfile}
182.     for i := (aLeft + h) to aRight do begin
183.       Temp := aItemArray[i];
184.       j := i;
185.       while (j >= (aLeft+h)) and aLessThan(Temp, aItemArray[j-h]) do begin
186.         aItemArray[j] := aItemArray[j-h];
187.         dec(j, h);
188.       end;
189.       aItemArray[j] := Temp;
190.     end;
191.     {decrease h by a third}
192.     h := h div 3;
193.   end;
194. end;
195.
196. procedure UsualQuickSort(var aItemArray    : array of TSortElement;
197.                              aLeft, aRight : integer;
198.                              aLessThan     : TLessFunction);
199.   function Partition(L, R : integer): integer;
200.   var
201.     i, j : integer;
202.     Last : TSortElement;
203.     Temp : TSortElement;
204.   begin
205.     {set up the indexes}
206.     i := L;
207.     j := pred(R);
208.     {get the partition element}
209.     Last := aItemArray[R];
210.     {do forever (we'll break out of the loop when needed)}
211.     while true do begin
212.       {find the first element greater than or equal to the partition
213.        element from the left; note that our partition element will
214.        stop this loop}
215.       while aLessThan(aItemArray[i], Last) do
216.         inc(i);
217.       {find the first element less than the partition element from the
218.        right; check to break out of the loop if we hit the left
219.        element - we have no sentinel there}
220.       while aLessThan(Last, aItemArray[j]) do begin
221.         if (j = L) then
222.           Break;
223.         dec(j);
224.       end;
225.       {if we crossed get out of this infinite loop to swap the
226.        partition element into place}
227.       if (i >= j) then
228.         Break;
229.       {otherwise swap the two out-of-place elements}
230.       Temp := aItemArray[i];
231.       aItemArray[i] := aItemArray[j];
232.       aItemArray[j] := Temp;
233.       {and continue}
234.       inc(i);
235.       dec(j);
236.     end;
237.     {swap the partition element into place, return the dividing index}
238.     aItemArray[R] := aItemArray[i];
239.     aItemArray[i] := Last;
240.     Result := i;
241.   end;
242.   procedure QuickSortPrim(L, R : integer);
243.   var
244.     DividingItem : integer;
245.   begin
246.     {stop the recursion, if needed}
247.     if (R - L) <= 0 then
248.       Exit;
249.     {otherwise, partition about the final element in the set}
250.     DividingItem := Partition(L, R);
251.     {recursively quicksort the two subsets either side of the dividing
252.      element}
253.     QuicksortPrim(L, pred(DividingItem));
254.     QuicksortPrim(succ(DividingItem), R);
255.   end;
256. begin
257.   {start it all off}
258.   QuicksortPrim(aLeft, aRight);
259. end;
260.
261. procedure QuickSort(var aItemArray    : array of TSortElement;
262.                         aLeft, aRight : integer;
263.                         aLessThan     : TLessFunction);
264.   function Partition(L, R : integer): integer;
265.   var
266.     i, j : integer;
267.     Last : TSortElement;
268.     Temp : TSortElement;
269.   begin
270.     {set up the indexes}
271.     i := L;
272.     j := pred(R);
273.     {get the partition element}
274.     Last := aItemArray[R];
275.     {do forever (we'll break out of the loop when needed)}
276.     while true do begin
277.       {find the first element greater than or equal to the partition
278.        element from the left; note that our partition element will
279.        stop this loop}
280.       while aLessThan(aItemArray[i], Last) do
281.         inc(i);
282.       {find the first element less than the partition element from the
283.        right; note the median-of-three algorithm has ensured we have
284.        a sentinel on the left}
285.       while not aLessThan(aItemArray[j], Last) do
286.         dec(j);
287.       {if we crossed get out of this infinite loop to swap the
288.        partition element into place}
289.       if (i >= j) then
290.         Break;
291.       {otherwise swap the two out-of-place elements}
292.       Temp := aItemArray[i];
293.       aItemArray[i] := aItemArray[j];
294.       aItemArray[j] := Temp;
295.       {and continue}
296.       inc(i);
297.       dec(j);
298.     end;
299.     {swap the partition element into place, return the dividing index}
300.     aItemArray[R] := aItemArray[i];
301.     aItemArray[i] := Last;
302.     Result := i;
303.   end;
304.   procedure QuickSortPrim(L, R : integer);
305.   var
306.     DividingItem : integer;
307.     Temp : TSortElement;
308.     i, j : integer;
309.   begin
310.     {if needed, stop the recursion at the cut-off point, and insertion
311.      sort}
312.     if (R - L) <= 10 then begin
313.       for i := succ(L) to R do begin
314.         Temp := aItemArray[i];
315.         j := i;
316.         while (j > L) and aLessThan(Temp, aItemArray[j-1]) do begin
317.           aItemArray[j] := aItemArray[j-1];
318.           dec(j);
319.         end;
320.         aItemArray[j] := Temp;
321.       end;
322.       Exit;
323.     end;
324.     {calculate the median-of-three element; for an extra bit of speed,
325.      put the smallest element of the three in the first position, the
326.      greatest in the last position, and the median in the last-but-one
327.      position and partition a smaller subset excluding the first and
328.      last}
329.     Temp := aItemArray[(L+R) shr 1];
330.     aItemArray[(L+R) shr 1] := aItemArray[pred(R)];
331.     aItemArray[pred(R)] := Temp;
332.     if not aLessThan(aItemArray[L], aItemArray[pred(R)]) then begin
333.       Temp := aItemArray[L];
334.       aItemArray[L] := aItemArray[pred(R)];
335.       aItemArray[pred(R)] := Temp;
336.     end;
337.     if not aLessThan(aItemArray[L], aItemArray[R]) then begin
338.       Temp := aItemArray[L];
339.       aItemArray[L] := aItemArray[R];
340.       aItemArray[R] := Temp;
341.     end;
342.     if not aLessThan(aItemArray[pred(R)], aItemArray[R]) then begin
343.       Temp := aItemArray[R];
344.       aItemArray[R] := aItemArray[pred(R)];
345.       aItemArray[pred(R)] := Temp;
346.     end;
347.     DividingItem := Partition(succ(L), pred(R));
348.     {recursively quicksort the two subsets either side of the dividing
349.      element}
350.     QuickSortPrim(L, pred(DividingItem));
351.     QuickSortPrim(succ(DividingItem), R);
352.   end;
353. begin
354.   {start it all off}
355.   QuickSortPrim(aLeft, aRight);
356. end;
357.
358. end.
I actually ported it back to not use KOL features right now.
Modern language features can be introduced to improve this, but this is a solid introduction to sorts.
And Julian gave me permission to use it a long time ago.
Well written code by computer scientists hardly age........
(His book Algorithms and Data structures is still available: e.g. https://www.amazon.com/Tomes-Delphi-Algorithms-Data-Structures-ebook/dp/B007FKB0EI  best book ever on the subject)
« Last Edit: April 22, 2019, 10:36:06 am by Thaddy »
Read the manuals and if you are a professional get a proper education in computer science. Makes the forum a lot cleaner.

• Hero Member
• Posts: 8508
##### Re: Example Code Question
« Reply #13 on: April 22, 2019, 10:36:19 am »

Another one with still valid code is by Petr Vones:
Code: Pascal  [Select]
1. {**************************************************************************************************}
2. {                                                                                                  }
3. { Dynamic array sorting routines                                                                   }
4. {                                                                                                  }
5. { The contents of this file are subject to the Mozilla Public License Version 1.1 (the "License"); }
6. { you may not use this file except in compliance with the License. You may obtain a copy of the    }
7. { License at http://www.mozilla.org/MPL/                                                           }
8. {                                                                                                  }
9. { Software distributed under the License is distributed on an "AS IS" basis, WITHOUT WARRANTY OF   }
10. { ANY KIND, either express or implied. See the License for the specific language governing rights  }
11. { and limitations under the License.                                                               }
12. {                                                                                                  }
13. { The Original Code is DynArraySort.pas.                                                           }
14. {                                                                                                  }
15. { The Initial Developer of the Original Code is Petr Vones (petr_v@post.cz)                        }
16. {                                                                                                  }
18. { Adapted for KOL: August 22, 2004, Thaddy de Koning                                                                                                 }
19. {**************************************************************************************************}
20.
21. unit KolDynArraySort;
22.
23. interface
24.
25. //--------------------------------------------------------------------------------------------------
26. // Dynamic array sort and search routines
27. //--------------------------------------------------------------------------------------------------
28.
29. type
30.   TDynArraySortFunction = function (Item1, Item2: Pointer): Integer;
31.
32. procedure SortDynamicArray(const ArrayPtr: Pointer; ElementSize: Cardinal; SortFunc: TDynArraySortFunction);
33. // Usage: SortDynamicArray(Array, SizeOf(Array[0]), SortFunction);
34. function SearchDynamicArray(const ArrayPtr: Pointer; ElementSize: Cardinal; SortFunc: TDynArraySortFunction;
35.   ValuePtr: Pointer): Integer;
36. // Usage: SearchDynamicArray(Array, SizeOf(Array[0]), SortFunction, @SearchedValue);
37.
38. //--------------------------------------------------------------------------------------------------
39. // Various sort functions for basic types
40. //--------------------------------------------------------------------------------------------------
41.
42. function DynArraySortShortInt(Item1, Item2: Pointer): Integer;
43. function DynArraySortSmallInt(Item1, Item2: Pointer): Integer;
44. function DynArraySortInteger(Item1, Item2: Pointer): Integer;
45. function DynArraySortInt64(Item1, Item2: Pointer): Integer;
46.
47. function DynArraySortSingle(Item1, Item2: Pointer): Integer;
48. function DynArraySortDouble(Item1, Item2: Pointer): Integer;
49. function DynArraySortExtended(Item1, Item2: Pointer): Integer;
50.
51. function DynArraySortAnsiString(Item1, Item2: Pointer): Integer;
52. function DynArraySortAnsiText(Item1, Item2: Pointer): Integer;
53. function DynArraySortString(Item1, Item2: Pointer): Integer;
54. function DynArraySortText(Item1, Item2: Pointer): Integer;
55.
56.
57.
58. implementation
59.
60. uses
61.   Windows, Kol;
62.
63. //--------------------------------------------------------------------------------------------------
64.
65. function DynArraySortShortInt(Item1, Item2: Pointer): Integer;
66. begin
67.   Result := PShortInt(Item1)^ - PShortInt(Item2)^;
68. end;
69.
70. //--------------------------------------------------------------------------------------------------
71.
72. function DynArraySortSmallInt(Item1, Item2: Pointer): Integer;
73. begin
74.   Result := PSmallInt(Item1)^ - PSmallInt(Item2)^;
75. end;
76.
77. //--------------------------------------------------------------------------------------------------
78.
79. function DynArraySortInteger(Item1, Item2: Pointer): Integer;
80. begin
81.   Result := PInteger(Item1)^ - PInteger(Item2)^;
82. end;
83.
84. //--------------------------------------------------------------------------------------------------
85.
86. function DynArraySortInt64(Item1, Item2: Pointer): Integer;
87. begin
88.   Result := PInt64(Item1)^ - PInt64(Item2)^;
89. end;
90.
91. //--------------------------------------------------------------------------------------------------
92.
93. function DynArraySortSingle(Item1, Item2: Pointer): Integer;
94. begin
95.   if PSingle(Item1)^ < PSingle(Item2)^ then
96.     Result := -1
97.   else
98.   if PSingle(Item1)^ > PSingle(Item2)^ then
99.     Result := 1
100.   else
101.     Result := 0;
102. end;
103.
104. //--------------------------------------------------------------------------------------------------
105.
106. function DynArraySortDouble(Item1, Item2: Pointer): Integer;
107. begin
108.   if PDouble(Item1)^ < PDouble(Item2)^ then
109.     Result := -1
110.   else
111.   if PDouble(Item1)^ > PDouble(Item2)^ then
112.     Result := 1
113.   else
114.     Result := 0;
115. end;
116.
117. //--------------------------------------------------------------------------------------------------
118.
119. function DynArraySortExtended(Item1, Item2: Pointer): Integer;
120. begin
121.   if PExtended(Item1)^ < PExtended(Item2)^ then
122.     Result := -1
123.   else
124.   if PExtended(Item1)^ > PExtended(Item2)^ then
125.     Result := 1
126.   else
127.     Result := 0;
128. end;
129.
130. //--------------------------------------------------------------------------------------------------
131.
132. function DynArraySortAnsiString(Item1, Item2: Pointer): Integer;
133. begin
134.   Result := AnsiCompareStr(PAnsiString(Item1)^, PAnsiString(Item2)^);
135. end;
136.
137. //--------------------------------------------------------------------------------------------------
138.
139. function DynArraySortAnsiText(Item1, Item2: Pointer): Integer;
140. begin
141.   Result := AnsiCompareText(PAnsiString(Item1)^, PAnsiString(Item2)^);
142. end;
143.
144. //--------------------------------------------------------------------------------------------------
145.
146. function DynArraySortString(Item1, Item2: Pointer): Integer;
147. begin
148.   Result := AnsiCompareStr(PAnsiString(Item1)^, PAnsiString(Item2)^);
149. end;
150.
151. //--------------------------------------------------------------------------------------------------
152.
153. function DynArraySortText(Item1, Item2: Pointer): Integer;
154. begin
155.   Result := AnsiCompareText(PAnsiString(Item1)^, PAnsiString(Item2)^);
156. end;
157.
158. //--------------------------------------------------------------------------------------------------
159.
160. procedure SortDynamicArray(const ArrayPtr: Pointer; ElementSize: Cardinal; SortFunc: TDynArraySortFunction);
161. var
162.   TempBuf: Pointer;
163.
164.   function ArrayItemPointer(Item: Integer): Pointer;
165.   begin
166.     Result := Pointer(Cardinal(ArrayPtr) + (Cardinal(Item) * ElementSize));
167.   end;
168.
169.   procedure QuickSort(L, R: Integer);
170.   var
171.     I, J, T: Integer;
172.     P, IPtr, JPtr: Pointer;
173.   begin
174.     repeat
175.       I := L;
176.       J := R;
177.       P := ArrayItemPointer((L + R) shr 1);
178.       repeat
179.         while SortFunc(ArrayItemPointer(I), P) < 0 do
180.           Inc(I);
181.         while SortFunc(ArrayItemPointer(J), P) > 0 do
182.           Dec(J);
183.         if I <= J then
184.         begin
185.           IPtr := ArrayItemPointer(I);
186.           JPtr := ArrayItemPointer(J);
187.           case ElementSize of
188.             SizeOf(Byte):
189.               begin
190.                 T := PByte(IPtr)^;
191.                 PByte(IPtr)^ := PByte(JPtr)^;
192.                 PByte(JPtr)^ := T;
193.               end;
194.             SizeOf(Word):
195.               begin
196.                 T := PWord(IPtr)^;
197.                 PWord(IPtr)^ := PWord(JPtr)^;
198.                 PWord(JPtr)^ := T;
199.               end;
200.             SizeOf(Integer):
201.               begin
202.                 T := PInteger(IPtr)^;
203.                 PInteger(IPtr)^ := PInteger(JPtr)^;
204.                 PInteger(JPtr)^ := T;
205.               end;
206.           else
207.             Move(IPtr^, TempBuf^, ElementSize);
208.             Move(JPtr^, IPtr^, ElementSize);
209.             Move(TempBuf^, JPtr^, ElementSize);
210.           end;
211.           if P = IPtr then
212.             P := JPtr
213.           else
214.           if P = JPtr then
215.             P := IPtr;
216.           Inc(I);
217.           Dec(J);
218.         end;
219.       until I > J;
220.       if L < J then
221.         QuickSort(L, J);
222.       L := I;
223.     until I >= R;
224.   end;
225.
226. begin
227.   if ArrayPtr <> nil then
228.   begin
229.     GetMem(TempBuf, ElementSize);
230.     try
231.       QuickSort(0, PInteger(Cardinal(ArrayPtr) - 4)^ - 1);
232.     finally
233.       FreeMem(TempBuf);
234.     end;
235.   end;
236. end;
237.
238. //--------------------------------------------------------------------------------------------------
239.
240. function SearchDynamicArray(const ArrayPtr: Pointer; ElementSize: Cardinal; SortFunc: TDynArraySortFunction;
241.   ValuePtr: Pointer): Integer;
242. var
243.   L, H, I, C: Integer;
244.   B: Boolean;
245. begin
246.   Result := -1;
247.   if ArrayPtr <> nil then
248.   begin
249.     L := 0;
250.     H := PInteger(Cardinal(ArrayPtr) - 4)^ - 1;
251.     B := False;
252.     while L <= H do
253.     begin
254.       I := (L + H) shr 1;
255.       C := SortFunc(Pointer(Cardinal(ArrayPtr) + (Cardinal(I) * ElementSize)), ValuePtr);
256.       if C < 0 then
257.         L := I + 1
258.       else
259.       begin
260.         H := I - 1;
261.         if C = 0 then
262.         begin
263.           B := True;
264.           L := I;
265.         end;
266.       end;
267.     end;
268.     if B then
269.       Result := L;
270.   end;
271. end;
272.
273. //--------------------------------------------------------------------------------------------------
274. end.
That's a candidate for generics....
Read the manuals and if you are a professional get a proper education in computer science. Makes the forum a lot cleaner.

#### Thausand

• Full Member
• Posts: 227
##### Re: Example Code Question
« Reply #14 on: April 22, 2019, 11:25:32 am »
thanks for the try.
i have make work. write here https://forum.lazarus.freepascal.org/index.php/topic,22752.0.html

Make work easy. Make picture attach work < 250kb have work small hour and not can make