Quicksort Demonstration 1a (Smart Pascal)

Introduction

This demonstration places a PaintBox inside a ScrollBox on a form in Smart Mobile Studio. We have changed some of the colours so that the display is easier to read. If the demonstration does not work in your current browser, try another such as Chrome.

Output

QuicksortWebDemo1a.html

Smart Pascal Code

unit Form1;

interface

uses 
  SmartCL.System, SmartCL.Graphics, SmartCL.Components, SmartCL.Forms, 
  SmartCL.Fonts, SmartCL.Borders, SmartCL.Application, SmartCL.Controls.ScrollBox,
   SmartCL.Controls.PaintBox, System.Colors;
type
  TConsoleColour = (black, blue, green, cyan, red, magenta, brown, lightgray,
                    darkgray, lightblue, lightgreen, lightcyan, lightred, lightmagenta, yellow, white);

  TCharacter = record
    Letter: string = ' ';
    TextColour: TConsoleColour = white;
    TextBackgroundColour = black;
  end;

  TCharacters = array[1..80, 1..100] of TCharacter;

  TConsoleGrid = class
  private
    FTextColour: TConsoleColour = black;
    FBackgroundColour: TConsoleColour = white;
    FCursorX: integer = 1;
    FCursorY: integer = 1;
    FRows: integer = 100;
    FCols: integer = 80;
    FCharacters: TCharacters;
  public
    procedure setCharacters(Char: TCharacters);
    function getCharacters: TCharacters;
    procedure SetCursorX(newX: integer);
    procedure SetCursorY(newY: integer);
    procedure SetXY(newRec: TCharacter; X, Y: integer);
    function GetXY(X, Y: integer): TCharacter;
    procedure write(txt: string);
    procedure ClearEOL(startX, clearY: integer);
    procedure ClearCell(clearX, clearY: integer);
    procedure ClearGrid;
    property TextColour: TConsoleColour read FTextColour write FTextColour;
    property BackgroundColour: TConsoleColour read FBackgroundColour write FBackgroundColour;
    property CursorX: integer read FCursorX write SetCursorX;
    property CursorY: integer read FCursorY write SetCursorY;
    property Cols: integer read FCols write FCols;
    property Rows: integer read FRows write FRows;
  end;

  TForm1 = class(TW3Form)
  private
    {$I 'Form1:intf'}
    const UPPER_BOUND = 10;
    const FIELD_WIDTH = 3;
    const SCALE_FACTOR = 2;
    const CELL_WIDTH = 5 * SCALE_FACTOR;
    const CELL_HEIGHT = 8 * SCALE_FACTOR;
    const FONT_SIZE = 9 * SCALE_FACTOR;
    const ROWS = 100;
    const COLS = 80;
    const WIDTH = COLS * CELL_WIDTH;
    const HEIGHT = ROWS * CELL_HEIGHT;
    Grid: TConsoleGrid;
    pb :TW3PaintBox;
    Ints : array[1..10] of integer = [10, 7, 3, 5, 8, 2, 6, 9, 1, 4];
  protected
    procedure InitializeForm; override;
    procedure InitializeObject; override;
    procedure Resize; override;
    procedure Quicksort(Left, Right: integer);
    procedure GoToXY(X, Y: integer);
    procedure ClrScr;
    procedure ClrEOL;
    procedure textColor(colour: TConsoleColour);
    procedure textBackground(colour: TConsoleColour);
    procedure write(txt: string);
    procedure writeln(txt : string); overload;
    procedure writeln;         overload;
    procedure PaintGrid(Canvas: TW3Canvas);
  end;

procedure SetTextColor(colour: TConsoleColour; Canvas : TW3Canvas);

implementation

procedure TForm1.GoToXY(X, Y: integer);
begin
  Grid.CursorX := X;
  Grid.CursorY := Y;
end;

procedure TForm1.ClrScr;
begin
  Grid.ClearGrid;
  GoToXY(1, 1);
end;

procedure TForm1.ClrEOL;
begin
  grid.ClearEol(Grid.CursorX, Grid.CursorY);
end;

procedure TForm1.textColor(colour: TConsoleColour);
begin
  Grid.TextColour := colour;
end;

procedure TForm1.textBackground(colour: TConsoleColour);
begin
  Grid.BackgroundColour := colour;
