Recent

Author Topic: Example Code Question  (Read 3828 times)

JLWest

  • Hero Member
  • *****
  • Posts: 1293
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;
  19.     btnAdd: TBitBtn;
  20.     btnClose: TButton;
  21.     ListBox1: TListBox;
  22.  
  23.  
  24.   procedure btnFromArrayClick(Sender: TObject);
  25.   procedure btnAddClick(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.  
  55.  procedure TForm1.btnAddClick(Sender: TObject);
  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);
  65.      Listbox1.Items.Add(Bit1);
  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);
  83.      Listbox1.Items.Add(Bit1);
  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
  95.         SwapMade := False;
  96.         Done := True;
  97.       for i := Low(Data2) to High(Data2) -1 do begin
  98.          if Data2[i]  > Data2[i + 1] then begin
  99.             SwapMade := True;
  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.

FPC 3.2.0, Lazarus IDE v2.0.4
 Windows 10 Pro 32-GB
 Intel i7 770K CPU 4.2GHz 32702MB Ram
GeForce GTX 1080 Graphics - 8 Gig
4.1 TB

Handoko

  • Hero Member
  • *****
  • Posts: 5131
  • 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.

But I think you should use ready-made features, like
- 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: 4460
    • https://lainz.github.io/
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

  • Hero Member
  • *****
  • Posts: 632
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: 1293
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.


FPC 3.2.0, Lazarus IDE v2.0.4
 Windows 10 Pro 32-GB
 Intel i7 770K CPU 4.2GHz 32702MB Ram
GeForce GTX 1080 Graphics - 8 Gig
4.1 TB

JLWest

  • Hero Member
  • *****
  • Posts: 1293
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.

FPC 3.2.0, Lazarus IDE v2.0.4
 Windows 10 Pro 32-GB
 Intel i7 770K CPU 4.2GHz 32702MB Ram
GeForce GTX 1080 Graphics - 8 Gig
4.1 TB

JLWest

  • Hero Member
  • *****
  • Posts: 1293
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.

FPC 3.2.0, Lazarus IDE v2.0.4
 Windows 10 Pro 32-GB
 Intel i7 770K CPU 4.2GHz 32702MB Ram
GeForce GTX 1080 Graphics - 8 Gig
4.1 TB

Thausand

  • Sr. Member
  • ****
  • Posts: 292
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  :D


JLWest

  • Hero Member
  • *****
  • Posts: 1293
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?
FPC 3.2.0, Lazarus IDE v2.0.4
 Windows 10 Pro 32-GB
 Intel i7 770K CPU 4.2GHz 32702MB Ram
GeForce GTX 1080 Graphics - 8 Gig
4.1 TB

Thausand

  • Sr. Member
  • ****
  • Posts: 292
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.
1) not have requirement account. github free download. https://github.com/taazz/CodeLibrarian/archive/master.zip
2) if windows or linux intel then have release download https://github.com/taazz/CodeLibrarian/releases
3) no need SQL and no need database if no import.

Quote
How difficult is this to install and get running?
1) download source
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

  • Sr. Member
  • ****
  • Posts: 292
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  :'(

many can read
Quote
<<<<<<< HEAD
        CopyAttributes(vNewFolder, InclPathDel(aSourceFolder) + vFolders[vCnt]);
=======
        CopyAttributes(vNewFolder, vNewFolder);
>>>>>>> 747aae165a283c89228d908bb5cbe9c7cd942bda


add:

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: 1293
Re: Example Code Question
« Reply #11 on: April 22, 2019, 09:28:35 am »
thanks for the try.
FPC 3.2.0, Lazarus IDE v2.0.4
 Windows 10 Pro 32-GB
 Intel i7 770K CPU 4.2GHz 32702MB Ram
GeForce GTX 1080 Graphics - 8 Gig
4.1 TB

Thaddy

  • Hero Member
  • *****
  • Posts: 14201
  • Probably until I exterminate Putin.
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                  *}
  4. {* KOL Portions ©2001-2005, Thaddy de Koning             *}
  5. {* All rights reserved.                                  *}
  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.  8-)
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 »
Specialize a type, not a var.

Thaddy

  • Hero Member
  • *****
  • Posts: 14201
  • Probably until I exterminate Putin.
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. {                                                                                                  }
  17. { Last modified: March 09, 2002                                                                    }
  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....
Specialize a type, not a var.

Thausand

  • Sr. Member
  • ****
  • Posts: 292
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  %)

 

TinyPortal © 2005-2018