Library:  Winapi.Windows
Library:  System.SysUtils
Library:  System.Classes
Library:  Vcl.Graphics
Library:  Vcl.Forms
Library:  Vcl.ExtCtrls
Translation of: C#

unit main;

interface

uses
  Winapi.Windows, System.SysUtils, System.Classes, Vcl.Graphics, Vcl.Forms,
  Vcl.ExtCtrls;

type
  TClock = class(TForm)
    tmrTimer: TTimer;
    procedure FormResize(Sender: TObject);
    procedure tmrTimerTimer(Sender: TObject);
  private
    { Private declarations }
    const
      degrees06 = PI / 30;
      degrees30 = degrees06 * 5;
      degrees90 = degrees30 * 3;
      margin = 20;
    var
      p0: TPoint;
      MinP0XY: Integer;
    class function IfThen(Condition: Boolean; TrueValue, FalseValue: Integer):
      Integer; overload; static;
    class function IfThen(Condition: Boolean; TrueValue, FalseValue: Double):
      Double; overload; static;
    procedure Paint; override;
    procedure DrawHand(Color: TColor; Angle, Size: Double; aWidth: Integer = 2);
    procedure DrawFace;
    procedure DrawCenter;
    procedure DrawNumbers(Angle: Double; Value: Integer);
  public
    { Public declarations }
  end;

var
  Clock: TClock;

implementation

{$R *.dfm}

{ TClock }

procedure TClock.DrawCenter;
var
  radius: Integer;
begin
  radius := 6;
  with Canvas do
  begin
    pen.Color := clNone;
    Brush.Color := clBlack;
    Ellipse(p0.x - radius, p0.y - radius, p0.x + radius, p0.y + radius);
  end;
end;

procedure TClock.DrawFace;
var
  radius, h, m: Integer;
begin
  radius := MinP0XY - margin;
  with Canvas do
  begin
    Pen.Color := clBlack;
    Pen.Width := 2;
    Brush.Color := clWhite;
    Ellipse(p0.x - radius, p0.y - radius, p0.x + radius, p0.y + radius);
    for m := 0 to 59 do
      DrawHand(clGray, m * degrees06, -0.08, 2);

    for h := 0 to 11 do
    begin
      DrawHand(clBlack, h * degrees30, -0.09, 3);
      DrawNumbers((h + 3) * degrees30, 12 - h);
    end;
  end;
end;

procedure TClock.DrawHand(Color: TColor; Angle, Size: Double; aWidth: Integer = 2);
var
  radius, x0, y0, x1, y1: Integer;
begin
  radius := MinP0XY - margin;

  x0 := p0.X + (IfThen(Size > 0, 0, Round(radius * (Size + 1) * cos(Angle))));
  y0 := p0.Y + (IfThen(Size > 0, 0, Round(radius * (Size + 1) * sin(-Angle))));

  x1 := p0.X + round(radius * IfThen(Size > 0, Size, 1) * cos(Angle));
  y1 := p0.y + round(radius * IfThen(Size > 0, Size, 1) * sin(-Angle));

  with Canvas do
  begin
    Pen.Color := Color;
    pen.Width := aWidth;
    MoveTo(x0, y0);
    LineTo(x1, y1);
  end;
end;

procedure TClock.DrawNumbers(Angle: Double; Value: Integer);
var
  radius, x0, y0, x1, y1, h, w: Integer;
  Size: Double;
  s: string;
begin
  radius := MinP0XY - margin;
  Size := 0.85;
  s := (Value).ToString;

  x1 := p0.X + round(radius * Size * cos(Angle));
  y1 := p0.y + round(radius * Size * sin(-Angle));

  with Canvas do
  begin
    radius := 5;
    Font.Size := 12;
    w := TextWidth(s);
    h := TextHeight(s);

    x0 := x1 - (w div 2);
    y0 := y1 - (h div 2);

    TextOut(x0, y0, s);
  end;
end;

procedure TClock.FormResize(Sender: TObject);
begin
  p0 := Tpoint.create(ClientRect.CenterPoint);
  MinP0XY := p0.x;
  if MinP0XY > p0.Y then
    MinP0XY := p0.y;
  Refresh();
end;

class function TClock.IfThen(Condition: Boolean; TrueValue, FalseValue: Double): Double;
begin
  if Condition then
    exit(TrueValue);
  exit(FalseValue);
end;

class function TClock.IfThen(Condition: Boolean; TrueValue, FalseValue: Integer): Integer;
begin
  if Condition then
    exit(TrueValue);
  exit(FalseValue);
end;

procedure TClock.Paint;
var
  t: TDateTime;
  second, minute, hour: Integer;
  angle, minsecs, hourmins: Double;
begin
  inherited;

  t := time;
  second := trunc(Frac(t * 24 * 60) * 60);
  minute := trunc(Frac(t * 24) * 60);
  hour := trunc(t * 24);

  DrawFace;

  angle := degrees90 - (degrees06 * second);
  DrawHand(clred, angle, 0.95, 3);

  minsecs := (minute + second / 60.0);

  angle := degrees90 - (degrees06 * minsecs);
  DrawHand(clGreen, angle, 0.8, 4);

  hourmins := (hour + minsecs / 60.0);
  angle := degrees90 - (degrees30 * hourmins);
  DrawHand(clBlue, angle, 0.6, 5);

  DrawCenter;

  Caption := Format('%.2d:%.2d:%.2d', [hour, minute, second]);
end;

procedure TClock.tmrTimerTimer(Sender: TObject);
begin
  Refresh;
end;

end.

object Clock: TClock
  Left = 0
  Top = 0
  Caption = 'Draw_a_clock'
  ClientHeight = 462
  ClientWidth = 484
  Color = clBtnFace
  DoubleBuffered = True
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'Tahoma'
  Font.Style = []
  OldCreateOrder = False
  Position = poDesktopCenter
  OnResize = FormResize
  PixelsPerInch = 96
  TextHeight = 13
  object tmrTimer: TTimer
    OnTimer = tmrTimerTimer
    Left = 16
    Top = 8
  end
end

The code creates a simple, animated clock that updates every second. It utilizes system or language-specific timers instead of constantly polling system resources. The clock, which could be any time-keeping device, only needs to display seconds and should align with the system clock. The code is designed to be clear, concise, and efficient, avoiding unnecessary complexity and CPU usage.


The code calculates the number of Pythagorean triples (a, b, c) where a, b, and c are positive integers, a < b < c, and a^2 + b^2 = c^2, with a perimeter (a+b+c) no larger than 100. It also identifies the number of these triples that are primitive, i.e., a, b, and c are co-prime. The code is optimized to handle large values up to a maximum perimeter of 100,000,000.


// The project file (Project1.dpr)
program Project1;

uses
  Forms,
  // Include file with Window class declaration (see below)
  Unit0 in 'Unit1.pas' {Form1};

{$R *.res}

begin
  Application.Initialize;
  Application.CreateForm(TForm1, Form1);
  Application.Run;
end.

// The Window class declaration
unit Unit1;

interface

uses
  Forms;

type
  TForm1 = class(TForm)
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm} // The window definition resource (see below)

end.

// A textual rendition of the Window (form) definition file (Unit1.dfm)
object Form1: TForm1
  Left = 469
  Top = 142
  Width = 800
  Height = 600
  Caption = 'Form1'
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'MS Shell Dlg 2'
  Font.Style = []
  OldCreateOrder = False
  Position = poScreenCenter
  PixelsPerInch = 96
  TextHeight = 13
end

program Project3;

uses
  Windows,
  Messages;

var
  WndClass: TWndClass;
  Msg: TMsg;
  winT, winL: Integer;

// Initial height/width of the window
const
  winW: Integer = 800;
  winH: Integer = 600;

// Callback function to processes messages sent to the window
function WindowProc(hWnd,Msg,wParam,lParam:Integer): Integer; stdcall;
begin
  // Trap the WM_DESTROY message
  if (Msg = WM_DESTROY) then PostQuitMessage(0);
  Result := DefWindowProc(hWnd,Msg,wParam,lParam);
end;

begin
  // Fill the WndClass structure with the window class attributes
  // to be registered by the RegisterClass function
  with WndClass do
    begin
      lpszClassName:= 'Form1';
      lpfnWndProc :=  @WindowProc; // Pointer to our message handling callback
      style := CS_OWNDC or         // Request a unique device context
               CS_VREDRAW or       // Redraw window when resized vertically
               CS_HREDRAW;         // Redraw window when resized horizontally
      hInstance := hInstance;      // The instance that the window procedure of this class is within
      hbrBackground := HBRUSH(COLOR_BTNFACE+1); // Background colour of the window
    end;

  // Register the window class for use by CreateWindow
  RegisterClass(WndClass);

  // Calculate initial top and left positions of the window
  winT := (GetSystemMetrics(SM_CYFULLSCREEN) - winH) div 2;
  winL := (GetSystemMetrics(SM_CXFULLSCREEN) - winW) div 2;

  // Create the window
  CreateWindow(WndClass.lpszClassName,              // Class name
               'Form1',                             // Window name
               WS_OVERLAPPEDWINDOW or WS_VISIBLE,   // Window style
               winL,                                // Horizontal Position (Left)
               winT,                                // Vertical Position (Top)
               winW,                                // Width
               winH,                                // Height
               0,                                   // Window parent/owner handle
               0,                                   // Menu handle
               hInstance,                           // Handle to application instance
               nil);                                // Pointer to window creation data

 // Handle messages
 while GetMessage(Msg,0,0,0) do
   DispatchMessage(Msg);

end.

create a GUI window that can respond to close requests. Two methods are demonstrated: one using Delphi's standard window creation procedure, resulting in a 362KB executable, and a second 'pure' Windows API approach, not using the Delphi Visual Component Library, resulting in a 15KB executable.


"Open a text file, count the frequency of each letter from A to Z, and optionally include punctuation characters."


Type
  pOneWayList = ^OneWayList;
  OneWayList = record
                pData : pointer ;
                Next  : pOneWayList ;
               end;

define a data structure for a singly-linked list element. This element contains a data member that can hold a numeric value and a mutable link to the next element. It's a simple one-way list that uses a generic pointer for the data, allowing it to point to any structure or variable. However, in Standard Pascal, a specific data type must be used as there are no generic pointers.


Works with: Delphi version 6.0
Library: SysUtils,StdCtrls

procedure DrawTree(Image: TImage; X1, Y1: integer; Angle: double; Depth: integer);
var X2,Y2: integer;
begin
if Depth = 0 then exit;
X2:=trunc(X1 + cos(DegToRad(Angle)) * Depth * 5);
Y2:=trunc(Y1 + sin(DegToRad(Angle)) * Depth * 5);
Image.Canvas.Pen.Color:=ColorMap47[MulDiv(High(ColorMap47),Depth,11)];
Image.Canvas.Pen.Width:=MulDiv(Depth,5,10);
Image.Canvas.MoveTo(X1,Y1);
Image.Canvas.LineTo(X2,Y2);
DrawTree(Image, X2, Y2, Angle - 10, Depth - 1);
DrawTree(Image, X2, Y2, Angle + 35, Depth - 1);
end;

procedure ShowFactalTree(Image: TImage);
begin
ClearImage(Image,clBlack);
DrawTree(Image, 250, 350, -90, 11);
Image.Invalidate;
end;

generate and draw a fractal tree by first drawing the trunk, then splitting the trunk at the end by a certain angle to form two branches, and repeating this process until a desired level of branching is reached.


calculate the factors of a given positive integer, excluding zero and negative integers. It also notes that every prime number has two factors: 1 and itself.


Library: Delphi StdCtrls, Classes, SysUtils, StrUtils, Contnrs
USES
   StdCtrls, Classes, SysUtils, StrUtils, Contnrs;