end;

procedure TForm1.write(txt: string);
begin
  Grid.write(txt);
end;

procedure TForm1.writeln(txt : string);
begin
  Grid.write(txt);
  Grid.CursorX := 1;
  Grid.CursorY := Grid.CursorY + 1;
end;

procedure TForm1.writeln;
begin
  Grid.CursorX := 1;
  Grid.CursorY := Grid.CursorY + 1;
end;

procedure TForm1.Quicksort(Left, Right: integer);
var
  ptrLeft, ptrRight, Pivot, Temp: integer;

procedure DisplayArray;
begin
  for var Count := 1 to UPPER_BOUND do
    begin
      if (Count >= Left) and (Count <= Right) then
        textBackground(brown)
      else
        textBackground(black);
      if Count = ptrLeft  then
        textColor(lightgreen)
      else if Count = ptrRight then
        textColor(red)
      else
        textColor(white);
      if Ints[Count] =  Pivot then
        textBackground(darkgray);
      var str := inttostr(ints[Count]);
      var l := length(str);
      for var i := 1 to FIELD_WIDTH - l do
        str := ' ' + str;
      write(str);
    end;
    textColor(white);
    textBackground(black);
    if PtrLeft = PtrRight then
      writeln('  Pointers coincide')
    else
      writeln;
end;

begin
  ptrLeft := Left;
  ptrRight := Right;
  Pivot := Ints[(Left + Right) div 2];
  textColor(white);
  textbackground(black);
  writeln('Quicksort for index ' + inttostr(Left) +  ' to ' + inttostr(Right) +
          ' with pivot ' + inttostr(Pivot) + ':');
  DisplayArray;
  repeat
    {Increment left pointer while  it has not reached upper
     index of array segment and value remains less than pivot.}
    while (ptrLeft < Right) and (Ints[ptrLeft] < Pivot) do
      begin
        writeln('Left pointer moves right:');
        inc(ptrLeft);
        DisplayArray;
      end;
    {Decrement left pointer while it has not reached lower
     index of array segment and value remains greater than pivot.}
    while (ptrRight > Left) and (Ints[ptrRight] > Pivot) do
      begin
        writeln('Right pointer moves left:');
        dec(ptrRight);
        DisplayArray;
      end;
    if ptrLeft <= ptrRight then  //if left pointer and right pointer have not crossed
      begin
        //Swap values at left and right pointers if pointers are not equal
        if ptrLeft < ptrRight then
          begin
            writeln('Swapping '+ inttostr(Ints[ptrLeft])+ ' with '+ inttostr(Ints[ptrRight]));
            Temp := Ints[ptrLeft];
            Ints[ptrLeft] := Ints[ptrRight];
            Ints[ptrRight] := Temp;
            DisplayArray;
          end;
        writeln('Both pointers move one place:');
        //Left pointer moves right and right pointer moves left.
        inc(ptrLeft);
        dec(ptrRight);
        DisplayArray;
     end;
  until ptrLeft > ptrRight;  //Until pointers have crossed
  write('Pointers have crossed. ');
  //Sort the left partition if necessary.
  if ptrRight > Left then
    Quicksort(Left, ptrRight);
  //Sort the right partition if necessary.
  if ptrLeft < Right then
    Quicksort(ptrLeft, Right);
end;

procedure TForm1.PaintGrid(Canvas: TW3Canvas);
begin
  pb.Canvas.Font := IntToStr(FONT_SIZE) + 'px Lucida Console';
  var currentChar: TCharacter;
  for var x := 1 to COLS do
    for var y := 1 to ROWS do
      begin
        currentChar := Grid.getCharacters[x, y];
        SetTextColor(currentChar.TextBackGroundColour, Canvas);
        Canvas.FillRect((x - 1) * CELL_WIDTH, ((y - 1) * CELL_HEIGHT) + 2, CELL_WIDTH, CELL_HEIGHT);
        SetTextColor(currentChar.TextColour, Canvas);
        Canvas.FillText(currentChar.Letter, (x - 1) * CELL_WIDTH, y * CELL_HEIGHT);
      end;
end;

procedure TForm1.InitializeForm;
begin
  inherited;
  Grid := new TConsoleGrid;
  Grid.Rows := ROWS;
  Grid.Cols := COLS;
  pb := TW3PaintBox.Create(W3ScrollBox1.Content);
  pb.SetBounds(1, 1, COLS * CELL_WIDTH, 3000);
  pb.Width:= WIDTH;
  pb.Height := HEIGHT;
  Quicksort(1, UPPER_BOUND);
  textcolor(red);
  textbackground(yellow);
  writeln;
  writeln;
  writeln('Sorted!');
  pb.OnPaint :=
    procedure (Sender: TObject; Canvas: TW3Canvas)
    begin
      PaintGrid(Canvas);
    end;
end;

procedure TForm1.InitializeObject;
begin
  inherited;
  {$I 'Form1:impl'}
end;
 
procedure TForm1.Resize;
begin
  inherited;
end;

procedure SetTextColor(colour: TConsoleColour; Canvas: TW3Canvas);
begin
  case colour of
    black: Canvas.FillStyle := 'black';
    white: Canvas.FillStyle := 'white';
    brown: Canvas.FillStyle := ColorToWebStr(clBrown);
    red: Canvas.FillStyle := 'red';
    magenta: Canvas.FillStyle := ColorToWebStr(clMagenta);
    yellow: Canvas.FillStyle := 'yellow';
    green: Canvas.FillStyle := 'green';
    cyan: Canvas.FillStyle := ColorToWebStr(clCyan);
    blue: Canvas.FillStyle := 'blue';
    lightgray: Canvas.FillStyle := ColorToWebStr(clLightGray);
    darkgray: Canvas.FillStyle := ColorToWebStr(clDarkGray);
    lightred: Canvas.FillStyle := 'rgb(250, 130, 130)';
    lightmagenta: Canvas.FillStyle := 'rgb(250, 130, 250)';
    lightgreen: Canvas.FillStyle := ColorToWebStr(clLightGreen);
    lightcyan: Canvas.FillStyle := ColorToWebStr(clLightCyan);
    lightblue: Canvas.FillStyle := 'rgb(130, 130, 250)';
  end;
end;

procedure TConsoleGrid.setCharacters(Char: TCharacters);
begin
  FCharacters := Char;
end;

function TConsoleGrid.getCharacters: TCharacters;
begin
  Result := FCharacters;
end;

procedure TConsoleGrid.SetCursorX(newX: integer);
begin
  if (newX > 0) and (newX <= Cols) then
    FCursorX := newX;
end;

procedure TConsoleGrid.SetCursorY(newY: integer);
begin
  if (newY > 0) and (newY <= Rows) then
    FCursorY := newY;
end;

procedure TConsoleGrid.SetXY(newRec: TCharacter; X, Y: integer);
begin
  if (X > 0) and (X <= Cols) and (Y > 0) and (Y <= Rows) then
    FCharacters[X, Y] := newRec;
end;

function TConsoleGrid.GetXY(X, Y: integer): TCharacter;
begin
  Result := getCharacters[X, Y];
end;

procedure TConsoleGrid.write(txt: string);
var
  tempchar: TCharacter;
begin
  for var i := 1 to length(txt) do
    begin
      tempChar.TextColour := TextColour;
      tempChar.TextBackgroundColour := BackgroundColour;
      tempChar.Letter := txt[i];
      SetXY(tempChar, CursorX, CursorY);
      if CursorX < (Cols - 1) then
        CursorX := CursorX + 1
      else
        begin
          CursorX := 1;
          CursorY := CursorY + 1;  //Scrolling not implemented yet
        end;
    end;
end;

procedure TConsoleGrid.ClearCell(clearX, clearY: integer);
var
  tempChar: TCharacter;
begin
  tempChar.TextBackgroundColour := BackGroundColour;
  tempChar.Letter := ' ';
  tempChar.TextColour := black; //Not needed
  SetXY(tempChar, clearX, clearY);
end;

procedure TConsoleGrid.ClearEOL(startX, clearY: integer);
begin
  for var x := startX to Cols do
    ClearCell(x, clearY);
end;

procedure TConsoleGrid.ClearGrid;
begin
  for var y := 1 to Rows do
    ClearEOL(1, y);
end;
 
initialization
  Forms.RegisterForm({$I %FILE%}, TForm1);
end.
Programming - a skill for life!

Discussion of quicksort