procedure AlignByColumn(

The code reads a text file with lines separated by a dollar character. It aligns each column of fields by ensuring at least one space between words in each column. It also allows each word in a column to be left, right, or center justified. The minimum space between columns is computed from the text, not hard-coded. Trailing dollar characters or consecutive spaces at the end of lines do not affect the alignment. The output is suitable for viewing in a mono-spaced font on a plain text editor or basic terminal.


Library:  System.SysUtils
Translation of: Go
program Draw_a_cuboid;

{$APPTYPE CONSOLE}

uses
  System.SysUtils;

procedure cubLine(n, dx, dy: Integer; cde: string);
var
  i: integer;
begin
  write(format('%' + (n + 1).ToString + 's', [cde.Substring(0, 1)]));

  for i := 9 * dx - 1 downto 1 do
    Write(cde.Substring(1, 1));

  Write(cde.Substring(0, 1));
  Writeln(cde.Substring(2, cde.Length).PadLeft(dy + 1));
end;

procedure cuboid(dx, dy, dz: integer);
var
  i: integer;
begin
  Writeln(Format('cuboid %d %d %d:', [dx, dy, dz]));

  cubLine(dy + 1, dx, 0, '+-');

  for i := 1 to dy do
    cubLine(dy - i + 1, dx, i - 1, '/ |');

  cubLine(0, dx, dy, '+-|');

  for i := 4 * dz - dy - 2 downto 1 do
    cubLine(0, dx, dy, '| |');

  cubLine(0, dx, dy, '| +');

  for i := 1 to dy do
    cubLine(0, dx, dy - i, '| /');

  cubLine(0, dx, 0, '+-');
  Writeln;
end;

begin
  cuboid(2, 3, 4);
  cuboid(1, 1, 1);
  cuboid(6, 2, 1);

  readln;
end.

generate a graphical or ASCII art representation of a cuboid with dimensions 2x3x4, ensuring three faces are visible, and allowing for either static or rotational projection.


Library:  System.SysUtils
Translation of: Go
program Rot13;

{$APPTYPE CONSOLE}

uses
  System.SysUtils;

function Rot13char(c: AnsiChar): AnsiChar;
begin
  Result := c;
  if c in ['a'..'m', 'A'..'M'] then
    Result := AnsiChar(ord(c) + 13)
  else if c in ['n'..'z', 'N'..'Z'] then
    Result := AnsiChar(ord(c) - 13);
end;

function Rot13Fn(s: ansistring): ansistring;
var i: Integer;
begin
  SetLength(result, length(s));
  for i := 1 to length(s) do
    Result[i] := Rot13char(s[i]);
end;

begin
  writeln(Rot13Fn('nowhere ABJURER'));
  readln;
end.

implement a rot-13 function that replaces every letter of the ASCII alphabet with the letter which is "rotated" 13 characters around the 26 letter alphabet. The function should work on both upper and lower case letters, preserve case, and pass all non-alphabetic characters without alteration. Optionally, the function can be wrapped in a utility program that performs rot-13 encoding line-by-line for every line of input in each file listed on its command line or acts as a filter on its standard input.


program SortCompositeStructures;

{$APPTYPE CONSOLE}

uses SysUtils, Generics.Collections, Generics.Defaults;

type
  TStructurePair = record
    name: string;
    value: string;
    constructor Create(const aName, aValue: string);
  end;

constructor TStructurePair.Create(const aName, aValue: string);
begin
  name := aName;
  value := aValue;
end;

var
  lArray: array of TStructurePair;
begin
  SetLength(lArray, 3);
  lArray[0] := TStructurePair.Create('dog', 'rex');
  lArray[1] := TStructurePair.Create('cat', 'simba');
  lArray[2] := TStructurePair.Create('horse', 'trigger');

  TArray.Sort<TStructurePair>(lArray , TDelegatedComparer<TStructurePair>.Construct(
  function(const Left, Right: TStructurePair): Integer
  begin
    Result := CompareText(Left.Name, Right.Name);
  end));
end.

sort an array of composite structures, specifically name-value pairs, by the key name using a custom comparator.


program LoopFor;

{$APPTYPE CONSOLE}

var
  i, j: Integer;
begin
  for i := 1 to 5 do
  begin
    for j := 1 to i do
      Write('*');
    Writeln;
  end;
end.

demonstrate how to use nested for loops to print a specific pattern. The number of iterations in the inner loop is controlled by the outer loop, resulting in a pattern of increasing asterisks.


program AssociativeArrayCreation;

{$APPTYPE CONSOLE}

uses Generics.Collections;

var
  lDictionary: TDictionary<string, Integer>;
begin
  lDictionary := TDictionary<string, Integer>.Create;
  try
    lDictionary.Add('foo', 5);
    lDictionary.Add('bar', 10);
    lDictionary.Add('baz', 15);
    lDictionary.AddOrSetValue('foo', 6); // replaces value if it exists
  finally
    lDictionary.Free;
  end;
end.

"Create an associative array, also known as a dictionary, map, or hash."


Library:  System.SysUtils
Library:  Winapi.Windows
Translation of: C#
program Linear_congruential_generator;

{$APPTYPE CONSOLE}
{$R *.res}

uses
  System.SysUtils,
  Winapi.Windows;

type
  TRandom = record
  private
    FSeed: Cardinal;
    FBsdCurrent: Cardinal;
    FMsvcrtCurrent: Cardinal;
    class function Next(seed, a, b: Cardinal): Cardinal; static;
  public
    constructor Create(const seed: Cardinal);
    function Rand(Bsd: Boolean = True): Cardinal;
    property Seed: Cardinal read FSeed;
  end;

{ TRandom }

class function TRandom.Next(seed, a, b: Cardinal): Cardinal;
begin
  Result := (a * seed + b) and MAXDWORD;
end;

function TRandom.Rand(Bsd: Boolean): Cardinal;
begin
  if Bsd then
  begin
    FBsdCurrent := Next(FBsdCurrent, 1103515245, 12345);
    Result := FBsdCurrent;
  end
  else
  begin
    FMsvcrtCurrent := Next(FMsvcrtCurrent shl 16, 214013, 2531011) shr 16;
    Result := FMsvcrtCurrent;
  end;
end;

constructor TRandom.Create(const seed: Cardinal);
begin
  FSeed := seed;
  FBsdCurrent := FSeed;
  FMsvcrtCurrent := FSeed;
end;

var
  r: TRandom;

procedure PrintRandom(count: Integer; IsBsd: Boolean);
const
  NAME: array[Boolean] of string = ('MS', 'BSD');
var
  i: Integer;
begin
  Writeln(NAME[IsBsd], ' next ', count, ' Random'#10);
  for i := 0 to count - 1 do
    writeln('   ', r.Rand(IsBsd));
  writeln;
end;

begin
  r.Create(GetTickCount);
  PrintRandom(10, True);
  PrintRandom(10, False);
  readln;
end.

The code implements two historic random number generators: the rand() function from BSD libc and the rand() function from the Microsoft C Runtime (MSCVRT.DLL). These generators use the linear congruential generator formula with specific constants. The generators produce a sequence of integers, starting from a seed value, that is not cryptographically secure but can be used for simple tasks. The BSD generator outputs numbers in the range 0 to 2147483647, while the Microsoft generator outputs numbers in the range 0 to 32767.


// Using the same type defs from the one way list example.

Type

  // The pointer to the list structure
  pOneWayList = ^OneWayList;

  // The list structure
  OneWayList = record
                 pData : pointer ;
                 Next  : pOneWayList ;
               end;

// I will illustrate a simple function that will return a pointer to the
// new node or it will return NIL.  In this example I will always insert
// right, to keep the code clear.  Since I am using a function all operations
// for the new node will be conducted on the functions result.  This seems
// somewhat counter intuitive, but it is the simplest way to accomplish this.

Function InsertNode(VAR CurrentNode:pOneWayList): pOneWayList
begin

    // I try not to introduce different parts of the language, and keep each
    // example to just the code required.  in this case it is important to use
    // a try/except block.  In any OS that is multi-threaded and has many apps
    // running at the same time, you cannot rely on a call to check memory available
    // and then attempting to allocate.  In the time between the two, another
    // program may have grabbed the memory you were trying to get.

    Try
      // Try to allocate enough memory for a variable the size of OneWayList
      GetMem(Result,SizeOf(OneWayList));
    Except
      On EOutOfMemoryError do
         begin
           Result := NIL
           exit;
         end;
    end;

    // Initialize the variable.
    Result.Next  := NIL ;
    Reuslt.pdata := NIL ;

    // Ok now we will insert to the right.

    // Is the Next pointer of CurrentNode Nil?  If it is we are just tacking
    // on to the end of the list.

    if CurrentNode.Next = NIL then
       CurrentNode.Next := Result
    else
      // We are inserting into the middle of this list
      Begin
         Result.Next      := CurrentNode.Next ;
         CurrentNode.Next := result ;
      end;
end;

define a method to insert an element into a singly-linked list after a specified element. This method is then used to insert an element 'C' into a list containing elements 'A' and 'B', placing 'C' after 'A'. The code is designed to be compatible with Turbo Pascal, with considerations for its lack of C++-style comments and the Try Except block. The data pointer is kept generic to accommodate any structure or variable.


The code defines three functions for halving an integer, doubling an integer, and checking if an integer is even. These functions are used to implement Ethiopian multiplication, a method of multiplying integers using only addition, doubling, and halving. The multiplication process involves creating a table with two columns, repeatedly halving the first number and doubling the second number, discarding rows where the first number is even, and summing the remaining values in the second column to get the product.


Iterative[edit]
program Factorial1;

{$APPTYPE CONSOLE}

function FactorialIterative(aNumber: Integer): Int64;
var
  i: Integer;
begin
  Result := 1;
  for i := 1 to aNumber do
    Result := i * Result;
end;

begin
  Writeln('5! = ', FactorialIterative(5));
end.
Recursive[edit]
program Factorial2;

{$APPTYPE CONSOLE}

function FactorialRecursive(aNumber: Integer): Int64;
begin
  if aNumber < 1 then
    Result := 1
  else
    Result := aNumber * FactorialRecursive(aNumber - 1);
end;

begin
  Writeln('5! = ', FactorialRecursive(5));
end.
Tail Recursive[edit]
program Factorial3;

{$APPTYPE CONSOLE}

function FactorialTailRecursive(aNumber: Integer): Int64;

  function FactorialHelper(aNumber: Integer; aAccumulator: Int64): Int64;
  begin
    if aNumber = 0 then
      Result := aAccumulator
    else
      Result := FactorialHelper(aNumber - 1, aNumber * aAccumulator);
    end;

begin
  if aNumber < 1 then
    Result := 1
  else
    Result := FactorialHelper(aNumber, 1);
end;

begin
  Writeln('5! = ', FactorialTailRecursive(5));
end.

The code defines a function that calculates the factorial of a given number. The factorial is the product of all positive integers from the given number down to 1. The function can be implemented either iteratively or recursively. It optionally includes error handling for negative input numbers. It is related to the task of generating primorial numbers.


generate a unique four-digit number, accept user guesses, validate the format of the guesses, calculate scores based on the number of correct digits in the correct and incorrect positions, and terminate the program if the guess matches the generated number.


program Randoms;

{$APPTYPE CONSOLE}

uses
  Math;

var
  Values: array[0..999] of Double;
  I: Integer;

begin
//  Randomize;   Commented to obtain reproducible results
  for I:= Low(Values) to High(Values) do
    Values[I]:= RandG(1.0, 0.5);  // Mean = 1.0, StdDev = 0.5
  Writeln('Mean          = ', Mean(Values):6:4);
  Writeln('Std Deviation = ', StdDev(Values):6:4);
  Readln;
end.

generate a collection of 1000 normally distributed pseudo-random numbers with a mean of 1.0 and a standard deviation of 0.5 using Delphi's RandG function and Marsaglia-Bray algorithm.


Works with: Lazarus
program Project1;

{$APPTYPE CONSOLE}

type
  doublearray = array of Double;

function DotProduct(const A, B : doublearray): Double;
var
I: integer;
begin
  assert (Length(A) = Length(B), 'Input arrays must be the same length');
  Result := 0;
  for I := 0 to Length(A) - 1 do
    Result := Result + (A[I] * B[I]);
end;

var
  x,y: doublearray;
begin
  SetLength(x, 3);
  SetLength(y, 3);
  x[0] := 1; x[1] := 3; x[2] := -5;
  y[0] := 4; y[1] :=-2; y[2] := -1;
  WriteLn(DotProduct(x,y));
  ReadLn;
end.

The code implements a function to calculate the dot product of two vectors. The vectors can be of arbitrary length, but must be the same length for the operation. The dot product is computed by multiplying corresponding terms from each vector and summing the products. The function also handles the case where arrays cannot be declared in procedure headings, as in Delphi, by declaring them beforehand.


program InputLoop;

{$APPTYPE CONSOLE}

uses SysUtils, Classes;

var
  lReader: TStreamReader; // Introduced in Delphi XE
begin
  lReader := TStreamReader.Create('input.txt', TEncoding.Default);
  try
    while lReader.Peek >= 0 do
      Writeln(lReader.ReadLine);
  finally
    lReader.Free;
  end;
end.

"Continuously read words or lines from a text stream until there is no more data available."


lblDateTime.Caption := FormatDateTime('dd mmmm yyyy hh:mm:ss', Now);
This populates a label with the date

the system time in a specified unit. This can be used for debugging, network information, random number seeds, or program performance. The time is retrieved either by a system command or a built-in language function. It is related to the task of date formatting and retrieving system time.


program Sedol;

{$APPTYPE CONSOLE}

uses
  SysUtils;

const
  SEDOL_CHR_COUNT = 6;
  DIGITS = ['0'..'9'];
  LETTERS = ['A'..'Z'];
  VOWELS = ['A', 'E', 'I', 'O', 'U'];
  ACCEPTABLE_CHRS = DIGITS + LETTERS - VOWELS;
  WEIGHTS : ARRAY [1..SEDOL_CHR_COUNT] of integer = (1, 3, 1, 7, 3, 9);
  LETTER_OFFSET = 9;

function AddSedolCheckDigit(Sedol : string) : string;
var
  iChr : integer;
  Checksum : integer;
  CheckDigit : char;
begin
  if Sedol <> uppercase(Sedol) then
    raise ERangeError.CreateFmt('%s contains lower case characters',[Sedol]);
  if length(Sedol) <> SEDOL_CHR_COUNT then
    raise ERangeError.CreateFmt('"%s" length is invalid. Should be 6 characters',[Sedol]);

  Checksum := 0;
  for iChr := 1 to SEDOL_CHR_COUNT do
  begin

    if Sedol[iChr] in Vowels then
      raise ERangeError.CreateFmt('%s contains a vowel (%s) at chr %d',[Sedol, Sedol[iChr], iChr]);
    if not (Sedol[iChr] in ACCEPTABLE_CHRS) then
      raise ERangeError.CreateFmt('%s contains an invalid chr (%s) at position %d',[Sedol, Sedol[iChr], iChr]);

    if Sedol[iChr] in DIGITS then
      Checksum := Checksum + (ord(Sedol[iChr]) - ord('0')) * WEIGHTS[iChr]
    else
      Checksum := Checksum + (ord(Sedol[iChr]) - ord('A') + 1 + LETTER_OFFSET) * WEIGHTS[iChr];

  end;

  Checksum := (Checksum mod 10);
  if Checksum <> 0 then
    Checksum := 10 - Checksum;
  CheckDigit := chr(CheckSum + ord('0'));

  Result := Sedol + CheckDigit;
end;

procedure Test(First6 : string);
begin
  writeln(First6, ' becomes ', AddSedolCheckDigit(First6));
end;

begin
  try
    Test('710889');
    Test('B0YBKJ');
    Test('406566');
    Test('B0YBLH');
    Test('228276');
    Test('B0YBKL');
    Test('557910');
    Test('B0YBKR');
    Test('585284');
    Test('B0YBKT');
    Test('B00030');
  except
    on E : Exception do
      writeln(E.Message);
  end;
  readln;
end.

710889 becomes 7108899
B0YBKJ becomes B0YBKJ7
406566 becomes 4065663
B0YBLH becomes B0YBLH2
228276 becomes 2282765
B0YBKL becomes B0YBKL9
557910 becomes 5579107
B0YBKR becomes B0YBKR5
585284 becomes 5852842
B0YBKT becomes B0YBKT7
B00030 becomes B000300

The code takes a list of 6-digit SEDOL numbers as input, calculates and appends the checksum digit to each SEDOL number, and outputs the updated SEDOL numbers. It also validates the input to ensure that it contains only valid characters for a SEDOL string.


Translation of: C

program DrawASphere;

{$APPTYPE CONSOLE}

uses
  SysUtils,
  Math;

type
  TDouble3  = array[0..2] of Double;
  TChar10 = array[0..9] of Char;

var
  shades: TChar10 = ('.', ':', '!', '*', 'o', 'e', '&', '#', '%', '@');
  light: TDouble3 = (30, 30, -50 );

  procedure normalize(var v: TDouble3);
  var
    len: Double;
  begin
    len:= sqrt(v[0]*v[0] + v[1]*v[1] + v[2]*v[2]);
    v[0] := v[0] / len;
    v[1] := v[1] / len;
    v[2] := v[2] / len;
  end;

  function dot(x, y: TDouble3): Double;
  begin
    Result:= x[0]*y[0] + x[1]*y[1] + x[2]*y[2];
    Result:= IfThen(Result < 0, -Result, 0 );
  end;

  procedure drawSphere(R, k, ambient: Double);
  var
    vec: TDouble3;
    x, y, b: Double;
    i, j,
    intensity: Integer;
  begin
    for i:= Floor(-R) to Ceil(R) do
    begin
      x := i + 0.5;
      for j:= Floor(-2*R) to Ceil(2 * R) do
      begin
        y:= j / 2 + 0.5;
        if(x * x + y * y <= R * R) then
        begin
          vec[0]:= x;
          vec[1]:= y;
          vec[2]:= sqrt(R * R - x * x - y * y);
          normalize(vec);
          b:= Power(dot(light, vec), k) + ambient;
          intensity:= IfThen(b <= 0,
                             Length(shades) - 2,
                             Trunc(max( (1 - b) * (Length(shades) - 1), 0 )));
          Write(shades[intensity]);
        end
        else
          Write(' ');
      end;
      Writeln;
    end;
  end;

begin
  normalize(light);
  drawSphere(19, 4, 0.1);
  drawSphere(10, 2, 0.4);
  Readln;
end.

The code generates a graphical or ASCII art representation of a sphere, with either static or rotational projection. On Windows, if the sphere appears distorted, the console width can be increased to maintain roundness.


The code is a function that takes an integer input greater than or equal to zero and returns a string of the number with an apostrophe and an ordinal suffix. The function is demonstrated with the integer ranges of 0 to 25, 250 to 265, and 1000 to 1025. The use of apostrophes is optional.


program StripCharacters;

{$APPTYPE CONSOLE}

uses SysUtils;

function StripChars(const aSrc, aCharsToStrip: string): string;
var
  c: Char;
begin
  Result := aSrc;
  for c in aCharsToStrip do
    Result := StringReplace(Result, c, '', [rfReplaceAll, rfIgnoreCase]);
end;

const
  TEST_STRING = 'She was a soul stripper. She took my heart!';
begin
  Writeln(TEST_STRING);
  Writeln(StripChars(TEST_STRING, 'aei'));
end.

"Function to remove specific characters from a given string"


Library:  System.SysUtils
program String_preappend;

{$APPTYPE CONSOLE}

uses
  System.SysUtils;

type
  TStringHelper = record helper for string
    procedure Preappend(str: string);
  end;

{ TStringHelper }

procedure TStringHelper.Preappend(str: string);
begin
  Self := str + self;
end;

begin
  var h: string;

  // with + operator
  h := 'World';
  h := 'Hello ' + h;
  writeln(h);

  // with a function concat
  h := 'World';
  h := concat('Hello ', h);
  writeln(h);

  // with helper
  h := 'World';
  h.Preappend('Hello ');
  writeln(h);
  readln;
end.

Creates a string variable with a specific text value, prepends another string literal to it, and displays the content of the variable. If possible, the operation is performed without referring to the variable twice in one expression.


Library:  Winapi.Windows
Library:  System.SysUtils
Library:  System.Classes
Library:  Vcl.Graphics
Translation of: Go
program Dragon_curve;

{$APPTYPE CONSOLE}

uses
  Winapi.Windows,
  System.SysUtils,
  System.Classes,
  Vcl.Graphics;

type
  TDragon = class
  private
    p: TColor;
    _sin: TArray<double>;
    _cos: TArray<double>;
    s: double;
    b: TBitmap;
    FAsBitmap: TBitmap;
    const
      sep = 512;
      depth = 14;
    procedure Dragon(n, a, t: Integer; d, x, y: Double; var b: TBitmap);
  public
    constructor Create;
    destructor Destroy; override;
    property AsBitmap: TBitmap read b;
  end;

{ TDragon }

procedure TDragon.Dragon(n, a, t: Integer; d, x, y: Double; var b: TBitmap);
begin
  if n <= 1 then
  begin
    with b.Canvas do
    begin
      Pen.Color := p;
      MoveTo(Trunc(x + 0.5), Trunc(y + 0.5));
      LineTo(Trunc(x + d * _cos[a] + 0.5), Trunc(y + d * _sin[a] + 0.5));
      exit;
    end;
  end;

  d := d * s;
  var a1 := (a - t) and 7;
  var a2 := (a + t) and 7;

  dragon(n - 1, a1, 1, d, x, y, b);
  dragon(n - 1, a2, -1, d, x + d * _cos[a1], y + d * _sin[a1], b);
end;

constructor TDragon.Create;
begin
  s := sqrt(2) / 2;
  _sin := [0, s, 1, s, 0, -s, -1, -s];
  _cos := [1.0, s, 0.0, -s, -1.0, -s, 0.0, s];
  p := Rgb(64, 192, 96);
  b := TBitmap.create;

  var width := Trunc(sep * 11 / 6);
  var height := Trunc(sep * 4 / 3);
  b.SetSize(width, height);
  with b.Canvas do
  begin
    Brush.Color := clWhite;
    Pen.Width := 3;
    FillRect(Rect(0, 0, width, height));
  end;
  dragon(14, 0, 1, sep, sep / 2, sep * 5 / 6, b);
end;

destructor TDragon.Destroy;
begin
  b.Free;
  inherited;
end;

var
  Dragon: TDragon;

begin
  Dragon := TDragon.Create;
  Dragon.AsBitmap.SaveToFile('dragon.bmp');
  Dragon.Free;
end.

generate a dragon curve fractal either directly or by writing it to an image file. The fractal is created using various algorithms such as recursive, successive approximation, iterative, and Lindenmayer system of expansions. The algorithms consider curl direction, bit transitions, and absolute X, Y coordinates. The code also includes functionality to test whether a given X,Y point or segment is on the curve. The code is adaptable to different programming languages and drawing methods.


program GuessTheNumber;

{$APPTYPE CONSOLE}

uses SysUtils;

var
  theDigit : String ;
  theAnswer : String ;

begin
  Randomize ;
  theDigit := IntToStr(Random(9)+1) ;
  while ( theAnswer <> theDigit ) do Begin
    Writeln('Please enter a digit between 1 and 10' ) ;
    Readln(theAnswer);
  End ;
  Writeln('Congratulations' ) ;
end.

"Implement a number guessing game where the computer selects a number between 1 and 10. The player is repeatedly prompted to guess the number until the correct number is guessed, upon which a 'Well guessed!' message is displayed and the program terminates. A conditional loop is used to facilitate repeated guessing."


program atoz;

var
  ch : char;

begin
  for ch in ['a'..'z'] do
  begin
    write(ch);
  end;
end.

generate a sequence of all lower case ASCII characters from a to z. This is done in a reliable coding style suitable for large programs, using strong typing if available. The code avoids manual enumeration of characters to prevent bugs. It also demonstrates how to access a similar sequence from the standard library if it exists.


program BinaryDigit;
{$APPTYPE CONSOLE}
uses
  sysutils;

function IntToBinStr(AInt : LongWord) : string;
begin
  Result := '';
  repeat
    Result := Chr(Ord('0')+(AInt and 1))+Result;
    AInt := AInt div 2;
  until (AInt = 0);
end;

Begin
  writeln('   5: ',IntToBinStr(5));
  writeln('  50: ',IntToBinStr(50));
  writeln('9000: '+IntToBinStr(9000));
end.

generate a sequence of binary digits for a given non-negative integer. The output displays only the binary digits of each number, followed by a newline, without any whitespace, radix, sign markers, or leading zeros. The conversion can be achieved using built-in radix functions or a user-defined function.


Library:  Windows
Library:  Messages
Library:  SysUtils

program Draw_a_pixel;

{$APPTYPE CONSOLE}

{$R *.res}

uses
  Windows,
  Messages,
  SysUtils;

var
  Msg: TMSG;
  LWndClass: TWndClass;
  hMainHandle: HWND;

procedure Paint(Handle: hWnd); forward;

procedure ReleaseResources;
begin
  PostQuitMessage(0);
end;

function WindowProc(hWnd, Msg: Longint; wParam: wParam; lParam: lParam): Longint; stdcall;
begin
  case Msg of
    WM_PAINT:
      Paint(hWnd);
    WM_DESTROY:
      ReleaseResources;
  end;
  Result := DefWindowProc(hWnd, Msg, wParam, lParam);
end;

procedure CreateWin(W, H: Integer);
begin
  LWndClass.hInstance := hInstance;
  with LWndClass do
  begin
    lpszClassName := 'OneRedPixel';
    Style := CS_PARENTDC or CS_BYTEALIGNCLIENT;
    hIcon := LoadIcon(hInstance, 'MAINICON');
    lpfnWndProc := @WindowProc;
    hbrBackground := COLOR_BTNFACE + 1;
    hCursor := LoadCursor(0, IDC_ARROW);
  end;

  RegisterClass(LWndClass);
  hMainHandle := CreateWindow(LWndClass.lpszClassName,
    'Draw a red pixel on (100,100)', WS_CAPTION or WS_MINIMIZEBOX or WS_SYSMENU
    or WS_VISIBLE, ((GetSystemMetrics(SM_CXSCREEN) - W) div 2), ((GetSystemMetrics
    (SM_CYSCREEN) - H) div 2), W, H, 0, 0, hInstance, nil);
end;

procedure ShowModal;
begin
  while GetMessage(Msg, 0, 0, 0) do
  begin
    TranslateMessage(Msg);
    DispatchMessage(Msg);
  end;
end;

procedure Paint(Handle: hWnd);
var
  ps: PAINTSTRUCT;
  Dc: HDC;
begin
  Dc := BeginPaint(Handle, ps);

  // Fill bg with white
  FillRect(Dc, ps.rcPaint, CreateSolidBrush($FFFFFF));

  // Do the magic
  SetPixel(Dc, 100, 100, $FF);

  EndPaint(Handle, ps);
end;

begin
  CreateWin(320, 240);
  ShowModal();
end.

create a 320x240 window using Windows API and draw a red pixel at the position (100, 100).


Library:  System.SysUtils
Library:  uSettings

unit uSettings;

interface

uses
  System.SysUtils, System.IoUtils, System.Generics.Collections, System.Variants;

type
  TVariable = record
    value: variant;
    function ToString: string;
    class operator Implicit(a: variant): TVariable;
    class operator Implicit(a: TVariable): TArray<string>;
    class operator Implicit(a: TVariable): string;
  end;

  TSettings = class(TDictionary<string, TVariable>)
  private
    function GetVariable(key: string): TVariable;
    procedure SetVariable(key: string; const Value: TVariable);
    function GetKey(line: string; var key: string; var value: variant; var
      disable: boolean): boolean;
    function GetAllKeys: TList<string>;
  public
    procedure LoadFromFile(Filename: TfileName);
    procedure SaveToFile(Filename: TfileName);
    property Variable[key: string]: TVariable read GetVariable write SetVariable; default;
  end;

implementation

{ TVariable }

class operator TVariable.Implicit(a: variant): TVariable;
begin
  Result.value := a;
end;

class operator TVariable.Implicit(a: TVariable): TArray<string>;
begin
  if VarIsType(a.value, varArray or varOleStr) then
    Result := a.value
  else
    raise Exception.Create('Error: can''t convert this type data in array');
end;

class operator TVariable.Implicit(a: TVariable): string;
begin
  Result := a.ToString;
end;

function TVariable.ToString: string;
var
  arr: TArray<string>;
begin
  if VarIsType(value, varArray or varOleStr) then
  begin
    arr := value;
    Result := string.Join(', ', arr).Trim;
  end
  else
    Result := value;
  Result := Result.Trim;
end;

{ TSettings }

function TSettings.GetAllKeys: TList<string>;
var
  key: string;
begin
  Result := TList<string>.Create;
  for key in Keys do
    Result.Add(key);
end;

function TSettings.GetKey(line: string; var key: string; var value: variant; var
  disable: boolean): boolean;
var
  line_: string;
  j: integer;
begin
  line_ := line.Trim;
  Result := not (line_.IsEmpty or (line_[1] = '#'));
  if not Result then
    exit;

  disable := (line_[1] = ';');
  if disable then
    delete(line_, 1, 1);

  var data := line_.Split([' '], TStringSplitOptions.ExcludeEmpty);
  case length(data) of
    1: //Boolean
      begin
        key := data[0].ToUpper;
        value := True;
      end;

    2: //Single String
      begin
        key := data[0].ToUpper;
        value := data[1].Trim;
      end;

  else // Mult String value or Array of value
    begin
      key := data[0];
      delete(line_, 1, key.Length);
      if line_.IndexOf(',') > -1 then
      begin
        data := line_.Trim.Split([','], TStringSplitOptions.ExcludeEmpty);
        for j := 0 to High(data) do
          data[j] := data[j].Trim;
        value := data;
      end
      else
        value := line_.Trim;
    end;
  end;
  Result := true;
end;

function TSettings.GetVariable(key: string): TVariable;
begin
  key := key.Trim.ToUpper;
  if not ContainsKey(key) then
    add(key, false);

  result := Items[key];
end;

procedure TSettings.LoadFromFile(Filename: TfileName);
var
  key, line: string;
  value: variant;
  disabled: boolean;
  Lines: TArray<string>;
begin
  if not FileExists(Filename) then
    exit;

  Clear;
  Lines := TFile.ReadAllLines(Filename);
  for line in Lines do
  begin
    if GetKey(line, key, value, disabled) then
    begin
      if disabled then
        AddOrSetValue(key, False)
      else
        AddOrSetValue(key, value)
    end;
  end;
end;

procedure TSettings.SaveToFile(Filename: TfileName);
var
  key, line: string;
  value: variant;
  disabled: boolean;
  Lines: TArray<string>;
  i: Integer;
  All_kyes: TList<string>;
begin
  All_kyes := GetAllKeys();
  SetLength(Lines, 0);
  i := 0;
  if FileExists(Filename) then
  begin
    Lines := TFile.ReadAllLines(Filename);
    for i := high(Lines) downto 0 do
    begin
      if GetKey(Lines[i], key, value, disabled) then
      begin
        if not ContainsKey(key) then
        begin
          Lines[i] := '; ' + Lines[i];
          Continue;
        end;

        All_kyes.Remove(key);

        disabled := VarIsType(Variable[key].value, varBoolean) and (Variable[key].value
          = false);
        if not disabled then
        begin
          if VarIsType(Variable[key].value, varBoolean) then
            Lines[i] := key
          else
            Lines[i] := format('%s %s', [key, Variable[key].ToString])
        end
        else
          Lines[i] := '; ' + key;
      end;
    end;

  end;

  // new keys
  i := high(Lines) + 1;
  SetLength(Lines, Length(Lines) + All_kyes.Count);
  for key in All_kyes do
  begin
    Lines[i] := format('%s %s', [key, Variable[key].ToString]);
    inc(i);
  end;

  Tfile.WriteAllLines(Filename, Lines);

  All_kyes.Free;
end;

procedure TSettings.SetVariable(key: string; const Value: TVariable);
begin
  AddOrSetValue(key.Trim.ToUpper, Value);
end;
end.

program ReadAConfigFile;

{$APPTYPE CONSOLE}

uses
  System.SysUtils,
  uSettings;

const
  FileName = 'Config.txt';

var
  Settings: TSettings;

procedure show(key: string; value: string);
begin
  writeln(format('%14s = %s', [key, value]));
end;

begin
  Settings := TSettings.Create;
  Settings.LoadFromFile(FileName);

  for var k in Settings.Keys do
    show(k, Settings[k]);

  Settings.Free;
  Readln;
end.

The code reads a standard configuration file, ignores lines beginning with a hash or semicolon, and blank lines. It sets variables based on the configuration parameters: fullname, favouritefruit, needspeeling, seedsremoved, and otherfamily. The 'otherfamily' parameter can have multiple values, stored in an array. The code also handles optional equals signs separating parameter data from the option name, and ignores leading and trailing whitespace around parameter names and data fields. The configuration option names are case insensitive, while the parameter data is case sensitive.


program HaversineDemo;
uses Math;

function HaversineDist(th1, ph1, th2, ph2:double):double;
const diameter = 2 * 6372.8;
var   dx, dy, dz:double;
begin
  ph1    := degtorad(ph1 - ph2);
  th1    := degtorad(th1);
  th2    := degtorad(th2);

  dz     := sin(th1) - sin(th2);
  dx     := cos(ph1) * cos(th1) - cos(th2);
  dy     := sin(ph1) * cos(th1);
  Result := arcsin(sqrt(sqr(dx) + sqr(dy) + sqr(dz)) / 2) * diameter;
end;

begin
  Writeln('Haversine distance: ', HaversineDist(36.12, -86.67, 33.94, -118.4):7:2, ' km.');
end.

Implement a function to calculate the great-circle distance between two points on a sphere using the Haversine formula. The function takes the coordinates of Nashville International Airport (BNA) and Los Angeles International Airport (LAX) as input and returns the distance between them. The calculation uses the recommended earth radius of 6372.8 km or 6371 km, depending on the level of precision required.


program HTTP;

{$APPTYPE CONSOLE}

{$DEFINE DEBUG}

uses
  Classes,
  httpsend; // Synapse httpsend class

var
  Response: TStrings;
  HTTPObj: THTTPSend;

begin
  HTTPObj := THTTPSend.Create;
  try
    { Stringlist object to capture HTML returned
      from URL }
    Response := TStringList.Create;
    try
      if HTTPObj.HTTPMethod('GET','http://www.mgis.uk.com') then
        begin
          { Load HTTP Document into Stringlist }
          Response.LoadFromStream(HTTPObj.Document);
          { Write the response to the console window }
          Writeln(Response.Text);
        end
        else
        Writeln('Error retrieving data');

    finally
      Response.Free;
    end;

  finally
    HTTPObj.Free;
  end;

  // Keep console window open
  Readln;

end.

program ShowHTTP;

{$APPTYPE CONSOLE}

uses IdHttp;

var
  s: string;
  lHTTP: TIdHTTP;
begin
  lHTTP := TIdHTTP.Create(nil);
  try
    lHTTP.HandleRedirects := True;
    s := lHTTP.Get('http://www.rosettacode.org');
    Writeln(s);
  finally
    lHTTP.Free;
  end;
end.

print the content of a specified URL to the console using either the Synapse TCP/IP library or Indy. Note that this does not cover HTTPS requests.


Works with: Delphi version 6.0
Library: SysUtils,StdCtrls

{Test data arrays}

const Num1: array [0..10] of byte = (4,9,9,2,7,3,9,8,7,1,6);
const Num2: array [0..10] of byte = (4,9,9,2,7,3,9,8,7,1,7);
const Num3: array [0..15] of byte = (1,2,3,4,5,6,7,8,1,2,3,4,5,6,7,8);
const Num4: array [0..15] of byte = (1,2,3,4,5,6,7,8,1,2,3,4,5,6,7,0);

{Simplifies cases where we have to sum a two digit number}

const DigitSum: array [0..18] of byte = (0,1,2,3,4,5,6,7,8,9,1,2,3,4,5,6,7,8,9);

function ValidateCreditCard(CardNum: array of byte): boolean;
{Validate a Credit Card number}
var I,J,Len,Sum,Sum1,Sum2: integer;
var Rev: array of byte;
begin
Sum1:=0; Sum2:=0;
Len:=High(CardNum);
for I:=Len downto 0 do
 if ((I-Len) and 1)=0 then Sum1:=Sum1 + CardNum[I]
 else Sum2:=Sum2 + DigitSum[CardNum[I]*2];
Sum:=Sum1+Sum2;
Result:=(Sum mod 10)=0;
end;

function CardNumberToStr(CardNum: array of byte): string;
{Convert card number to a string}
var I: integer;
begin
Result:='';
for I:=0 to High(CardNum) do
Result:=Result+IntToStr(CardNum[I]);
end;

procedure TestDisplayNumber(Memo: TMemo; Num: array of byte);
{Test a credit card number and display results}
var S: string;
begin
S:=CardNumberToStr(Num);
if ValidateCreditCard(Num) then S:=S+': Valid'
else S:=S+': Not Valid';
Memo.Lines.Add(S);
end;

procedure TestCreditCardNums(Memo: TMemo);
{Test all credit card numbers}
begin
TestDisplayNumber(Memo,Num1);
TestDisplayNumber(Memo,Num2);
TestDisplayNumber(Memo,Num3);
TestDisplayNumber(Memo,Num4);
end;

"Implements the Luhn test to validate credit card numbers. The function reverses the input number, calculates the sum of odd and even digits (with even digits being doubled and, if the result is a two-digit number, summed again), and checks if the total sum ends in zero. The function is used to validate a set of given numbers. The process uses an array to handle two-digit results from the doubling operation and avoids reversing the number by traversing the array backwards."


Works with: Delphi version 6.0
Library: SysUtils,Classes,StdCtrls,ExtCtrl

type TIntArray = array of integer;

procedure GetJosephusSequence(N,K: integer; var IA: TIntArray);
{Analyze sequence of deleting every K of N numbers}
{Retrun result in Integer Array}
var LS: TList;
var I,J: integer;
begin
SetLength(IA,N);
LS:=TList.Create;
try
{Store number 0..N-1 in list}
for I:=0 to N-1 do LS.Add(Pointer(I));
J:=0;
for I:=0 to N-1 do
	begin
	{Advance J by K-1 because iterms are deleted}
	{And wrapping around if it J exceed the count }
        J:=(J+K-1) mod LS.Count;
        {Caption the sequence}
        IA[I]:=Integer(LS[J]);
        {Delete (kill) one item}
        LS.Delete(J);
	end;
finally LS.Free; end;
end;

procedure ShowJosephusProblem(Memo: TMemo; N,K: integer);
{Analyze and display one Josephus Problem}
var IA: TIntArray;
var I: integer;
var S: string;
const CRLF = #$0D#$0A;
begin
GetJosephusSequence(N,K,IA);
S:='';
for I:=0 to High(IA) do
	begin
	if I>0 then S:=S+',';
	if (I mod 12)=11 then S:=S+CRLF+'           ';
	S:=S+IntToStr(IA[I]);
	end;
Memo.Lines.Add('N='+IntToStr(N)+' K='+IntToStr(K));
Memo.Lines.Add('Sequence: ['+S+']');
Memo.Lines.Add('Survivor: '+IntToStr(IA[High(IA)]));
Memo.Lines.Add('');
end;

procedure TestJosephusProblem(Memo: TMemo);
{Test suite of Josephus Problems}
begin
ShowJosephusProblem(Memo,5,2);
ShowJosephusProblem(Memo,41,3);
end;

The code implements the Josephus problem, a mathematical puzzle where n prisoners are sequentially numbered and every k-th prisoner is executed until only one remains. The code determines the final survivor given any n and k. It also provides a way to calculate the position of any prisoner in the killing sequence. The code uses a standard Delphi TList to hold and delete numbers as it processes the data.


function RepeatString(const s: string; count: cardinal): string;
var
  i: Integer;
begin
  for i := 1 to count do
    Result := Result + s;
end;

Writeln(RepeatString('ha',5));

Writeln( StringOfChar('a',5) );

function RepeatStr(const s: string; i: Cardinal): string;
begin
  if i = 0 then
    result := ''
  else
   result := s + RepeatStr(s, i-1)
end;

StrUtils.DupeString

Code summarization: The code repeats a given string or character a specified number of times, demonstrating both a general method and a more efficient method for single characters. It also includes a recursion method and a built-in RTL function.


Library:  System.SysUtils
Library:  System.RegularExpressions

program Regular_expressions;

{$APPTYPE CONSOLE}
{$R *.res}

uses
  System.SysUtils,
  System.RegularExpressions;

const
  CPP_IF = '\s*if\s*\(\s*(?<COND>.*)\s*\)\s*\{\s*return\s+(?<RETURN>.+);\s*\}';
  PASCAL_IF = 'If ${COND} then result:= ${RETURN};';

var
  RegularExpression: TRegEx;
  str: string;

begin
  str := ' if ( a < 0 ) { return -a; }';

  Writeln('Expression: '#10#10, str);

  if RegularExpression.Create(CPP_IF).IsMatch(str) then
  begin
    Writeln(#10'   Is a single If in Cpp:'#10);

    Writeln('Translate to Pascal:'#10);
    str := RegularExpression.Create(CPP_IF).Replace(str, PASCAL_IF);
    Writeln(str);
  end;
  readln;
end.

"Code matches a string with a regular expression and substitutes part of the string using the same regular expression, specifically to translate a line of code from C++ to Pascal."


program IntegerArithmetic;

{$APPTYPE CONSOLE}

uses SysUtils, Math;

var
  a, b: Integer;
begin
  a := StrToInt(ParamStr(1));
  b := StrToInt(ParamStr(2));

  WriteLn(Format('%d + %d = %d', [a, b, a + b]));
  WriteLn(Format('%d - %d = %d', [a, b, a - b]));
  WriteLn(Format('%d * %d = %d', [a, b, a * b]));
  WriteLn(Format('%d / %d = %d', [a, b, a div b])); // rounds towards 0
  WriteLn(Format('%d %% %d = %d', [a, b, a mod b])); // matches sign of the first operand
  WriteLn(Format('%d ^ %d = %d', [a, b, Trunc(Power(a, b))]));
end.

take two integers as input from the user and display their sum, difference, product, integer quotient, remainder, and exponentiation. The code also indicates the rounding direction for the quotient and the sign of the remainder. It does not include error handling. A bonus feature is the inclusion of the `divmod` operator example.


program OccurrencesOfASubstring;

{$APPTYPE CONSOLE}

uses StrUtils;

function CountSubstring(const aString, aSubstring: string): Integer;
var
  lPosition: Integer;
begin
  Result := 0;
  lPosition := PosEx(aSubstring, aString);
  while lPosition <> 0 do
  begin
    Inc(Result);
    lPosition := PosEx(aSubstring, aString, lPosition + Length(aSubstring));
  end;
end;

begin
  Writeln(CountSubstring('the three truths', 'th'));
  Writeln(CountSubstring('ababababab', 'abab'));
end.

The code defines a function to count the number of non-overlapping occurrences of a given substring within a larger string. The function takes two arguments: the main string and the substring to search for. It returns an integer representing the count of non-overlapping occurrences. The function prioritizes the highest number of non-overlapping matches, typically matching from left-to-right or right-to-left.


implement a recursive solution for the Towers of Hanoi problem.


program Binomial;

{$APPTYPE CONSOLE}

function BinomialCoff(N, K: Cardinal): Cardinal;
var
  L: Cardinal;

begin
  if N < K then
    Result:= 0      // Error
  else begin
    if K > N - K then
      K:= N - K;    // Optimization
    Result:= 1;
    L:= 0;
    while L < K do begin
      Result:= Result * (N - L);
      Inc(L);
      Result:= Result div L;
    end;
  end;
end;

begin
  Writeln('C(5,3) is ', BinomialCoff(5, 3));
  ReadLn;
end.

The code calculates any binomial coefficient using the provided formula. It is specifically designed to output the binomial coefficient of 5 choose 3, which is 10. It also includes tasks for generating combinations and permutations, both with and without replacement.


Procedure ShellSort(var buf:Array of Integer);
const
  gaps:array[0..7] of Integer = (701, 301, 132, 57, 23, 10, 4, 1);

var
  whichGap, i, j, n, gap, temp : Integer;

begin
  n := high(buf);
  for whichGap := 0 to high(gaps) do begin
    gap := gaps[whichGap];
    for i := gap to n do begin
      temp := buf[i];

      j := i;
      while ( (j >= gap ) and ( (buf[j-gap] > dt) ) do begin
        buf[j] := buf[j-gap];
        dec(j, gap);
      end;
      buf[j] := temp;
    end;
  end;
end;

implement the Shell sort algorithm to sort an array of elements. This algorithm, invented by Donald Shell, uses a diminishing increment sort and interleaved insertion sorts based on an increment sequence. The increment size reduces after each pass until it reaches 1, turning the sort into a basic insertion sort. The data is almost sorted at this point, providing the best case for insertion sort. The increment sequence can vary but should always end in 1. Sequences with a geometric increment ratio of about 2.2 have been found to work well.


extend the data storage type to support grayscale images, convert a color image to a grayscale image and vice versa using the CIE recommended formula for luminance. The code also ensures that rounding errors in floating-point arithmetic do not cause run-time problems or distorted results.


Library:  Winapi.Windows
Library:  System.SysUtils
Library:  System.Classes
Library:  Vcl.Controls
Library:  Vcl.Forms
Library:  Vcl.StdCtrls
Library:  Vcl.ExtCtrls
unit Main;

interface

uses
  Winapi.Windows, System.SysUtils, System.Classes, Vcl.Controls, Vcl.Forms,
  Vcl.StdCtrls, Vcl.ExtCtrls;

type
  TForm1 = class(TForm)
    lblAniText: TLabel;
    tmrAniFrame: TTimer;
    procedure lblAniTextClick(Sender: TObject);
    procedure tmrAniFrameTimer(Sender: TObject);
  end;

var
  Form1: TForm1;
  Reverse: boolean = false;

implementation

{$R *.dfm}

procedure TForm1.lblAniTextClick(Sender: TObject);
begin
  Reverse := not Reverse;
end;

function Shift(text: string; direction: boolean): string;
begin
  if direction then
    result := text[text.Length] + text.Substring(0, text.Length - 1)
  else
    result := text.Substring(1, text.Length) + text[1];
end;

procedure TForm1.tmrAniFrameTimer(Sender: TObject);
begin
  with lblAniText do
    Caption := Shift(Caption, Reverse);
end;
end.

object Form1: TForm1
  ClientHeight = 132
  ClientWidth = 621
  object lblAniText: TLabel
    Align = alClient
    Alignment = taCenter
    Caption = 'Hello World! '
    Font.Height = -96
    OnClick = lblAniTextClick
  end
  object tmrAniFrame: TTimer
    Interval = 200
    OnTimer = tmrAniFrameTimer
  end
end

"Creates a GUI window displaying a rotating "Hello World!" text. The rotation direction reverses upon user click."


program Loop;

{$APPTYPE CONSOLE}

var
  I: Integer;

begin
  I:= 0;
  repeat
    Inc(I);
    Write(I:2);
  until I mod 6 = 0;
  Writeln;
  Readln;
end.

The code initializes a value to 0, then enters a do-while loop where it increments the value by 1 and prints it, continuing as long as the value modulo 6 is not 0. The loop is guaranteed to execute at least once.


The code calculates the character and byte length of a string, correctly handling encodings like UTF-8 and Unicode code points. It also correctly handles non-BMP code points. The code provides the actual character counts in code points, not in code unit counts. It can also provide the string length in graphemes if the language supports it.


Windows[edit]
Library:  System.SysUtils
Library:  Winapi.WinCrypt[[1]]
program Random_number_generator;

{$APPTYPE CONSOLE}

uses
  System.SysUtils,
  Winapi.WinCrypt;

var
  hCryptProv: NativeUInt;
  i: Byte;
  UserName: PChar;

function Random: UInt64;
var
  pbData: array[0..7] of byte;
  i: integer;
begin
  if not CryptGenRandom(hCryptProv, 8, @pbData[0]) then
    exit(0);
  Result := 0;
  for i := 0 to 7 do
    Result := Result + (pbData[i] shl (8 * i));
end;

procedure Randomize;
begin
  CryptAcquireContext(hCryptProv, UserName, nil, PROV_RSA_FULL, 0);
end;

begin
  Randomize;
  for i := 0 to 9 do
    Writeln(Random);
  Readln;
end.

demonstrate how to generate a random 32-bit number using a system's built-in mechanism, not relying solely on a software algorithm like /dev/urandom devices in Unix.


program TopAndTail;

{$APPTYPE CONSOLE}

const
  TEST_STRING = '1234567890';
begin
  Writeln(TEST_STRING);                                    // full string
  Writeln(Copy(TEST_STRING, 2, Length(TEST_STRING)));      // first character removed
  Writeln(Copy(TEST_STRING, 1, Length(TEST_STRING) - 1));  // last character removed
  Writeln(Copy(TEST_STRING, 2, Length(TEST_STRING) - 2));  // first and last characters removed

  Readln;
end.

The code demonstrates how to remove the first, last, and both the first and last characters from a string. It works with any valid Unicode code point in UTF-8 or UTF-16, referencing logical characters, not code units. It doesn't necessarily support all Unicode characters for other encodings like 8-bit ASCII or EUC-JP.


program OneInstance;

{$APPTYPE CONSOLE}

uses SysUtils, Windows;

var
  FMutex: THandle;
begin
  FMutex := CreateMutex(nil, True, 'OneInstanceMutex');
  if FMutex = 0 then
    RaiseLastOSError
  else
  begin
    try
      if GetLastError = ERROR_ALREADY_EXISTS then
        Writeln('Program already running.  Closing...')
      else
      begin
        // do stuff ...
        Readln;
      end;
    finally
      CloseHandle(FMutex);
    end;
  end;
end.

"Check if an application instance is already running, display a message if so, and terminate the program."


Library:  Winapi.Windows
Library:  System.SysUtils
Library:  Vcl.Forms
unit Main;

interface

uses
  Winapi.Windows, System.SysUtils, Vcl.Forms;

type
  TForm1 = class(TForm)
    procedure FormCreate(Sender: TObject);
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.FormCreate(Sender: TObject);
var
 w,h:Integer;
begin
  w := Screen.Monitors[0].WorkareaRect.Width;
  h := Screen.Monitors[0].WorkareaRect.Height;
  Caption:= format('%d x %d',[w,h]);
  SetBounds(0,0,w,h);
end;

end.

object Form1: TForm1
  OnCreate = FormCreate
end

determine the maximum height and width of a window that can fit within the physical display area of the screen without scrolling, considering multiple monitors and tiling window managers.


type
  TIntArray = array of Integer;

  { TSudokuSolver }

  TSudokuSolver = class
  private
    FGrid: TIntArray;

    function CheckValidity(val: Integer; x: Integer; y: Integer): Boolean;
    function ToString: string; reintroduce;
    function PlaceNumber(pos: Integer): Boolean;
  public
    constructor Create(s: string);

    procedure Solve;
  end;

implementation

uses
  Dialogs;

{ TSudokuSolver }

function TSudokuSolver.CheckValidity(val: Integer; x: Integer; y: Integer
  ): Boolean;
var
  i: Integer;
  j: Integer;
  StartX: Integer;
  StartY: Integer;
begin
  for i := 0 to 8 do
  begin
    if (FGrid[y * 9 + i] = val) or
       (FGrid[i * 9 + x] = val) then
    begin
      Result := False;
      Exit;
    end;
  end;
  StartX := (x div 3) * 3;
  StartY := (y div 3) * 3;
  for i := StartY to Pred(StartY + 3) do
  begin
    for j := StartX to Pred(StartX + 3) do
    begin
      if FGrid[i * 9 + j] = val then
      begin
        Result := False;
        Exit;
      end;
    end;
  end;
  Result := True;
end;

function TSudokuSolver.ToString: string;
var
  sb: string;
  i: Integer;
  j: Integer;
  c: char;
begin
  sb := '';
  for i := 0 to 8 do
  begin
    for j := 0 to 8 do
    begin
      c := (IntToStr(FGrid[i * 9 + j]) + '0')[1];
      sb := sb + c + ' ';
      if (j = 2) or (j = 5) then sb := sb + '| ';
    end;
    sb := sb + #13#10;
    if (i = 2) or (i = 5) then
      sb := sb + '-----+-----+-----' + #13#10;
  end;
  Result := sb;
end;

function TSudokuSolver.PlaceNumber(pos: Integer): Boolean;
var
  n: Integer;
begin
  Result := False;
  if Pos = 81 then
  begin
    Result := True;
    Exit;
  end;
  if FGrid[pos] > 0 then
  begin
    Result := PlaceNumber(Succ(pos));
    Exit;
  end;
  for n := 1 to 9 do
  begin
    if CheckValidity(n, pos mod 9, pos div 9) then
    begin
      FGrid[pos] := n;
      Result := PlaceNumber(Succ(pos));
      if not Result then
        FGrid[pos] := 0;
    end;
  end;
end;

constructor TSudokuSolver.Create(s: string);
var
  lcv: Cardinal;
begin
  SetLength(FGrid, 81);
  for lcv := 0 to Pred(Length(s)) do
    FGrid[lcv] := StrToInt(s[Succ(lcv)]);
end;

procedure TSudokuSolver.Solve;
begin
  if not PlaceNumber(0) then
    ShowMessage('Unsolvable')
  else
    ShowMessage('Solved!');
  end;
end;

var
  SudokuSolver: TSudokuSolver;
begin
  SudokuSolver := TSudokuSolver.Create('850002400' +
                                       '720000009' +
                                       '004000000' +
                                       '000107002' +
                                       '305000900' +
                                       '040000000' +
                                       '000080070' +
                                       '017000000' +
                                       '000036040');
  try
    SudokuSolver.Solve;
  finally
    FreeAndNil(SudokuSolver);
  end;
end;

"Code implements a Sudoku solver for a 9x9 grid. It takes a partially filled grid as input and displays the solved Sudoku in a human-readable format. The solution is based on the Algorithmics of Sudoku and Python Sudoku Solver Computerphile video."


implement the Knuth shuffle algorithm, also known as the Fisher-Yates shuffle. This algorithm shuffles the elements of an array randomly. It works by iterating through the array from the last element to the first, and for each element, it swaps it with a random element in the range from the first element to the current one. The algorithm modifies the input array in-place, but can be adjusted to return a new array or iterate from left to right if necessary.


program LastFridayOfMonth;

{$APPTYPE CONSOLE}

uses
  System.SysUtils, System.DateUtils;

var
  Year: Word;
  Month: Word;
  D1: TDateTime;
  D2: Word;

begin
  Write('Enter year: ');
  ReadLn(Year);

  for Month := MonthJanuary to MonthDecember do begin
    D1 := EndOfAMonth(Year, Month);
    D2 := DayOfTheWeek(D1);
    while D2 <> DayFriday do begin
      D1 := IncDay(D1, -1);
      D2 := DayOfTheWeek(D1);
    end;
    WriteLn(DateToStr(D1));
  end;
end.

The code takes a year as input and returns the dates of the last Fridays of each month for that given year. The year can be inputted through any simple method such as command line or standard input. The code uses the standard Delphi library.


program Project1;

{$APPTYPE CONSOLE}

begin
  Write('Goodbye, World!');
end.

"Display the string 'Goodbye, World!' without appending a newline at the end."


program UserInputGraphical;

{$APPTYPE CONSOLE}

uses SysUtils, Dialogs;

var
  s: string;
  lStringValue: string;
  lIntegerValue: Integer;
begin
  lStringValue := InputBox('User input/Graphical', 'Enter a string', '');

  repeat
    s := InputBox('User input/Graphical', 'Enter the number 75000', '75000');
    lIntegerValue := StrToIntDef(s, 0);
    if lIntegerValue <> 75000 then
      ShowMessage('Invalid entry: ' + s);
  until lIntegerValue = 75000;
end.

"Implement functionality to accept a string and the integer 75000 as inputs from a graphical user interface."


implement a Caesar cipher for both encoding and decoding. The cipher uses a key ranging from 1 to 25 to rotate the letters of the alphabet, replacing each letter with the next 1st to 25th letter. The cipher is identical to Vigenère cipher with a key of length 1 and Rot-13 with key 13. However, it provides almost no security as the encoded message can be easily decrypted.


calculate the least common multiple (LCM) of two integers m and n. The LCM is the smallest positive integer that has both m and n as factors. It also handles the special case where if either m or n is zero, the LCM is zero. The LCM can be calculated by iterating all the multiples of m until one is found that is also a multiple of n, or by using the formula lcm(m, n) = |m × n| / gcd(m, n), where gcd is the greatest common divisor. Additionally, the LCM can be found by merging the prime decompositions of both m and n.


Works with: Delphi version 6.0
Library: SysUtils,StdCtrls

type TCUSIPInfo = record
 ID,Company: string;
 end;

var CUSIPArray: array [0..5] of TCUSIPInfo = (
  (ID:'037833100'; Company: 'Apple Incorporated'),
  (ID:'17275R102'; Company: 'Cisco Systems'),
  (ID:'38259P508'; Company: 'Google Incorporated'),
  (ID:'594918104'; Company: 'Microsoft Corporation'),
  (ID:'68389X106'; Company: 'Oracle Corporation'),
  (ID:'68389X105'; Company: 'Oracle Corporation'));

function IsValidCUSIP(Info: TCUSIPInfo): boolean;
{Calculate checksum on first 7 chars of CUSIP }
{And compare with the last char - the checksum char}
var I,V,Sum: integer;
var C: char;
begin
Sum:=0;
for I:=1 to Length(Info.ID)-1 do
	begin
	C:=Info.ID[I];
	if C in ['0'..'9'] then V:=byte(C)-$30
	else if C in ['A'..'Z'] then V:=(byte(C)-$40) + 9
	else case C of
	 '*': V:=36;
	 '@': V:=37;
	 '#': V:=38;
	 end;
	if (I and 1)=0 then V:=V*2;
	Sum:=Sum + (V div 10) + (V mod 10);
	end;
Sum:=(10 - (Sum mod 10)) mod 10;
Result:=StrToInt(Info.ID[Length(Info.ID)])=Sum;
end;

procedure TestCUSIPList(Memo: TMemo);
{Test every item in the CSUIP array}
var I: integer;
var S: string;
begin
for I:=0 to High(CUSIPArray) do
	begin
	if IsValidCUSIP(CUSIPArray[I]) then S:='Valid' else S:='Invalid';
	Memo.Lines.Add(CUSIPArray[I].ID+'	'+CUSIPArray[I].Company+':	'+S);
	end;
end;

The code verifies the correctness of the last digit (check digit) of a CUSIP code, which is a nine-character alphanumeric code used to identify North American financial securities. The code uses an algorithm that takes an 8-character CUSIP as input, calculates a sum based on the numeric value or ordinal position of each character, and returns the result of a specific calculation involving this sum. The correctness of the check digit is then assessed against this result. The code is designed to facilitate the clearing and settlement of trades.


program HostIntrospection ;

{$APPTYPE CONSOLE}

uses SysUtils;

begin
  Writeln('word size: ', SizeOf(Integer));
  Writeln('endianness: little endian'); // Windows is always little endian
end.

"Outputs the word size and endianness of the host machine."


Library:  System.SysUtils
Library:  System.Classes
Library:  IdHttp
Library:  IdBaseComponent
Library:  IdComponent
Library:  IdIOHandler
Library:  IdIOHandlerSocket
Library:  IdIOHandlerStack
Library:  IdSSL
Library:  IdSSLOpenSSL
Library:  System.RegularExpressions
Library:  System.Generics.Collections
Library:  System.Generics.Defaults

program Rank_languages_by_popularity;

{$APPTYPE CONSOLE}

{$R *.res}

uses
  System.SysUtils,
  System.Classes,
  IdHttp,
  IdBaseComponent,
  IdComponent,
  IdIOHandler,
  IdIOHandlerSocket,
  IdIOHandlerStack,
  IdSSL,
  IdSSLOpenSSL,
  System.RegularExpressions,
  System.Generics.Collections,
  System.Generics.Defaults;

const
  AURL = 'https://www.rosettacode.org/mw/index.php?title=Special:Categories&limit=5000';
  UserAgent =
    'Mozilla/5.0 (Windows NT 10.0; Win64; x64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/74.0.3729.169 Safari/537.36';

type
  TPair = record
    Language: string;
    Users: Integer;
    constructor Create(lang, user: string);
  end;

  TPairs = TList<TPair>;

  { TPair }

constructor TPair.Create(lang, user: string);
begin
  Language := lang;
  Users := StrToIntDef(user, 0);
end;

function GetFullCode: string;
begin
  with TIdHttp.create(nil) do
  begin
    HandleRedirects := True;
    Request.UserAgent := UserAgent;
    IOHandler := TIdSSLIOHandlerSocketOpenSSL.Create(nil);
    Result := Get(AURL);
    IOHandler.Free;
    Free;
  end;
end;

function GetList(const Code: string): TPairs;
var
  RegularExpression: TRegEx;
  Match: TMatch;
  language, users: string;
begin
  Result := TPairs.Create;

  RegularExpression.Create('>(?<LANG>[^<,;]*)<\/a>.. \((?<USERS>[,\d]*)');
  Match := RegularExpression.Match(Code);

  while Match.Success do
  begin
    users := Match.Groups.Item['USERS'].Value.Replace(',', '');
    language := Match.Groups.Item['LANG'].Value;

    Result.Add(TPair.Create(language, users));
    Match := Match.NextMatch;
  end;
end;

procedure Sort(List: TPairs);
begin
  List.Sort(TComparer<TPair>.Construct(
    function(const Left, Right: TPair): Integer
    begin
      result := Right.Users - Left.Users;
      if result = 0 then
        result := CompareText(Left.Language, Right.Language);
    end));
end;

function SumUsers(List: TPairs): Cardinal;
var
  p: TPair;
begin
  Result := 0;
  for p in List do
  begin
    Inc(Result, p.Users);
  end;
end;

var
  Data: TStringList;
  Code, line: string;
  List: TPairs;
  i: Integer;

begin
  Data := TStringList.Create;
  Writeln('Downloading code...');

  Code := GetFullCode;
  data.Clear;

  List := GetList(Code);

  Sort(List);

  Writeln('Total languages: ', List.Count);
  Writeln('Total Users: ', SumUsers(List));
  Writeln('Top 10:'#10);

  for i := 0 to List.Count - 1 do
  begin
    line := Format('%5dth %5d %s', [i + 1, List[i].users, List[i].language]);
    Data.Add(line);
    if i < 10 then
      Writeln(line);
  end;

  Data.SaveToFile('Rank.txt');
  List.Free;
  Data.Free;

  Readln;
end.

Output (as of Jul 27, 2020):
Downloading code...
Total languages: 3267
Total Users: 96532
Top 10:

    1th  1261 Go
    2th  1228 Phix
    3th  1221 Julia
    4th  1210 Raku
    5th  1148 Python
    6th  1139 Perl
    7th  1090 Kotlin
    8th  1053 C
    9th  1052 Java
   10th  1051 Racket

The code sorts the most popular computer programming languages based on the number of members in Rosetta Code categories. It uses either web scraping or API methods to access the data. The code also has an optional feature to filter incorrect results. The results can be checked against a complete, accurate, sortable, wikitable listing of all programming languages. For safe execution, the code requires the dlls: libeay32.dll & ssleay32.dll in the executable path.


program LoopForEach;

{$APPTYPE CONSOLE}

var
  s: string;
begin
  for s in 'Hello' do
    Writeln(s);
end.

H
e
l
l
o

utilize a "for each" loop or an alternative loop to iterate through and print each element in a collection in order. The codes support arrays (single, multidimensional, and dynamic), sets, strings, collections and any class or interface that implements GetEnumerator(), using for..in loops introduced in Delphi 2005.


Using String.split[edit]
Library:  System.SysUtils
program Tokenize_a_string;

{$APPTYPE CONSOLE}

uses
  System.SysUtils;

var
  Words: TArray<string>;

begin
  Words := 'Hello,How,Are,You,Today'.Split([',']);
  Writeln(string.Join(#10, Words));

  Readln;
end.

Using TStringList[edit]
program TokenizeString;

{$APPTYPE CONSOLE}

uses
  Classes;

var
  tmp: TStringList;
  i: Integer;

begin

  // Instantiate TStringList class
  tmp := TStringList.Create;
  try
    { Use the TStringList's CommaText property to get/set
      all the strings in a single comma-delimited string }
    tmp.CommaText := 'Hello,How,Are,You,Today';

    { Now loop through the TStringList and display each
      token on the console }
    for i := 0 to Pred(tmp.Count) do
      Writeln(tmp[i]);

  finally
    tmp.Free;
  end;

  Readln;

end.

Hello
How
Are
You
Today

"Tokenizes a string by separating it by commas into an array, then displays the words to the user separated by a period, including a trailing period."


finds the greatest common divisor (GCD), also known as greatest common factor (gcf) or greatest common measure, of two integers. It is related to the task of finding the least common multiple. For more information, refer to the MathWorld and Wikipedia entries on greatest common divisor. The code is written in Pascal/Delphi/Free Pascal.


program EchoServer;

{$APPTYPE CONSOLE}

uses SysUtils, IdContext, IdTCPServer;

type
  TEchoServer = class
  private
    FTCPServer: TIdTCPServer;
  public
    constructor Create;
    destructor Destroy; override;
    procedure TCPServerExecute(AContext: TIdContext);
  end;

constructor TEchoServer.Create;
begin
  FTCPServer := TIdTCPServer.Create(nil);
  FTCPServer.DefaultPort := 12321;
  FTCPServer.OnExecute := TCPServerExecute;
  FTCPServer.Active := True;
end;

destructor TEchoServer.Destroy;
begin
  FTCPServer.Active := False;
  FTCPServer.Free;
  inherited Destroy;
end;

procedure TEchoServer.TCPServerExecute(AContext: TIdContext);
var
  lCmdLine: string;
begin
  lCmdLine := AContext.Connection.IOHandler.ReadLn;
  Writeln('>' + lCmdLine);
  AContext.Connection.IOHandler.Writeln('>' + lCmdLine);

  if SameText(lCmdLine, 'QUIT') then
  begin
    AContext.Connection.IOHandler.Writeln('Disconnecting');
    AContext.Connection.Disconnect;
  end;
end;

var
  lEchoServer: TEchoServer;
begin
  lEchoServer := TEchoServer.Create;
  try
    Writeln('Delphi Echo Server');
    Writeln('Press Enter to quit');
    Readln;
  finally
    lEchoServer.Free;
  end;
end.

Implement an echo server that listens on TCP port 12321, accepts and handles multiple simultaneous connections from localhost, echoes complete lines back to clients, and logs connection information. The server remains responsive even if a client sends a partial line or stops reading responses.


function IsNumericString(const inStr: string): Boolean;
var
  i: extended;
begin
  Result := TryStrToFloat(inStr,i);
end;

program isNumeric;

{$APPTYPE CONSOLE}

uses
  Classes,
  SysUtils;

function IsNumericString(const inStr: string): Boolean;
var
  i: extended;
begin
  Result := TryStrToFloat(inStr,i);
end;

{ Test function }
var
  s: string;
  c: Integer;

const
  MAX_TRIES = 10;
  sPROMPT   = 'Enter a string (or type "quit" to exit):';
  sIS       = ' is numeric';
  sISNOT    = ' is NOT numeric';

begin
  c := 0;
  s := '';
  repeat
    Inc(c);
    Writeln(sPROMPT);
    Readln(s);
    if (s <> '') then
      begin
        tmp.Add(s);
        if IsNumericString(s) then
          begin
            Writeln(s+sIS);
          end
          else
          begin
            Writeln(s+sISNOT);
          end;
        Writeln('');
      end;
  until
    (c >= MAX_TRIES) or (LowerCase(s) = 'quit');

end.

"Implements a boolean function in Delphi that checks if a given string is a numeric string, including floating point and negative numbers. The function is tested in a console application."


Library: OpenSSL
program ShowHTTPS;

{$APPTYPE CONSOLE}

uses IdHttp, IdSSLOpenSSL;

var
  s: string;
  lHTTP: TIdHTTP;
begin
  lHTTP := TIdHTTP.Create(nil);
  try
    lHTTP.IOHandler := TIdSSLIOHandlerSocketOpenSSL.Create(lHTTP);
    lHTTP.HandleRedirects := True;
    s := lHTTP.Get('https://sourceforge.net/');
    Writeln(s);
  finally
    lHTTP.Free;
  end;
end.

Send a GET request to the URL "https://www.w3.org/", validate the host certificate, and print the obtained resource to the console without any authentication.


Works with: Delphi version 6.0
Library: SysUtils,StdCtrls

procedure ShowTrigFunctions(Memo: TMemo);
const AngleDeg = 45.0;
var AngleRad,ArcSine,ArcCosine,ArcTangent: double;
begin
AngleRad:=DegToRad(AngleDeg);

Memo.Lines.Add(Format('Angle:      Degrees: %3.5f   Radians: %3.6f',[AngleDeg,AngleRad]));
Memo.Lines.Add('-------------------------------------------------');
Memo.Lines.Add(Format('Sine:       Degrees: %3.6f   Radians: %3.6f',[sin(DegToRad(AngleDeg)),sin(AngleRad)]));
Memo.Lines.Add(Format('Cosine:     Degrees: %3.6f   Radians: %3.6f',[cos(DegToRad(AngleDeg)),cos(AngleRad)]));
Memo.Lines.Add(Format('Tangent:    Degrees: %3.6f   Radians: %3.6f',[tan(DegToRad(AngleDeg)),tan(AngleRad)]));
ArcSine:=ArcSin(Sin(AngleRad));
Memo.Lines.Add(Format('Arcsine:    Degrees: %3.6f   Radians: %3.6f',[DegToRad(ArcSine),ArcSine]));
ArcCosine:=ArcCos(cos(AngleRad));
Memo.Lines.Add(Format('Arccosine:  Degrees: %3.6f   Radians: %3.6f',[DegToRad(ArcCosine),ArcCosine]));
ArcTangent:=ArcTan(tan(AngleRad));
Memo.Lines.Add(Format('Arctangent: Degrees: %3.6f   Radians: %3.6f',[DegToRad(ArcTangent),ArcTangent]));
end;

demonstrate the usage of trigonometric functions (sine, cosine, tangent, and their inverses) in a given programming language, using the same angle in both radians and degrees. The codes also include the conversion of results for inverse functions to radians and degrees. If the language lacks built-in trigonometric functions, the codes provide custom functions based on known approximations or identities.


program IncrementNumericalString;

{$APPTYPE CONSOLE}

uses SysUtils;

const
  STRING_VALUE = '12345';
begin
  WriteLn(Format('"%s" + 1 = %d', [STRING_VALUE, StrToInt(STRING_VALUE) + 1]));

  Readln;
end.


Library:  System.SysUtils
program Find_common_directory_path;

{$APPTYPE CONSOLE}

uses
  System.SysUtils;

function FindCommonPath(Separator: Char; Paths: TArray<string>): string;
var
  SeparatedPath: array of TArray<string>;
  minLength, index: Integer;
  isSame: Boolean;
  j, i: Integer;
  cmp: string;
begin
  SetLength(SeparatedPath, length(Paths));
  minLength := MaxInt;
  for i := 0 to High(SeparatedPath) do
  begin
    SeparatedPath[i] := Paths[i].Split([Separator]);
    if minLength > length(SeparatedPath[i]) then
      minLength := length(SeparatedPath[i]);
  end;

  index := -1;

  for i := 0 to minLength - 1 do
  begin
    isSame := True;
    cmp := SeparatedPath[0][i];
    for j := 1 to High(SeparatedPath) do
      if SeparatedPath[j][i] <> cmp then
      begin
        isSame := False;
        Break;
      end;
    if not isSame then
    begin
      index := i - 1;
      Break;
    end;
  end;

  Result := '';
  if index >= 0 then
    for i := 0 to index do
    begin
      Result := Result + SeparatedPath[0][i];
      if i < index then
        Result := Result + Separator;
    end;
end;

begin
  Writeln(FindCommonPath('/', [
    '/home/user1/tmp/coverage/test',
    '/home/user1/tmp/covert/operator',
    '/home/user1/tmp/coven/members']));
  Readln;
end.

The code finds the common directory path from a given set of directory paths using a specified directory separator character. It tests the functionality using '/' as the directory separator and three specific strings as input paths. The code ensures the returned path is a valid directory, not just the longest common string.


Works with: Delphi version 6.0
Library: SysUtils,StdCtrls

procedure DoSattoloCycle(var IA: array of integer);
{Shuffle integers in array using Sattolo cycle}
var I,J,T: integer;
begin
{Make sure random number generator is random}
Randomize;
{Randomly shuffle every item in the array}
for I:=High(IA) downto 0 do
	begin
	J:=Random(I);
	T:=IA[I]; IA[I]:=IA[J]; IA[J]:=T;
	end;
end;

{Test data specified in problem}

var SatTest1: array of integer;
var SatTest2: array [0..0] of integer = (10);
var SatTest3: array [0..1] of integer = (10, 20);
var SatTest4: array [0..2] of integer = (10, 20, 30);
var SatTest5: array [0..11] of integer = (11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22);

procedure ShowSattoloCycle(Memo: TMemo);

	procedure ShowIntArray(Title: string; IA: array of integer);
	{Display title and array}
	var I: integer;
	var S: string;
	begin
	S:=Title+' [';
	for I:=0 to High(IA) do
		begin
		if I<>0 then S:=S+' ';
		S:=S+IntToStr(IA[I]);
		end;
	S:=S+']';
	Memo.Lines.Add(S);
	end;

	procedure ShowShuffleData(var IA: array of integer);
	{Shuffle and display specified array}
	begin
	ShowIntArray('Original data:', IA);
	DoSattoloCycle(IA);
	ShowIntArray('Shuffled data:',IA);
	end;

begin
{Shuffle and display all data items}
ShowShuffleData(SatTest1);
ShowShuffleData(SatTest2);
ShowShuffleData(SatTest3);
ShowShuffleData(SatTest4);
ShowShuffleData(SatTest5);
end;

implement the Sattolo cycle algorithm to randomly shuffle an array ensuring each element is in a new position. The algorithm modifies the input array in-place or returns a new shuffled array. It differs from the Knuth shuffle by choosing a random integer from a range ensuring each element ends up in a new position.


program AveragesMedian;

{$APPTYPE CONSOLE}

uses Generics.Collections, Types;

function Median(aArray: TDoubleDynArray): Double;
var
  lMiddleIndex: Integer;
begin
  TArray.Sort<Double>(aArray);

  lMiddleIndex := Length(aArray) div 2;
  if Odd(Length(aArray)) then
    Result := aArray[lMiddleIndex]
  else
    Result := (aArray[lMiddleIndex - 1] + aArray[lMiddleIndex]) / 2;
end;

begin
  Writeln(Median(TDoubleDynArray.Create(4.1, 5.6, 7.2, 1.7, 9.3, 4.4, 3.2)));
  Writeln(Median(TDoubleDynArray.Create(4.1, 7.2, 1.7, 9.3, 4.4, 3.2)));
end.

The code calculates the median value of a vector of floating-point numbers. It handles even number of elements by returning the average of the two middle values. The median is found using the selection algorithm for optimal time complexity. The code also includes tasks for calculating various statistical measures like mean, mode, and standard deviation. It also calculates moving (sliding window and cumulative) averages and different types of means such as arithmetic, geometric, harmonic, quadratic, and circular.


program FizzBuzz;

{$APPTYPE CONSOLE}

uses SysUtils;

var
  i: Integer;
begin
  for i := 1 to 100 do
  begin
    if i mod 15 = 0 then
      Writeln('FizzBuzz')
    else if i mod 3 = 0 then
      Writeln('Fizz')
    else if i mod 5 = 0 then
      Writeln('Buzz')
    else
      Writeln(i);
  end;
end.

print numbers from 1 to 100, replacing multiples of three with 'Fizz', multiples of five with 'Buzz', and multiples of both three and five with 'FizzBuzz'.


generate and draw the Mandelbrot set using various available algorithms and functions.


program SumAndProductOfArray;

{$APPTYPE CONSOLE}

var
  i: integer;
  lIntArray: array [1 .. 5] of integer = (1, 2, 3, 4, 5);
  lSum: integer = 0;
  lProduct: integer = 1;
begin
  for i := 1 to length(lIntArray) do
  begin
    Inc(lSum, lIntArray[i]);
    lProduct := lProduct * lIntArray[i]
  end;

  Write('Sum: ');
  Writeln(lSum);
  Write('Product: ');
  Writeln(lProduct);
end.

Calculate the sum and product of all integers in an array.


Library:  System.SysUtils
Library:  System.Classes
Translation of: Go
program MD5Implementation;

{$APPTYPE CONSOLE}

uses
  System.SysUtils,
  System.Classes;

type
  TTestCase = record
    hashCode: string;
    _: string;
  end;

var
  testCases: array[0..6] of TTestCase = ((
    hashCode: 'D41D8CD98F00B204E9800998ECF8427E';
    _: ''
  ), (
    hashCode: '0CC175B9C0F1B6A831C399E269772661';
    _: 'a'
  ), (
    hashCode: '900150983CD24FB0D6963F7D28E17F72';
    _: 'abc'
  ), (
    hashCode: 'F96B697D7CB7938D525A2F31AAF161D0';
    _: 'message digest'
  ), (
    hashCode: 'C3FCD3D76192E4007DFB496CCA67E13B';
    _: 'abcdefghijklmnopqrstuvwxyz'
  ), (
    hashCode: 'D174AB98D277D9F5A5611C2C9F419D9F';
    _: 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789'
  ), (
    hashCode: '57EDF4A22BE3C955AC49DA2E2107B67A';
    _: '12345678901234567890123456789' + '012345678901234567890123456789012345678901234567890'
  ));
  shift: array of UInt32 = [7, 12, 17, 22, 5, 9, 14, 20, 4, 11, 16, 23, 6, 10, 15, 21];
  table: array[0..63] of UInt32;

procedure Init();
var
  i: integer;

  function fAbs(x: Extended): Extended;
  begin
    if x < 0 then
      exit(-x);
    exit(x);
  end;

begin
  for i := 0 to High(table) do
    table[i] := Trunc((UInt64(1) shl 32) * fAbs(Sin(i + 1.0)));
end;

function Md5(s: string): TBytes;
const
  BUFFER_SIZE = 16;
var
  binary: TBytesStream;
  buffer: Tarray<UInt32>;
  messageLenBits: UInt64;
  i, j, bufferIndex, count: integer;
  byte_data: byte;
  string_data: ansistring;
  k, k1: Tarray<UInt32>;
  f, rnd, sa: UInt32;
  tmp: UInt64;
begin
  k := [$67452301, $EFCDAB89, $98BADCFE, $10325476];

  binary := TBytesStream.Create();

  if not s.IsEmpty then
  begin
    string_data := Utf8ToAnsi(s);
    binary.Write(Tbytes(string_data), length(string_data));
  end;

  byte_data := $80;
  binary.Write(byte_data, 1);

  messageLenBits := UInt64(s.Length * 8);
  count := s.Length + 1;

  while (count mod 64) <> 56 do
  begin
    byte_data := $00;
    binary.Write(byte_data, 1);
    inc(count);
  end;

  binary.Write(messageLenBits, sizeof(messageLenBits));

  SetLength(buffer, BUFFER_SIZE);
  SetLength(k1, length(k));

  binary.Seek(0, soFromBeginning);

  while binary.Read(buffer[0], BUFFER_SIZE * 4) > 0 do
  begin
    for i := 0 to 3 do
      k1[i] := k[i];

    for i := 0 to 63 do
    begin
      f := 0;
      bufferIndex := i;
      rnd := i shr 4;
      case rnd of
        0:
          f := (k1[1] and k1[2]) or (not k1[1] and k1[3]);
        1:
          begin
            f := (k1[1] and k1[3]) or (k1[2] and not k1[3]);
            bufferIndex := (bufferIndex * 5 + 1) and $0F
          end;
        2:
          begin
            f := k1[1] xor k1[2] xor k1[3];
            bufferIndex := (bufferIndex * 3 + 5) and $0F;
          end;
        3:
          begin
            f := k1[2] xor (k1[1] or not k1[3]);
            bufferIndex := (bufferIndex * 7) and $0F;
          end;
      end;

      sa := shift[(rnd shl 2) or (i and 3)];

      k1[0] := k1[0] + f + buffer[bufferIndex] + table[i];

      tmp := k1[0];

      k1[0] := k1[3];
      k1[3] := k1[2];
      k1[2] := k1[1];

      k1[1] := ((tmp shl sa) or (tmp shr (32 - sa))) + k1[1];
    end;

    for i := 0 to 3 do
      k[i] := k[i] + k1[i];
  end;

  SetLength(result, BUFFER_SIZE);

  binary.Clear;
  for i := 0 to 3 do
    binary.Write(k[i], 4);

  binary.Seek(0, soBeginning);

  binary.Read(Result, BUFFER_SIZE);

  binary.Free;
end;

function BytesToString(b: TBytes): string;
var
  v: byte;
begin
  Result := '';
  for v in b do
    Result := Result + v.ToHexString(2);
end;

var
  tc: TTestCase;

begin
  Init;

  for tc in testCases do
    Writeln(Format('%s'#10'%s'#10, [tc.hashCode, BytesToString(md5(tc._))]));
  Readln;
end.

The code is an implementation of the MD5 Message Digest Algorithm, developed directly from the algorithm specification without using built-in or external hashing libraries. It produces a correct message digest for an input string but does not mimic all calling modes. The code also includes handling of bit manipulation, unsigned integers, and little-endian data, with attention to details like boundary conditions and padding. The implementation is validated against the verification strings and hashes from RFC 1321.


Library:  System.SysUtils
Translation of: Go
program Department_numbers;

{$APPTYPE CONSOLE}

uses
  System.SysUtils;

var
  i, j, k, count: Integer;

begin
  writeln('Police  Sanitation  Fire');
  writeln('------  ----------  ----');
  count := 0;
  i := 2;
  while i < 7 do
  begin
    for j := 1 to 7 do
    begin
      if j = i then
        Continue;
      for k := 1 to 7 do
      begin
        if (k = i) or (k = j) then
          Continue;
        if i + j + k <> 12 then
          Continue;
        writeln(format('  %d         %d         %d', [i, j, k]));
        inc(count);
      end;
    end;
    inc(i, 2);
  end;
  writeln(#10, count, ' valid combinations');
  readln;
end.

all possible combinations of unique numbers between 1 and 7 (inclusive) for three different departments (police, sanitation, fire) that add up to 12, with the police department number being an even number.


program CopyString;

{$APPTYPE CONSOLE}

var
  s1: string;
  s2: string;
begin
  s1 := 'Goodbye';
  s2 := s1; // S2 points at the same string as S1
  s2 := s2 + ', World!'; // A new string is created for S2

  Writeln(s1);
  Writeln(s2);
end.

implement the functionality of copying a string in Delphi, differentiating between copying the string's contents and creating an additional reference to the existing string, utilizing the reference counting with copy on write semantics feature of Delphi strings.


unit Hofstadter;

interface

type
  THofstadterFemaleMaleSequences = class
  public
    class function F(n: Integer): Integer;
    class function M(n: Integer): Integer;
  end;

implementation

class function THofstadterFemaleMaleSequences.F(n: Integer): Integer;
begin
  Result:= 1;
  if (n > 0) then
    Result:= n - M(F(n-1));
end;

class function THofstadterFemaleMaleSequences.M(n: Integer): Integer;
begin
  Result:= 0;
  if (n > 0) then
    Result:= n - F(M(n - 1));
end;

end.

implement two mutually recursive functions to compute the Hofstadter Female and Male sequences. If the programming language does not support mutual recursion, it should be stated.


demonstrate how to select a random element from a list in Pascal/Delphi/Free Pascal.


program URLEncoding;

{$APPTYPE CONSOLE}

uses IdURI;

begin
  Writeln(TIdURI.URLDecode('http%3A%2F%2Ffoo%20bar%2F'));
end.

provide a function to convert URL-encoded strings back into their original unencoded form. It includes test cases for strings like "http%3A%2F%2Ffoo%20bar%2F", "google.com/search?q=%60Abdu%27l-Bah%C3%A1", and "%25%32%35".


The code implements a binary search algorithm, which divides a range of values into halves to find an unknown value. It includes both recursive and iterative versions of traditional binary search, leftmost insertion point, and rightmost insertion point algorithms. The code also handles potential overflow bugs. It returns the index of the found element or the insertion point if the element is not found. The code also prints whether the number was found in the array and its index if it was.


// The program name and the directory it was called from are in
// param[0] , so given the axample of myprogram -c "alpha beta" -h "gamma"

  for x := 0 to paramcount do
      writeln('param[',x,'] = ',param[x]);

// will yield ( assuming windows and the c drive as the only drive) :

//  param[0] = c:\myprogram
//  param[1] = -c
//  param[2] = alpha beta
//  param[3] = -h
//  param[4] = gamma

The code retrieves and prints the list of command-line arguments provided to the program, such as 'myprogram -c "alpha beta" -h "gamma"'. It also includes functionalities for intelligent parsing of these arguments.


Library:  Vcl.Forms
Library:  Vcl.Graphics
Library:  Vcl.ExtCtrls
Translation of: C#
unit main;

interface

uses
  Vcl.Forms, Vcl.Graphics, Vcl.ExtCtrls;

type
  TForm1 = class(TForm)
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
  private
    Timer: TTimer;
    angle, angleAccel, angleVelocity, dt: double;
    len: Integer;
    procedure Tick(Sender: TObject);
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.FormCreate(Sender: TObject);
begin
  Width := 200;
  Height := 200;
  DoubleBuffered := True;
  Timer := TTimer.Create(nil);
  Timer.Interval := 30;
  Timer.OnTimer := Tick;
  Caption := 'Pendulum';

  // initialize
  angle := PI / 2;
  angleAccel := 0;
  angleVelocity := 0;
  dt := 0.1;
  len := 50;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  Timer.Free;
end;

procedure TForm1.Tick(Sender: TObject);
const
  HalfPivot = 4;
  HalfBall = 7;
var
  anchorX, anchorY, ballX, ballY: Integer;
begin
  anchorX := Width div 2 - 12;
  anchorY := Height div 4;
  ballX := anchorX + Trunc(Sin(angle) * len);
  ballY := anchorY + Trunc(Cos(angle) * len);

  angleAccel := -9.81 / len * Sin(angle);
  angleVelocity := angleVelocity + angleAccel * dt;
  angle := angle + angleVelocity * dt;

  with canvas do
  begin
    Pen.Color := clBlack;

    with Brush do
    begin
      Style := bsSolid;
      Color := clWhite;
    end;

    FillRect(ClientRect);
    MoveTo(anchorX, anchorY);
    LineTo(ballX, ballY);

    Brush.Color := clGray;
    Ellipse(anchorX - HalfPivot, anchorY - HalfPivot, anchorX + HalfPivot,
      anchorY + HalfPivot);

    Brush.Color := clYellow;
    Ellipse(ballX - HalfBall, ballY - HalfBall, ballX + HalfBall, ballY + HalfBall);
  end;
end;

end.

create and animate a simple physical model of a gravity pendulum.


Translation of: C#
program JsonTest;

{$APPTYPE CONSOLE}

{$R *.res}

uses
  System.SysUtils,
  Json;

type
  TJsonObjectHelper = class helper for TJsonObject
  public
    class function Deserialize(data: string): TJsonObject; static;
    function Serialize: string;
  end;

{ TJsonObjectHelper }

class function TJsonObjectHelper.Deserialize(data: string): TJsonObject;
begin
  Result := TJSONObject.ParseJSONValue(data) as TJsonObject;
end;

function TJsonObjectHelper.Serialize: string;
begin
  Result := ToJson;
end;

var
  people, deserialized: TJsonObject;
  bar: TJsonArray;
  _json: string;

begin
  people := TJsonObject.Create();
  people.AddPair(TJsonPair.Create('1', 'John'));
  people.AddPair(TJsonPair.Create('2', 'Susan'));

  _json := people.Serialize;
  Writeln(_json);

  deserialized := TJSONObject.Deserialize(_json);
  Writeln(deserialized.Values['2'].Value);

  deserialized := TJSONObject.Deserialize('{"foo":1 , "bar":[10,"apples"]}');

  bar := deserialized.Values['bar'] as TJSONArray;
  Writeln(bar.Items[1].Value);

  deserialized.Free;
  people.Free;

  Readln;
end.

"Load a JSON string into a data structure, create a new data structure, serialize it into JSON, and validate the JSON."


USES
   Math;

function NthRoot(A, Precision: Double; n: Integer): Double;
var
   x_p, X: Double;
begin
   x_p := Sqrt(A);
   while Abs(A - Power(x_p, n)) > Precision do
   begin
      x := (1/n) * (((n-1) * x_p) + (A/(Power(x_p, n - 1))));
      x_p := x;
   end;
   Result := x_p;
end;

Implement the principal nth root algorithm for a positive real number A.


program ShowHostName;

{$APPTYPE CONSOLE}

uses Windows;

var
  lHostName: array[0..255] of char;
  lBufferSize: DWORD;
begin
  lBufferSize := 256;
  if GetComputerName(lHostName, lBufferSize) then
    Writeln(lHostName)
  else
    Writeln('error getting host name');
end.

"Determines and outputs the hostname of the current system where the routine is running."


Works with: Delphi version 6.0
Library: SysUtils,StdCtrls

type TIntArray = array of integer;

function GetLeonardoNumbers(Cnt,SN1,SN2,Add: integer): TIntArray;
var N: integer;
begin
SetLength(Result,Cnt);
Result[0]:=SN1; Result[1]:=SN2;
for N:=2 to Cnt-1 do
	begin
	Result[N]:=Result[N-1] + Result[N-2] + Add;
	end;
end;

procedure TestLeonardoNumbers(Memo: TMemo);
var IA: TIntArray;
var S: string;
var I: integer;
begin
Memo.Lines.Add('Leonardo Numbers:');
IA:=GetLeonardoNumbers(25,1,1,1);
S:='';
for I:=0 to High(IA) do
	begin
	S:=S+' '+Format('%6d',[IA[I]]);
	if I mod 5 = 4 then S:=S+#$0D#$0A;
	end;
Memo.Lines.Add(S);
Memo.Lines.Add('Fibonacci Numbers:');
IA:=GetLeonardoNumbers(25,0,1,0);
S:='';
for I:=0 to High(IA) do
	begin
	S:=S+' '+Format('%6d',[IA[I]]);
	if I mod 5 = 4 then S:=S+#$0D#$0A;
	end;
Memo.Lines.Add(S);
end;

The code calculates and displays the first 25 Leonardo numbers, starting from L(0). It allows customization of the first two Leonardo numbers (L(0) and L(1)) and the add number (default is 1). It also displays the first 25 Leonardo numbers when L(0) and L(1) are set to 0 and 1, and the add number is set to 0, which results in the Fibonacci sequence.