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.


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.

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."


PROGRAM EXRECURGCD.PAS;

{$IFDEF FPC}
    {$mode objfpc}{$H+}{$J-}{R+}
{$ELSE}
    {$APPTYPE CONSOLE}
{$ENDIF}

(*)
    Free Pascal Compiler version 3.2.0 [2020/06/14] for x86_64
    The free and readable alternative at C/C++ speeds
    compiles natively to almost any platform, including raspberry PI
(*)

FUNCTION gcd_recursive(u, v: longint): longint;

    BEGIN
        IF ( v = 0 ) THEN Exit ( u ) ;
        result := gcd_recursive ( v, u MOD v ) ;
    END;

BEGIN

    WriteLn ( gcd_recursive ( 231, 7 ) ) ;

END.

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'.


program mandelbrot;

  {$IFDEF FPC}
      {$MODE DELPHI}
  {$ENDIF}

const
   ixmax = 800;
   iymax = 800;
   cxmin = -2.5;
   cxmax =  1.5;
   cymin = -2.0;
   cymax =  2.0;
   maxcolorcomponentvalue = 255;
   maxiteration = 200;
   escaperadius = 2;

type
   colortype = record
      red   : byte;
      green : byte;
      blue  : byte;
   end;

var
   ix, iy      : integer;
   cx, cy      : real;
   pixelwidth  : real = (cxmax - cxmin) / ixmax;
   pixelheight : real = (cymax - cymin) / iymax;
   filename    : string = 'new1.ppm';
   comment     : string = '# ';
   outfile     : textfile;
   color       : colortype;
   zx, zy      : real;
   zx2, zy2    : real;
   iteration   : integer;
   er2         : real = (escaperadius * escaperadius);

begin
   {$I-}
   assign(outfile, filename);
   rewrite(outfile);
   if ioresult <> 0 then
   begin
      {$IFDEF FPC}
         writeln(stderr, 'Unable to open output file: ', filename);
      {$ELSE}
         writeln('ERROR: Unable to open output file: ', filename);
      {$ENDIF}
      exit;
   end;

   writeln(outfile, 'P6');
   writeln(outfile, ' ', comment);
   writeln(outfile, ' ', ixmax);
   writeln(outfile, ' ', iymax);
   writeln(outfile, ' ', maxcolorcomponentvalue);

   for iy := 1 to iymax do
   begin
      cy := cymin + (iy - 1)*pixelheight;
      if abs(cy) < pixelheight / 2 then cy := 0.0;
      for ix := 1 to ixmax do
      begin
         cx := cxmin + (ix - 1)*pixelwidth;
         zx := 0.0;
         zy := 0.0;
         zx2 := zx*zx;
         zy2 := zy*zy;
         iteration := 0;
         while (iteration < maxiteration) and (zx2 + zy2 < er2) do
         begin
            zy := 2*zx*zy + cy;
            zx := zx2 - zy2 + cx;
            zx2 := zx*zx;
            zy2 := zy*zy;
            iteration := iteration + 1;
         end;
         if iteration = maxiteration then
         begin
            color.red   := 0;
            color.green := 0;
            color.blue  := 0;
         end
         else
         begin
            color.red   := 255;
            color.green := 255;
            color.blue  := 255;
         end;
         write(outfile, chr(color.red), chr(color.green), chr(color.blue));
      end;
   end;

   close(outfile);
end.

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.Classesprogram 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.SysUtilsprogram 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.


Program PickRandomElement (output);

const
  s: array [1..5] of string = ('1234', 'ABCDE', 'Charlie', 'XB56ds', 'lala');

begin
  randomize;
  writeln(s[low(s) + random(length(s))]);
end.

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".


function binary_search(element: real; list: array of real): integer;
var
    l, m, h: integer;
begin
    l := Low(list);
    h := High(list);
    binary_search := -1;
    while l <= h do
    begin
        m := (l + h) div 2;
        if list[m] > element then
        begin
            h := m - 1;
        end
        else if list[m] < element then
        begin
            l := m + 1;
        end
        else
        begin
            binary_search := m;
            break;
        end;
    end;
end;

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.ExtCtrlsunit 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.


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.


Works with: Delphi version 6.0
Library: SysUtils,StdCtrls

var ErrorFlag: boolean;
var ErrorStr: string;

function EvaluateExpression(Express: string): double;
{ Recursive descent expression evaluator }
var Atom: char;
var ExpressStr: string;
var ExpressInx: integer;
const Tab_Char = #$09; SP_char = #$20;

	procedure HandleError(S: string);
	begin
	ErrorStr:=S;
	ErrorFlag:=True;
	Abort;
	end;

	procedure GetChar;
	begin
	if ExpressInx > Length(ExpressStr) then
		begin
		Atom:= ')';
		end
	 else	begin
		Atom:= ExpressStr[ExpressInx];
		Inc(ExpressInx);
		end;
	end;

	procedure SkipWhiteSpace;
	{ Skip Tabs And Spaces In Expression }
	begin
	while (Atom=TAB_Char) or (Atom=SP_char) do GetChar;
	end;

	procedure SkipSpaces;
	{ Get Next Character, Ignoring Any Space Characters }
	begin
	repeat GetChar until Atom <> SP_CHAR;
	end;

	function GetDecimal: integer;
	{ Read In A Decimal String And Return Its Value }
	var S: string;
	begin
	Result:=0;
	S:='';
	while True do
		begin
		if not (Atom in ['0'..'9']) then break;
		S:=S+Atom;
		GetChar;
		end;
	if S='' then HandleError('Number Expected')
	else Result:=StrToInt(S);
	if Result>9 then HandleError('Only Numbers 0..9 allowed')
	end;

	function Expression: double;
	{ Returns The Value Of An Expression }

		function Factor: double;
		{ Returns The Value Of A Factor }
		var NEG: boolean;
		begin
		Result:=0;
		while Atom='+' do SkipSpaces;		{ Ignore Unary "+" }
		NEG:= False;
		while Atom ='-' do			{ Unary "-" }
			begin
			SkipSpaces;
			NEG:= not NEG;
			end;

		if (Atom>='0') and (Atom<='9') then Result:= GetDecimal	{ Unsigned Integer }
		else case Atom of
		  '(':	begin				{ Subexpression }
			SkipSpaces;
			Result:= Expression;
			if Atom<>')' then HandleError('Mismatched Parenthesis');
			SkipSpaces;
			end;
		  else	HandleError('Syntax Error');
		  end;
		{ Numbers May Terminate With A Space Or Tab }
		SkipWhiteSpace;
		if NEG then Result:=-Result;
		end;	{ Factor }

		function Term: double;
		{ Returns Factor * Factor, Etc. }
		var R: double;
		begin
		Result:= Factor;
		while True do
			case Atom of
			  '*':	begin
			  	SkipSpaces;
			  	Result:= Result * Factor;
			  	end;
			  '/':	begin
			  	SkipSpaces;
			  	R:=Factor;
			  	if R=0 then HandleError('Divide By Zero');
			  	Result:= Result / R;
			  	end;
			  else	break;
			end;
		end;
		{ Term }

		function AlgebraicExpression: double;
		{ Returns Term + Term, Etc. }
		begin
		Result:= Term;
		while True do
			case Atom of
			  '+':	begin SkipSpaces; Result:= Result + Term; end;
			  '-':	begin SkipSpaces; Result:= Result - Term; end
			else	break;
			end;
		end; { Algexp }

	begin	{ Expression }
	SkipWhiteSpace;
	Result:= AlgebraicExpression;
	end;	{ Expression }

begin	{ EvaluateExpression }
ErrorFlag:=False;
ErrorStr:='';
ExpressStr:=Express;
ExpressInx:=1;
try
GetChar;
Result:= Expression;
except end;
end;

function WaitForString(Memo: TMemo; Prompt: string): string;
{Wait for key stroke on TMemo component}
var MW: TMemoWaiter;
var C: char;
var Y: integer;
begin
{Use custom object to wait and capture key strokes}
MW:=TMemoWaiter.Create(Memo);
try
Memo.Lines.Add(Prompt);
Memo.SelStart:=Memo.SelStart-1;
Memo.SetFocus;
Result:=MW.WaitForLine;
finally MW.Free; end;
end;

procedure Play24Game(Memo: TMemo);
{Play the 24 game}
var R: double;
var Nums: array [0..4-1] of char;
var I: integer;
var Express,RS: string;
var RB: boolean;

	procedure GenerateNumbers;
	{Generate and display four random number 1..9}
	var S: string;
	var I: integer;
	begin
	{Generate random numbers}
	for I:=0 to High(Nums) do
	 Nums[I]:=char(Random(9)+$31);
	{Display them}
	S:='';
	for I:=0 to High(Nums) do
	 S:=S+' '+Nums[I];
	Memo.Lines.Add('Your Digits: '+S);
	end;

	function TestMatchingNums: boolean;
	{Make sure numbers entered by user match the target numbers}
	var SL1,SL2: TStringList;
	var I: integer;
	begin
	Result:=False;
	SL1:=TStringList.Create;
	SL2:=TStringList.Create;
	try
	{Load target numbers into string list}
	for I:=0 to High(Nums) do SL1.Add(Nums[I]);
	{Load users expression number int string list}
	for I:=1 to Length(Express) do
	 if Express[I] in ['0'..'9'] then SL2.Add(Express[I]);
	{There should be the same number }
	if SL1.Count<>SL2.Count then exit;
	{Sort them to facilitate testing}
	SL1.Sort; SL2.Sort;
	{Are number identical, if not exit}
	for I:=0 to SL1.Count-1 do
	 if SL1[I]<>SL2[I] then exit;
	{Users numbers passed all tests}
	Result:=True;
	finally
	 SL2.Free;
	 SL1.Free;
	 end;
	end;

	function TestUserExpression(var S: string): boolean;
	{Test expression user entered }
	begin
	Result:=False;
	if not TestMatchingNums then
		begin
		S:='Numbers Do not Match';
		exit;
		end;

	R:=EvaluateExpression(Express);
	S:='Expression Value = '+FloatToStrF(R,ffFixed,18,0)+CRLF;
	if ErrorFlag then
		begin
		S:=S+'Expression Problem: '+ErrorStr;
		exit;
		end;
	if R<>24 then
		begin
		S:=S+'Expression is incorrect value';
		exit;
		end;
	S:=S+'!!!!!! Winner !!!!!!!';
	Result:=True;
	end;

begin
Randomize;
Memo.Lines.Add('=========== 24 Game ===========');
GenerateNumbers;
while true do
	begin
	if Application.Terminated then exit;
	Express:=WaitForString(Memo,'Enter expression, Q = quit, N = New numbers: '+CRLF);
	if Pos('N',UpperCase(Express))>0 then
		begin
		GenerateNumbers;
		Continue;
		end;
	if Pos('Q',UpperCase(Express))>0 then exit;
	RB:=TestUserExpression(RS);
	Memo.Lines.Add(RS);
	if not RB then continue;
	RS:=WaitForString(Memo,'Play again Y=Yes, N=No'+CRLF);
	if Pos('N',UpperCase(RS))>0 then exit;
	GenerateNumbers;
	end;
end;

The code generates four random digits from 1 to 9 and prompts the user to form an arithmetic expression using all of these digits exactly once. The expression should evaluate to 24 using only addition, subtraction, multiplication, and division operations. The code checks and evaluates the user's expression, preserving remainders for division. The order of the digits in the expression does not matter. The code does not form multiple digit numbers from the supplied digits. It uses a recursive descent expression evaluator to handle any user input.


Library:  System.SysUtils
program RunLengthTest;

{$APPTYPE CONSOLE}

uses
  System.SysUtils;

type
  TRLEPair = record
    count: Integer;
    letter: Char;
  end;

  TRLEncoded = TArray<TRLEPair>;

  TRLEncodedHelper = record helper for TRLEncoded
  public
    procedure Clear;
    function Add(c: Char): Integer;
    procedure Encode(Data: string);
    function Decode: string;
    function ToString: string;
  end;

{ TRLEncodedHelper }

function TRLEncodedHelper.Add(c: Char): Integer;
begin
  SetLength(self, length(self) + 1);
  Result := length(self) - 1;
  with self[Result] do
  begin
    count := 1;
    letter := c;
  end;
end;

procedure TRLEncodedHelper.Clear;
begin
  SetLength(self, 0);
end;

function TRLEncodedHelper.Decode: string;
var
  p: TRLEPair;
begin
  Result := '';
  for p in Self do
    Result := Result + string.Create(p.letter, p.count);
end;

procedure TRLEncodedHelper.Encode(Data: string);
var
  pivot: Char;
  i, index: Integer;
begin
  Clear;
  if Data.Length = 0 then
    exit;

  pivot := Data[1];
  index := Add(pivot);

  for i := 2 to Data.Length do
  begin
    if pivot = Data[i] then
      inc(self[index].count)
    else
    begin
      pivot := Data[i];
      index := Add(pivot);
    end;
  end;
end;

function TRLEncodedHelper.ToString: string;
var
  p: TRLEPair;
begin
  Result := '';
  for p in Self do
    Result := Result + p.count.ToString + p.letter;
end;

const
  Input = 'WWWWWWWWWWWWBWWWWWWWWWWWWBBBWWWWWWWWWWWWWWWWWWWWWWWWBWWWWWWWWWWWWWW';

var
  Data: TRLEncoded;

begin
  Data.Encode(Input);
  Writeln(Data.ToString);
  writeln(Data.Decode);
  Readln;
end.

implement a run-length encoding and decoding system for strings containing uppercase characters. The system compresses repeated characters by storing the length of the run and provides a function to reverse the compression.


program Concat;

{$APPTYPE CONSOLE}

var
  s1, s2: string;
begin
  s1 := 'Hello';
  s2 := s1 + ' literal';
  WriteLn(s1);
  WriteLn(s2);
end.

Initializes two string variables, one with a text value and the other as a concatenation of the first variable and a string literal, then displays their content.


Works with: Delphi version 6.0
Library: SysUtils,StdCtrls

function EncodeURL(URL: string): string;
var I: integer;
begin
Result:='';
for I:=1 to Length(URL) do
 if URL[I] in ['0'..'9', 'A'..'Z', 'a'..'z'] then Result:=Result+URL[I]
 else Result:=Result+'%'+IntToHex(byte(URL[I]),2);
end;

procedure EncodeAndShowURL(Memo: TMemo; URL: string);
var ES: string;
begin
Memo.Lines.Add('Unencoded URL: '+URL);
ES:=EncodeURL(URL);
Memo.Lines.Add('Encoded URL:   '+ES);
Memo.Lines.Add('');
end;

procedure ShowEncodedURLs(Memo: TMemo);
begin
EncodeAndShowURL(Memo,'http://foo bar/');
EncodeAndShowURL(Memo,'https://rosettacode.org/wiki/URL_encoding');
EncodeAndShowURL(Memo,'https://en.wikipedia.org/wiki/Pikes_Peak_granite');
end;

The code provides a function to convert any given string into its URL encoded representation. It converts special, control, and extended characters into a percent symbol followed by a two-digit hexadecimal code. The only exceptions are characters 0-9, A-Z, and a-z. It also allows for variations in encoding standards and the use of an exception string.


Works with: Delphi version 6.0
Library: SysUtils,StdCtrls

{Structure to hold the data}

type TButcherInfo = record
 Name: string;
 Weight,Cost,PerKG: double;
 end;
type PButcherInfo = ^TButcherInfo;

{Array of actual data}

var Items: array [0..8] of TButcherInfo =(
	(Name: 'beef';    Weight: 3.8; Cost: 36.0),
	(Name: 'pork';    Weight: 5.4; Cost: 43.0),
	(Name: 'ham';     Weight: 3.6; Cost: 90.0),
	(Name: 'greaves'; Weight: 2.4; Cost: 45.0),
	(Name: 'flitch';  Weight: 4.0; Cost: 30.0),
	(Name: 'brawn';   Weight: 2.5; Cost: 56.0),
	(Name: 'welt';    Weight: 3.7; Cost: 67.0),
	(Name: 'salami';  Weight: 3.0; Cost: 95.0),
	(Name: 'sausage'; Weight: 5.9; Cost: 98.0)
	);

function CompareButcher(List: TStringList; Index1, Index2: Integer): Integer;
{Compare routine to sort by Per Kilograph cost}
var Info1,Info2: TButcherInfo;
begin
Info1:=PButcherInfo(List.Objects[Index1])^;
Info2:=PButcherInfo(List.Objects[Index2])^;
Result:=Trunc(Info2.PerKG * 100 - Info1.PerKG * 100);
end;

procedure KnapsackProblem(Memo: TMemo);
{Solve the knapsack problem}
var SL: TStringList;
var I,Inx: integer;
var Info: TButcherInfo;
var Weight,Cost,Diff: double;
const Limit = 15;
begin
SL:=TStringList.Create;
try
{Calculate the per Kilogram cost for each item}
for I:=0 to High(Items) do
	begin
	Items[I].PerKG:=Items[I].Cost/Items[I].Weight;
	SL.AddObject(Items[I].Name,@Items[I]);
	end;
{Sort most expensive items to top of list}
SL.CustomSort(CompareButcher);

{Take the most expensive items }
Weight:=0; Cost:=0;
for I:=0 to SL.Count-1 do
	begin
	Info:=PButcherInfo(SL.Objects[I])^;
	{Item exceeds the weight limit? }
	if (Weight+Info.Weight)>=Limit then
		begin
		{Calculate percent to fill gap}
		Diff:=(Limit-Weight)/Info.Weight;
		{Save index}
		Inx:=I;
		break;
		end
	else
		begin
		{Add up totals}
		Weight:=Weight+Info.Weight;
		Cost:=Cost+Info.Cost;
		end;
	end;

{Display all items}
Memo.Lines.Add('Item      Portion    Value');
Memo.Lines.Add('--------------------------');
for I:=0 to Inx-1 do
	begin
	Info:=PButcherInfo(SL.Objects[I])^;
	Memo.Lines.Add(Format('%-8s %8.2f %8.2f',[Info.Name,Info.Weight,Info.Cost]));
	end;
Info:=PButcherInfo(SL.Objects[Inx])^;
{Calculate cost and weight to fill gap}
weight:=Weight+Info.Weight*Diff;
Cost:=Cost+Info.Cost*Diff;
{Display gap filling item}
Memo.Lines.Add(Format('%-8s %8.2f %8.2f',[Info.Name,Info.Weight*Diff,Info.Cost*Diff]));
Memo.Lines.Add('--------------------------');
Memo.Lines.Add(Format('Totals   %8.2f %8.2f',[Weight,Cost]));
finally SL.Free; end;
end;

"Determines the optimal selection of items from a butcher's shop for a thief to maximize profit without exceeding a 15 kg weight limit, considering the possibility of cutting items proportionally to their original price."


Library:  System.SysUtils
Library:  System.Classes
Library:  System.Diagnostics
program AnagramsTest;

{$APPTYPE CONSOLE}

{$R *.res}

uses
  System.SysUtils,
  System.Classes,
  System.Diagnostics;

function Sort(s: string): string;
var
  c: Char;
  i, j, aLength: Integer;
begin
  aLength := s.Length;

  if aLength = 0 then
    exit('');

  Result := s;

  for i := 1 to aLength - 1 do
    for j := i + 1 to aLength do
      if result[i] > result[j] then
      begin
        c := result[i];
        result[i] := result[j];
        result[j] := c;
      end;
end;

function IsAnagram(s1, s2: string): Boolean;
begin
  if s1.Length <> s2.Length then
    exit(False);

  Result := Sort(s1) = Sort(s2);

end;

function Split(s: string; var Count: Integer; var words: string): Boolean;
var
  sCount: string;
begin
  sCount := s.Substring(0, 4);
  words := s.Substring(5);
  Result := TryStrToInt(sCount, Count);
end;

function CompareLength(List: TStringList; Index1, Index2: Integer): Integer;
begin
  result := List[Index1].Length - List[Index2].Length;
  if Result = 0 then
    Result := CompareText(Sort(List[Index2]), Sort(List[Index1]));
end;

var
  Dict: TStringList;
  i, j, Count, MaxCount, WordLength, Index: Integer;
  words: string;
  StopWatch: TStopwatch;

begin
  StopWatch := TStopwatch.Create;
  StopWatch.Start;

  Dict := TStringList.Create();
  Dict.LoadFromFile('unixdict.txt');

  Dict.CustomSort(CompareLength);

  Index := 0;
  words := Dict[Index];
  Count := 1;

  while Index + Count < Dict.Count do
  begin
    if IsAnagram(Dict[Index], Dict[Index + Count]) then
    begin
      words := words + ',' + Dict[Index + Count];
      Dict[Index + Count] := '';
      inc(Count);
    end
    else
    begin
      Dict[Index] := format('%.4d', [Count]) + ',' + words;
      inc(Index, Count);
      words := Dict[Index];
      Count := 1;
    end;
  end;

  // The last one not match any one
  if not Dict[Dict.count - 1].IsEmpty then
    Dict.Delete(Dict.count - 1);

  Dict.Sort;

  while Dict[0].IsEmpty do
    Dict.Delete(0);

  StopWatch.Stop;

  Writeln(Format('Time pass: %d ms [i7-4500U Windows 7]', [StopWatch.ElapsedMilliseconds]));

  Split(Dict[Dict.count - 1], MaxCount, words);
  writeln(#10'The anagrams that contain the most words, has ', MaxCount, ' words:'#10);
  writeln('Words found:'#10);

  Writeln('  ', words);

  for i := Dict.Count - 2 downto 0 do
  begin
    Split(Dict[i], Count, words);
    if Count = MaxCount then
      Writeln('  ', words)
    else
      Break;
  end;

  Dict.Free;
  Readln;
end.

"Code identifies sets of anagrams with the most words from the provided word list."


program SierpinskiCarpet;

uses
  Math;

function In_carpet(a, b: longint): boolean;
var
  x, y: longint;
begin
  x := a;
  y := b;
  while true do
  begin
    if (x = 0) or (y = 0) then
    begin
      In_carpet := true;
      break;
    end
    else if ((x mod 3) = 1) and ((y mod 3) = 1) then
    begin
      In_carpet := false;
      break;
    end;
    x := x div 3;
    y := y div 3;
  end;
end;

procedure Carpet(n: integer);
var
  i, j, limit: longint;
begin
{$IFDEF FPC}
  limit := 3 *  * n - 1;
{$ELSE}
  limit := Trunc(IntPower(3, n) - 1);
{$ENDIF}

  for i := 0 to limit do
  begin
    for j := 0 to limit do
      if In_carpet(i, j) then
        write('*')
      else
        write(' ');
    writeln;
  end;
end;

begin
  Carpet(3);
  {$IFNDEF UNIX}      readln; {$ENDIF}
end.

generate an ASCII-art or graphical representation of a Sierpinski carpet of a given order N. The representation uses whitespace and non-whitespace characters, with the placement of these characters being the crucial requirement. The '#' character is used as an example, but is not strictly necessary.


Works with: Delphi version 5.0

-- begin file --

   Program SingleWinApp ;

   // This is the equivalent of the C #include
   Uses Forms, Windows, Messages, Classes, Graphics, Controls, StdCtrls ;

   type

     // The only reason for this declaration is to allow the connection of the
     // on click method to the forms button object. This class declaration adds
     // a procedure.

     TMainForm class(tform)
       Procedure AddClicks(sender : tObject);
     end;

   // Use these globals.
   var

     MainForm : tForm ;
     aLabel   : tLabel ;
     aButton  : tButton ;
     i        : integer = 0 ;

    // This is the Method call that we connect to the button object
    // to start counting the clicks.
    Procedure tMainForm.AddClicks(sender :tObject)
    begin
      inc(i);
      aLabel.Caption := IntToStr(i) + ' Clicks since startup' ;
    end;

    Begin
      // Do all the behind the scenes stuff that sets up the Windows environment
      Application.Initialize ;

      // Create the form

      // Forms can either be created with an owner, like I have done here, or with
      // the owner set to Nil. In pascal (all versions of Borland) '''NIL''' is a
      // reserved, (the equivalent of '''NULL''' in Ansi C) word and un-sets any pointer
      // variable. Setting the owner to the application object will ensure that the form is
      // freed by the application object when the application shuts down. If I had set
      // the owner to NIL then i would have had to make sure I freed the form explicitly
      // or it would have been orphaned, thus creating a memory leak.

      // I must direct your attention to the CreateNew constructor.  This is
      // a non standard usage.  Normally the constructor Create() will call this
      // as part of the initialization routine for the form. Normally as you drop
      // various components on a form in deign mode, a DFM file is created with
      // all the various initial states of the controls. This bypasses the
      // DFM file altogether although all components AND the form are created
      // with default values. (see the Delphi help file).

      MainForm          := tMainForm.CreateNew(Application);
      MainForm.Parent   := Application ;
      MainForm.Position := poScreenCenter ;
      MainForm.Caption  := 'Single Window Application' ;

      // Create the Label, set its owner as MaiaForm
      aLabel          := tLabel.Create(mainForm);
      aLabel.Parent   := MainForm;
      aLabel.Caption  := IntToStr(i) + ' Clicks since startup' ;
      aLabel.Left     := 20 ;
      aLabel.Top      := MainForm.ClientRect.Bottom div 2 ;

      // Create the button, set its owner to MainForm
      aButton         := tButton.Create(MainForm);
      aButton.Parent  := MainForm ;
      aButton.Caption := 'Click Me!';
      aButton.Left    := (MainForm.ClientRect.Right div 2)-(aButton.Width div 2 );
      aButton.Top     := MainForm.ClientRect.Bottom - aButton.Height - 10 ;
      aButton.OnClick := AddClicks ;

      // Show the main form, Modaly. The ONLY reason to do this is because in this
      // demonstration if you only call the SHOW method, the form will appear and
      // disappear in a split second.
      MainForm.ShowModal ;

      Application.Run ;

   end. // Program

The code creates a simple windowed application in Delphi that includes a label and a button. Initially, the label displays "There have been no clicks yet", and the button displays "click me". When the button is clicked, the label updates to show the number of times the button has been clicked. The application is dynamically created from the main program file, SingleWinApp.dpr. The project can be built either through the IDE or the command line compiler.


The code performs a countdown from 10 to 0 using a downward for loop.


Works with: Delphi version 6.0
Library: SysUtils,StdCtrls

function UpperAlphaOnly(S: string): string;
{Remove all }
var I: integer;
begin
Result:='';
S:=UpperCase(S);
for I:=1 to Length(S) do
if S[I] in ['A'..'Z'] then Result:=Result+S[I];
end;

function VigenereEncrypt(Text, Key: string): string;
{Encrypt Text using specified key}
var KInx,TInx,I: integer;
var TC: byte;
begin
Result:='';
{Force Text and Key upper case}
Text:=UpperAlphaOnly(Text);
Key:=UpperAlphaOnly(Key);
{Point to first Key-character}
KInx:=1;
for I:=1 to Length(Text) do
	begin
	{Offset Text-char by key-char amount}
	TC:=byte(Text[I])-byte('A')+Byte(Key[KInx]);
	{if it is shifted past "Z", wrap back around past "A"}
	if TC>Byte('Z') then TC:=byte('@')+(TC-Byte('Z'));
	{Store in output string}
	Result:=Result+Char(TC);
	{Point to next Key-char}
	Inc(Kinx);
	{If index post end of key, start over}
	if KInx>Length(Key) then KInx:=1;
	end;
end;

function VigenereDecrypt(Text, Key: string): string;
{Encrypt Text using specified key}
var KInx,TInx,I: integer;
var TC: byte;
begin
Result:='';
{For Key and text uppercase}
Text:=UpperAlphaOnly(Text);
Key:=UpperAlphaOnly(Key);
KInx:=1;
for I:=1 to Length(Text) do
	begin
	{subtrack key-char from text-char}
	TC:=byte(Text[I])-Byte(Key[Kinx])+Byte('A');
	{if result below "A" wrap back around to "Z"}
	if TC<Byte('A') then TC:=(byte('Z')-((Byte('A')-TC)))+1;
	{store in result}
	Result:=Result+Char(TC);
	{Point to next key char}
	Inc(Kinx);
	{Past the end, start over}
	if KInx>Length(Key) then KInx:=1;
	end;
end;

const TestKey = 'VIGENERECIPHER';
const TestStr = 'Beware the Jabberwock, my son! The jaws that bite, the claws that catch!';

procedure VigenereCipher(Memo: TMemo);
var S: string;
begin
{Show plain text}
Memo.Lines.Add(TestStr);
S:=VigenereEncrypt(TestStr, TestKey);
{Show encrypted text}
Memo.Lines.Add(S);
S:=VigenereDecrypt(S, TestKey);
{Show decrypted text}
Memo.Lines.Add(S);
end;

Implement and decrypt a Vigenère cipher, accommodating keys and text of varying lengths, capitalizing all text, and discarding non-alphabetic characters.


program LoopWithStep;

{$APPTYPE CONSOLE}

var
  i: Integer;
begin
  i:=2;
  while i <= 8 do begin
    WriteLn(i);
    Inc(i, 2);
  end;
end.

demonstrate a for-loop with a step-value greater than one, using a simulated While loop due to Delphi's For loop not supporting a step value.


Works with: Delphi version 6.0
Library: SysUtils,StdCtrls

type TTerm = function(i: integer): real;

function Term(I: integer): double;
begin
Term := 1 / I;
end;

function Sum(var I: integer; Lo, Hi: integer; Term: TTerm): double;
begin
Result := 0;
I := Lo;
while I <= Hi do
	begin
	Result := Result + Term(I);
	Inc(I);
	end;
end;

procedure ShowJensenDevice(Memo: TMemo);
var I: LongInt;
begin
Memo.Lines.Add(FloatToStrF(Sum(I, 1, 100, @Term), ffFixed,18,15));
end;

The code implements Jensen's Device, a technique in computer programming that exploits call by name. It calculates the 100th harmonic number by passing parameters by name to a sum procedure. The sum procedure iteratively adds terms, re-evaluating the passed expression in the caller's context each time. The result is dependent on the re-evaluation of the actual parameter in the caller's context. The code also demonstrates the importance of passing the first parameter by name or reference for visibility of changes in the caller's context.


Works with: Delphi version 6.0
Library: Windows,Types,ExtCtrls,Graphics

procedure MunchingSquares(Image: TImage);
{XOR's X and Y to select an RGB level}
var W,H,X,Y: integer;
begin
W:=Image.Width;
H:=Image.Height;
for Y:=0 to Image.Height-1 do
 for X:=0 to Image.Width-1 do
	begin
	Image.Canvas.Pixels[X,Y]:=RGB(0,X xor Y,0);
	end;
end;

generate a graphical pattern by coloring each pixel based on the 'x xor y' value from a given color table, as described in the Munching Squares programming task.


program MazeGen_Rosetta;

{$APPTYPE CONSOLE}

uses System.SysUtils, System.Types, System.Generics.Collections, System.IOUtils;

type
  TMCell = record
    Visited  : Boolean;
    PassTop  : Boolean;
    PassLeft : Boolean;
  end;
  TMaze  = array of array of TMCell;
  TRoute = TStack<TPoint>;

const
  mwidth  = 24;
  mheight = 14;

procedure ClearVisited(var AMaze: TMaze);
var
  x, y: Integer;
begin
  for y := 0 to mheight - 1 do
    for x := 0 to mwidth - 1 do
      AMaze[x, y].Visited := False;
end;

procedure PrepareMaze(var AMaze: TMaze);
var
  Route    : TRoute;
  Position : TPoint;
  d        : Integer;
  Pool     : array of TPoint; // Pool of directions to pick randomly from
begin
  SetLength(AMaze, mwidth, mheight);
  ClearVisited(AMaze);
  Position := Point(Random(mwidth), Random(mheight));
  Route := TStack<TPoint>.Create;
  try
    with Position do
    while True do
    begin
      repeat
        SetLength(Pool, 0);
        if (y > 0)         and not AMaze[x, y-1].Visited then Pool := Pool + [Point(0, -1)];
        if (x < mwidth-1)  and not AMaze[x+1, y].Visited then Pool := Pool + [Point(1,  0)];
        if (y < mheight-1) and not AMaze[x, y+1].Visited then Pool := Pool + [Point(0,  1)];
        if (x > 0)         and not AMaze[x-1, y].Visited then Pool := Pool + [Point(-1, 0)];

        if Length(Pool) = 0 then // no direction to draw from
        begin
          if Route.Count = 0 then Exit; // and we are back at start so this is the end
          Position := Route.Pop;
        end;
      until Length(Pool) > 0;

      d := Random(Length(Pool));
      Offset(Pool[d]);

      AMaze[x, y].Visited := True;
      if Pool[d].y = -1 then AMaze[x, y+1].PassTop  := True; // comes from down to up ( ^ )
      if Pool[d].x =  1 then AMaze[x, y].PassLeft   := True; // comes from left to right ( --> )
      if Pool[d].y =  1 then AMaze[x, y].PassTop    := True; // comes from left to right ( v )
      if Pool[d].x = -1 then AMaze[x+1, y].PassLeft := True; // comes from right to left ( <-- )
      Route.Push(Position);
    end;
  finally
    Route.Free;
  end;
end;

function MazeToString(const AMaze: TMaze; const S, E: TPoint): String; overload;
var
  x, y: Integer;
  v   : Char;
begin
  Result := '';
  for y := 0 to mheight - 1 do
  begin
    for x := 0 to mwidth - 1 do
      if AMaze[x, y].PassTop then Result := Result + '+'#32#32#32 else Result := Result + '+---';
    Result := Result + '+' + sLineBreak;
    for x := 0 to mwidth - 1 do
    begin
      if S = Point(x, y) then v := 'S' else
        if E = Point(x, y) then v := 'E' else
          v := #32'*'[Ord(AMaze[x, y].Visited) + 1];

      Result := Result + '|'#32[Ord(AMaze[x, y].PassLeft) + 1] + #32 + v + #32;
    end;
    Result := Result + '|' + sLineBreak;
  end;
  for x := 0 to mwidth - 1 do Result := Result + '+---';
  Result := Result + '+' + sLineBreak;
end;

procedure Main;
var
  Maze: TMaze;
begin
  Randomize;
  PrepareMaze(Maze);
  ClearVisited(Maze);     // show no route
  Write(MazeToString(Maze, Point(-1, -1), Point(-1, -1)));
  ReadLn;
end;

begin
  Main;

end.

generate and display a maze using the Depth-first search algorithm. It starts from a random cell, marks it as visited, and gets a list of its neighbors. For each unvisited neighbor, it removes the wall between the current cell and the neighbor, and then recursively continues the process with the neighbor as the current cell.


unit Pi_BBC_Main;

interface

uses
  Classes, Controls, Forms, Dialogs, StdCtrls;

type
  TForm1 = class(TForm)
    btnRunSpigotAlgo: TButton;
    memScreen: TMemo;
    procedure btnRunSpigotAlgoClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
  private
    fScreenWidth : integer;
    fLineBuffer : string;
    procedure ClearText();
    procedure AddText( const s : string);
    procedure FlushText();
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

uses SysUtils;

// Button clicked to run algorithm
procedure TForm1.btnRunSpigotAlgoClick(Sender: TObject);
var
  // BBC Basic variables. Delphi longint is 32 bits.
  B : array of longint;
  A, C, D, E, I, L, M, P : longint;
  // Added for Delphi version
  temp : string;
  h, j, t : integer;
begin
  fScreenWidth := 80;
  ClearText();
  M := 5368709; // floor( (2^31 - 1)/400 )

  // DIM B%(M%) in BBC Basic declares an array [0..M%], i.e. M% + 1 elements
  SetLength( B, M + 1);
  for I := 0 to M do B[I] := 20;
  E := 0;
  L := 2;

  // FOR C% = M% TO 14 STEP -7
  // In Delphi (or at least Delphi 7) the step size in a for loop has to be 1.
  // So the BBC Basic FOR loop has been replaced by a repeat loop.
  C := M;
  repeat
    D := 0;
    A := C*2 - 1;
    for P := C downto 1 do begin
      D := D*P + B[P]*$64; // hex notation copied from BBC version
      B[P] := D mod A;
      D := D div A;
      dec( A, 2);
    end;

    // The BBC CASE statement here amounts to a series of if ... else
    if (D = 99) then begin
      E := E*100 + D;
      inc( L, 2);
    end
    else if (C = M) then begin
      AddText( SysUtils.Format( '%2.1f', [1.0*(D div 100) / 10.0] ));
      E := D mod 100;
    end
    else begin
      // PRINT RIGHT$(STRING$(L%,"0") + STR$(E% + D% DIV 100),L%);
      // This can't be done so concisely in Delphi 7
      SetLength( temp, L);
      for j := 1 to L do temp[j] := '0';
      temp := temp + SysUtils.IntToStr( E + D div 100);
      t := Length( temp);
      AddText( Copy( temp, t - L + 1, L));
      E := D mod 100;
      L := 2;
    end;
    dec( C, 7);
  until (C < 14);
  FlushText();

  // Delphi addition: Write screen output to a file for checking
  h := SysUtils.FileCreate( 'C:\Delphi\PiDigits.txt'); // h = file handle
  for j := 0 to memScreen.Lines.Count - 1 do
    SysUtils.FileWrite( h, memScreen.Lines[j][1], Length( memScreen.Lines[j]));
  SysUtils.FileClose( h);
end;

{=========================== Auxiliary routines ===========================}

// Form created
procedure TForm1.FormCreate(Sender: TObject);
begin
  fScreenWidth := 80; // in case not set by the algotithm
  ClearText();
end;

// This Delphi version builds each screen line in a buffer and puts
//   the line into the TMemo when the buffer is full.
// This is faster than writing to the TMemo a few characters at a time,
//   but note that the buffer must be flushed at the end of the program.
procedure TForm1.ClearText();
begin
  memScreen.Lines.Clear();
  fLineBuffer := '';
end;

procedure TForm1.AddText( const s : string);
var
  nrChars, nrLeft : integer;
begin
  nrChars := Length( s);
  nrLeft := fScreenWidth - Length( fLineBuffer); // nr chars left in line
  if (nrChars <= nrLeft) then fLineBuffer := fLineBuffer + s
  else begin
    fLineBuffer := fLineBuffer + Copy( s, 1, nrLeft);
    memScreen.Lines.Add( fLineBuffer);
    fLineBuffer := Copy( s, nrLeft + 1, nrChars - nrLeft);
  end;
end;

procedure TForm1.FlushText();
begin
  if (Length(fLineBuffer) > 0) then begin
    memScreen.Lines.Add( fLineBuffer);
    fLineBuffer := '';
  end;
end;

end.

The code continuously calculates and outputs the successive decimal digits of Pi, starting from 3.14159265. The calculation process continues indefinitely until manually stopped by the user. The number of digits calculated is determined by the variable M, with the output written to a disk file. The code is a translation from the original BBC micro code and has been tested for accuracy up to 1,533,913 decimal places.


Library:  System.SysUtils
Library:  System.Generics.Defaults
program Order_two_numerical_lists;

{$APPTYPE CONSOLE}

uses
  System.SysUtils,
  System.Generics.Defaults;

type
  TArray = record
    class function LessOrEqual<T>(first, second: TArray<T>): Boolean; static;
  end;

class function TArray.LessOrEqual<T>(first, second: TArray<T>): Boolean;
begin
  if Length(first) = 0 then
    exit(true);
  if Length(second) = 0 then
    exit(false);
  var comp := TComparer<T>.Default.Compare(first[0], second[0]);
  if comp = 0 then
    exit(LessOrEqual(copy(first, 1, length(first)), copy(second, 1, length(second))));
  Result := comp < 0;
end;

begin
  writeln(TArray.LessOrEqual<Integer>([1, 2, 3], [2, 3, 4]));
  writeln(TArray.LessOrEqual<Integer>([2, 3, 4], [1, 2, 3]));
  writeln(TArray.LessOrEqual<Integer>([1, 2], [1, 2, 3]));
  writeln(TArray.LessOrEqual<Integer>([1, 2, 3], [1, 2]));
  writeln(TArray.LessOrEqual<Char>(['a', 'c', 'b'], ['a', 'b', 'b']));
  writeln(TArray.LessOrEqual<string>(['this', 'is', 'a', 'test'], ['this', 'is',
    'not', 'a', 'test']));
  readln;
end.

"Function to compare and order two numerical lists lexicographically, returning true if the first list should be ordered before the second and false otherwise."


function Ackermann(m,n:Int64):Int64;
begin
    if m = 0 then
        Result := n + 1
    else if n = 0 then
        Result := Ackermann(m-1, 1)
    else
        Result := Ackermann(m-1, Ackermann(m, n - 1));
end;

Implement the Ackermann function which is a recursive function that takes two non-negative arguments and returns a value based on the specified conditions. The function should ideally support arbitrary precision due to its rapid growth.


implement the Gamma function using either the Lanczos or Stirling's approximation. The codes also compare the results of the custom implementation with the built-in/library function if available. The Gamma function is computed through numerical integration.


Library:  System.SysUtilsprogram N_queens_problem;

{$APPTYPE CONSOLE}

uses
  System.SysUtils;

var
  i: Integer;
  q: boolean;
  a: array[0..8] of boolean;
  b: array[0..16] of boolean;
  c: array[0..14] of boolean;
  x: array[0..8] of Integer;

procedure TryMove(i: Integer);
begin
  var j := 1;
  while True do
  begin
    q := false;
    if a[j] and b[i + j] and c[i - j + 7] then
    begin
      x[i] := j;
      a[j] := false;
      b[i + j] := false;
      c[i - j + 7] := false;

      if i < 8 then
      begin
        TryMove(i + 1);
        if not q then
        begin
          a[j] := true;
          b[i + j] := true;
          c[i - j + 7] := true;
        end;
      end
      else
        q := true;
    end;
    if q or (j = 8) then
      Break;
    inc(j);
  end;
end;

begin
  for i := 1 to 8 do
    a[i] := true;

  for i := 2 to 16 do
    b[i] := true;

  for i := 0 to 14 do
    c[i] := true;

  TryMove(1);

  if q then
    for i := 1 to 8 do
      writeln(i, ' ', x[i]);
  readln;
end.

"Solve the N-queens problem for an NxN board and provide the number of solutions for small values of N."


// This example works on stuff as old as Delphi 5 (maybe older)
// Modern Delphi / Object Pascal has both
//   • generic types
//   • the ability to concatenate arrays with the '+' operator
// So I could just say:
//   myarray := [1] + [2, 3];
// But if you do not have access to the latest/greatest, then:
{$apptype console}

type
  // Array types must be declared in order to return them from functions
  // They can also be used with open array parameters.
  TArrayOfString = array of string;

function Concat( a, b : array of string ): TArrayOfString; overload;
{
  Every array type needs its own 'Concat' function:
    function Concat( a, b : array of integer ): TArrayOfInteger; overload;
    function Concat( a, b : array of double  ): TArrayOfDouble;  overload;
    etc
  Also, dynamic and open array types ALWAYS start at 0. No need to complicate indexing here.
}
var
  n : Integer;
begin
  SetLength( result, Length(a)+Length(b) );
  for n := 0 to High(a) do result[          n] := a[n];
  for n := 0 to High(b) do result[Length(a)+n] := b[n]
end;

// Example time!
function Join( a : array of string; sep : string = ' ' ): string;
var
  n : integer;
begin
  if Length(a) > 0 then result := a[0];
  for n := 1 to High(a) do result := result + sep + a[n]
end;

var
  names : TArrayOfString;
begin
  // Here we use the open array parameter constructor as a convenience
  names := Concat( ['Korra', 'Asami'], ['Bolin', 'Mako'] );
  WriteLn( Join(names) );

  // Also convenient: open array parameters are assignment-compatible with our array type!
  names := Concat( names, ['Varrick', 'Zhu Li'] );
  WriteLn( #13#10, Join(names, ', ') );

  names := Concat( ['Tenzin'], names );
  Writeln( #13#10, Join(names, #13#10 ) );
end.

Korra Asami Bolin Mako

Korra, Asami, Bolin, Mako, Varrick, Zhu Li

Tenzin
Korra
Asami
Bolin
Mako
Varrick
Zhu Li

type
  TReturnArray = array of integer; //you need to define a type to be able to return it

function ConcatArray(a1,a2:array of integer):TReturnArray;
var
  i,r:integer;
begin
  { Low(array) is not necessarily 0 }
  SetLength(result,High(a1)-Low(a1)+High(a2)-Low(a2)+2); //BAD idea to set a length you won't release, just to show the idea!
  r:=0; //index on the result may be different to indexes on the sources
  for i := Low(a1) to High(a1) do begin
    result[r] := a1[i];
    Inc(r);
  end;
  for i := Low(a2) to High(a2) do begin
    result[r] := a2[i];
    Inc(r);
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  a1,a2:array of integer;
  r1:array of integer;
  i:integer;
begin
  SetLength(a1,4);
  SetLength(a2,3);
  for i := Low(a1) to High(a1) do
    a1[i] := i;
  for i := Low(a2) to High(a2) do
    a2[i] := i;
  TReturnArray(r1) := ConcatArray(a1,a2);
  for i := Low(r1) to High(r1) do
    showMessage(IntToStr(r1[i]));
  Finalize(r1); //IMPORTANT!
  ShowMessage(IntToStr(High(r1)));
end;

demonstrate how to concatenate two arrays in the given programming language. The process may be as simple as using array1 + array2. The code also includes older content with commentary about memory management, specifically noting that Delphi handles dynamic array memory effectively.


Works with: Delphi version 6.0
Library: SysUtils,StdCtrls

{Item to store data in}

type TPackItem = record
 Name: string;
 Weight,Value: integer;
 end;

{List of items, weights and values}

const ItemsList: array [0..21] of TPackItem = (
   (Name: 'map'; Weight: 9; Value: 150),
   (Name: 'compass'; Weight: 13; Value: 35),
   (Name: 'water'; Weight: 153; Value: 200),
   (Name: 'sandwich'; Weight: 50; Value: 160),
   (Name: 'glucose'; Weight: 15; Value: 60),
   (Name: 'tin'; Weight: 68; Value: 45),
   (Name: 'banana'; Weight: 27; Value: 60),
   (Name: 'apple'; Weight: 39; Value: 40),
   (Name: 'cheese'; Weight: 23; Value: 30),
   (Name: 'beer'; Weight: 52; Value: 10),
   (Name: 'suntan cream'; Weight: 11; Value: 70),
   (Name: 'camera'; Weight: 32; Value: 30),
   (Name: 't-shirt'; Weight: 24; Value: 15),
   (Name: 'trousers'; Weight: 48; Value: 10),
   (Name: 'umbrella'; Weight: 73; Value: 40),
   (Name: 'waterproof trousers'; Weight: 42; Value: 70),
   (Name: 'waterproof overclothes'; Weight: 43; Value: 75),
   (Name: 'note-case'; Weight: 22; Value: 80),
   (Name: 'sunglasses'; Weight: 7; Value: 20),
   (Name: 'towel'; Weight: 18; Value: 12),
   (Name: 'socks'; Weight: 4; Value: 50),
   (Name: 'book'; Weight: 30; Value: 10));

{Iterater object to step through all the indices
{ corresponding to the bits in "N". This is used }
{ step through all the combinations of items }

type TBitIterator = class(TObject)
 private
   FNumber,FIndex: integer;
 public
  procedure Start(StartNumber: integer);
  function Next(var Index: integer): boolean;
 end;

procedure TBitIterator.Start(StartNumber: integer);
{Set the starting value of the number }
begin
FNumber:=StartNumber;
end;

function TBitIterator.Next(var Index: integer): boolean;
{Return the next available index}
begin
Result:=False;
while FNumber>0 do
	begin
	Result:=(FNumber and 1)=1;
	if Result then Index:=FIndex;
	FNumber:=FNumber shr 1;
	Inc(FIndex);
	if Result then break;
	end;
end;

{=============================================================================}

procedure GetSums(N: integer; var Weight,Value: integer);
{Iterate through all indices corresponding to N}
{Get get the sum of their values}
var Inx: integer;
var BI: TBitIterator;
begin
BI:=TBitIterator.Create;
try
BI.Start(N);
Weight:=0; Value:=0;
while BI.Next(Inx) do
	begin
	Weight:=Weight+ItemsList[Inx].Weight;
	Value:=Value+ItemsList[Inx].Value;
	end;
finally BI.Free; end;
end;

procedure DoKnapsackProblem(Memo: TMemo);
{Find optimized solution to Knapsack problem}
{By iterating through all binary combinations}
var I,J,Inx: integer;
var Max: integer;
var WeightSum,ValueSum: integer;
var BestValue,BestIndex,BestWeight: integer;
var S: string;
var BI: TBitIterator;
begin
BI:=TBitIterator.Create;
try
{Get value that will cover all binary combinations}
Max:=1 shl Length(ItemsList)-1;
BestValue:=0;
{Iterate through all combinations of bits}
for I:=1 to Max do
	begin
	{Get the sum of the weights and values}
	GetSums(I,WeightSum,ValueSum);
	{Ignore any weight greater than 400}
	if WeightSum>400 then continue;
	{Test if this is the best value so far}
	if ValueSum>BestValue then
		begin
		BestValue:=ValueSum;
		BestWeight:=WeightSum;
		BestIndex:=I;
		end;
	end;
{Display the best result}
Memo.Lines.Add('  Item                    Weight  Value');
Memo.Lines.Add('---------------------------------------');
BI.Start(BestIndex);
while BI.Next(Inx) do
	begin
	S:='  '+Format('%-25s',[ItemsList[Inx].Name]);
	S:=S+Format('%5d',[ItemsList[Inx].Weight]);
	S:=S+Format('%7d',[ItemsList[Inx].Value]);
	Memo.Lines.Add(S);
	end;
Memo.Lines.Add('---------------------------------------');
Memo.Lines.Add(Format('Total                     %6d %6d',[BestWeight,BestValue]));
Memo.Lines.Add('Best Inx: '+IntToStr(BestIndex));
Memo.Lines.Add('Best Value: '+IntToStr(BestValue));
Memo.Lines.Add('Best Weight: '+IntToStr(BestWeight));
finally BI.Free; end;
end;

The code determines the optimal combination of items the tourist can carry in his knapsack, given a maximum weight limit of 4kg. It iterates through all possible combinations of items, ensuring the total weight does not exceed 400 decagrams and the total value is maximized. The items cannot be divided or diminished.


program ShortCircuitEvaluation;

{$APPTYPE CONSOLE}

uses SysUtils;

function A(aValue: Boolean): Boolean;
begin
  Writeln('a');
  Result := aValue;
end;

function B(aValue: Boolean): Boolean;
begin
  Writeln('b');
  Result := aValue;
end;

var
  i, j: Boolean;
begin
  for i in [False, True] do
  begin
    for j in [False, True] do
    begin
      Writeln(Format('%s and %s = %s', [BoolToStr(i, True), BoolToStr(j, True), BoolToStr(A(i) and B(j), True)]));
      Writeln;
      Writeln(Format('%s or %s = %s', [BoolToStr(i, True), BoolToStr(j, True), BoolToStr(A(i) or B(j), True)]));
      Writeln;
    end;
  end;
end.

The code defines two functions, 'a' and 'b', which both accept and return a boolean value, and print their name when called. It then calculates the values of two boolean expressions, 'x' and 'y', using short-circuit evaluation. The function 'b' is only called when necessary, depending on the result of function 'a'. If the programming language does not support short-circuit evaluation, the same result is achieved using nested 'if' statements. In Delphi, short-circuit evaluation is enabled by default but can be turned off using the compiler directive {$BOOLEVAL OFF}.


program Morse;

{$APPTYPE CONSOLE}

{$R *.res}

uses
  System.Generics.Collections,
  SysUtils,
  Windows;

const
  Codes: array[0..35, 0..1] of string =
   (('a', '.-   '), ('b', '-... '), ('c', '-.-. '), ('d', '-..  '),
    ('e', '.    '), ('f', '..-. '), ('g', '--.  '), ('h', '.... '),
    ('i', '..   '), ('j', '.--- '), ('k', '-.-  '), ('l', '.-.. '),
    ('m', '--   '), ('n', '-.   '), ('o', '---  '), ('p', '.--. '),
    ('q', '--.- '), ('r', '.-.  '), ('s', '...  '), ('t', '-    '),
    ('u', '..-  '), ('v', '...- '), ('w', '.--  '), ('x', '-..- '),
    ('y', '-.-- '), ('z', '--.. '), ('0', '-----'), ('1', '.----'),
    ('2', '..---'), ('3', '...--'), ('4', '....-'), ('5', '.....'),
    ('6', '-....'), ('7', '--...'), ('8', '---..'), ('9', '----.'));
var
  Dictionary: TDictionary<String, String>;

procedure InitCodes;
var
  i: Integer;
begin
  for i := 0 to High(Codes) do
    Dictionary.Add(Codes[i, 0], Codes[i, 1]);
end;

procedure SayMorse(const Word: String);
var
  s: String;
begin
  for s in Word do
    if s = '.' then
      Windows.Beep(1000, 250)
    else if s = '-' then
      Windows.Beep(1000, 750)
    else
      Windows.Beep(1000, 1000);
end;

procedure ParseMorse(const Word: String);
var
  s, Value: String;
begin
  for s in word do
    if Dictionary.TryGetValue(s, Value) then
    begin
      Write(Value + ' ');
      SayMorse(Value);
    end;
end;

begin
  Dictionary := TDictionary<String, String>.Create;
  try
    InitCodes;
    if ParamCount = 0 then
      ParseMorse('sos')
    else if ParamCount = 1 then
      ParseMorse(LowerCase(ParamStr(1)))
    else
      Writeln('Usage: Morse.exe anyword');

    Readln;
  finally
    Dictionary.Free;
  end;
end.

<output> convert a given string into audible Morse code and send it to an audio device such as a PC speaker. It either ignores unknown characters or indicates them with a different pitch. </output>


program ABC;
{$APPTYPE CONSOLE}

uses SysUtils;

type
  TBlock = set of char;

const
  TheBlocks : array [0..19] of TBlock =
  (
    [ 'B', 'O' ],    [ 'X', 'K' ],    [ 'D', 'Q' ],    [ 'C', 'P' ],    [ 'N', 'A' ],
    [ 'G', 'T' ],    [ 'R', 'E' ],    [ 'T', 'G' ],    [ 'Q', 'D' ],    [ 'F', 'S' ],
    [ 'J', 'W' ],    [ 'H', 'U' ],    [ 'V', 'I' ],    [ 'A', 'N' ],    [ 'O', 'B' ],
    [ 'E', 'R' ],    [ 'F', 'S' ],    [ 'L', 'Y' ],    [ 'P', 'C' ],    [ 'Z', 'M' ]
  );

function SolveABC(Target : string; Blocks : array of TBlock) : boolean;
var
  iChr : integer;
  Used : array [0..19] of boolean;

  function FindUnused(TargetChr : char) : boolean;  // Nested routine
  var
    iBlock : integer;
  begin
    Result := FALSE;
    for iBlock := low(Blocks) to high(Blocks) do
      if (not Used[iBlock]) and ( TargetChr in Blocks[iBlock] ) then
      begin
        Result := TRUE;
        Used[iBlock] := TRUE;
        Break;
      end;
  end;

begin
  FillChar(Used, sizeof(Used), ord(FALSE));
  Result := TRUE;
  iChr := 1;
  while Result and (iChr <= length(Target)) do
    if FindUnused(Target[iChr]) then inc(iChr)
                                else Result := FALSE;
end;

procedure CheckABC(Target : string);
begin
  if SolveABC(uppercase(Target), TheBlocks) then
    writeln('Can make ' + Target)
  else
    writeln('Can NOT make ' + Target);
end;

begin
  CheckABC('A');
  CheckABC('BARK');
  CheckABC('BOOK');
  CheckABC('TREAT');
  CheckABC('COMMON');
  CheckABC('SQUAD');
  CheckABC('CONFUSE');
  readln;
end.

The code implements a function that checks if a given word can be spelled using a predefined collection of ABC blocks. Each block contains two letters and can only be used once. The function is case-insensitive. The output for seven example words is displayed.


program MD5Hash;

{$APPTYPE CONSOLE}

uses
  SysUtils,
  IdHashMessageDigest;

function MD5(aValue: string): string;
begin
  with TIdHashMessageDigest5.Create do
  begin
    Result:= HashStringAsHex(aValue);
    Free;
  end;
end;

begin
  Writeln(MD5(''));
  Writeln(MD5('a'));
  Writeln(MD5('abc'));
  Writeln(MD5('message digest'));
  Writeln(MD5('abcdefghijklmnopqrstuvwxyz'));
  Writeln(MD5('ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789'));
  Writeln(MD5('12345678901234567890123456789012345678901234567890123456789012345678901234567890'));
  Readln;
end.

D41D8CD98F00B204E9800998ECF8427E
0CC175B9C0F1B6A831C399E269772661
900150983CD24FB0D6963F7D28E17F72
F96B697D7CB7938D525A2F31AAF161D0
C3FCD3D76192E4007DFB496CCA67E13B
D174AB98D277D9F5A5611C2C9F419D9F
57EDF4A22BE3C955AC49DA2E2107B67A

Implement and validate an MD5 encoding algorithm for a given string. The implementation should be tested against the test values in IETF RFC (1321) for MD5. The code also includes a warning about the known weaknesses of MD5 and suggests stronger alternatives for production-grade cryptography. If a library solution is used, there's a reference to MD5/Implementation for a native implementation.


program Sockets;

{$APPTYPE CONSOLE}

uses IdTCPClient;

var
  lTCPClient: TIdTCPClient;
begin
  lTCPClient := TIdTCPClient.Create(nil);
  try
    lTCPClient.Host := '127.0.0.1';
    lTCPClient.Port := 256;
    lTCPClient.Connect;
    lTCPClient.IOHandler.WriteLn('hello socket world');
  finally
    lTCPClient.Free;
  end;
end.

opens a socket to localhost on port 256, sends the message "hello socket world", and then closes the socket.


procedure SendEmail;
var
  msg: TIdMessage;
  smtp: TIdSMTP;
begin
  smtp := TIdSMTP.Create;
  try
    smtp.Host := 'smtp.server.com';
    smtp.Port := 587;
    smtp.Username := 'login';
    smtp.Password := 'password';
    smtp.AuthType := satNone;
    smtp.Connect;
    msg := TIdMessage.Create(nil);
    try
      with msg.Recipients.Add do begin
        Address := 'doug@gmail.com';
        Name := 'Doug';
      end;
      with msg.Sender do begin
        Address := 'fred@server.com';
        Name := 'Fred';
      end;
      msg.Subject := 'subj';
      msg.Body.Text := 'here goes email message';
      smtp.Send(msg);
    finally
      msg.Free;
    end;
  finally
    smtp.Free;
  end;
end;

Implement a function to send an email with parameters for From, To, Cc addresses, Subject, message text, and optional server name and login details. The code also provides notifications for any issues or success, and uses libraries or external programs for execution. It ensures portability across different operating systems. Sensitive data used in examples is obfuscated.


program CountingInOctal;

{$APPTYPE CONSOLE}

uses SysUtils;

function DecToOct(aValue: Integer): string;
var
  lRemainder: Integer;
begin
  Result := '';
  repeat
    lRemainder := aValue mod 8;
    Result := IntToStr(lRemainder) + Result;
    aValue := aValue div 8;
  until aValue = 0;
end;

var
  i: Integer;
begin
  for i := 0 to 20 do
    WriteLn(DecToOct(i));
end.

generate a sequential count in octal, starting from zero and incrementing by one on each line until the program is terminated or the maximum numeric type value is reached.


procedure Swap_T(var a, b: T);
var
  temp: T;
begin
  temp := a;
  a := b;
  b := temp;
end;

program GenericSwap;

type
  TSwap = class
    class procedure Swap<T>(var left, right: T);
  end;

class procedure TSwap.Swap<T>(var left, right: T);
var
  temp : T;
begin
  temp := left;
  left := right;
  right := temp;
end;

var
  a, b : integer;

begin
  a := 5;
  b := 3;
  writeln('Before swap: a=', a, ' b=', b);
  TSwap.Swap<integer>(a, b);
  writeln('After swap: a=', a, ' b=', b);
end.

implement a generic swap function or operator that can interchange the values of two variables or storage places, regardless of their types. The function is designed to work with both statically and dynamically typed languages, with certain restrictions for type compatibility and support for parametric polymorphism. In the case of Delphi, the function needs to be copied and adjusted for each required type, as it does not inherently support generics.


uses
  SysUtils, StrUtils;

function IsPalindrome(const aSrcString: string): Boolean;
begin
  Result := SameText(aSrcString, ReverseString(aSrcString));
end;

implement a function to check if a given sequence of characters is a palindrome. It also supports Unicode characters. Additionally, it includes a second function to detect inexact palindromes, ignoring white-space, punctuation, and case-sensitivity. It may also be useful for testing a function.


Works with: Delphi version 6.0
Library: SysUtils,StdCtrls

function SudanFunction(N,X,Y: integer): integer;
begin
if n = 0 then Result:=X + Y
else if y = 0 then Result:=X
else Result:=SudanFunction(N - 1, SudanFunction(N, X, Y - 1), SudanFunction(N, X, Y - 1) + Y);
end;

procedure ShowSudanFunction(Memo: TMemo; N,X,Y: integer);
begin
Memo.Lines.Add(Format('Sudan(%d,%d,%d)=%d',[n,x,y,SudanFunction(N,X,Y)]));
end;

procedure ShowSudanFunctions(Memo: TMemo);
var N,X,Y: integer;
var S: string;
begin
for N:=0 to 1 do
	begin
	Memo.Lines.Add(Format('Sudan(%d,X,Y)',[N]));
	Memo.Lines.Add('Y/X    0   1   2   3   4   5');
	Memo.Lines.Add('----------------------------');
	for Y:=0 to 6 do
		begin
		S:=Format('%2d | ',[Y]);
		for X:=0 to 5 do
			begin
			S:=S+Format('%3d ',[SudanFunction(N,X,Y)]);
			end;
		Memo.Lines.Add(S);
		end;
	Memo.Lines.Add('');
	end;

ShowSudanFunction(Memo, 1, 3, 3);
ShowSudanFunction(Memo, 2, 1, 1);
ShowSudanFunction(Memo, 2, 2, 1);
ShowSudanFunction(Memo, 3, 1, 1);
end;

Implement the Sudan function, a non-primitive recursive function, which takes two arguments (x, y) and returns their computed value based on the defined recursive rules.


$stack = New-Object -TypeName System.Collections.Stack
# or
$stack = [System.Collections.Stack] @()

1, 2, 3, 4 | ForEach-Object {$stack.Push($_)}

$stack -join ", "

implement a stack data structure with basic operations such as push, pop, and check if the stack is empty. It also allows for viewing the topmost element without modifying the stack.


function FibonacciNumber ( $count )
{
    $answer = @(0,1)
    while ($answer.Length -le $count)
    {
        $answer += $answer[-1] + $answer[-2]
    }
    return $answer
}

$count = 8
$answer = @(0,1)
0..($count - $answer.Length) | Foreach { $answer += $answer[-1] + $answer[-2] }
$answer
function fib($n) {
    switch ($n) {
        0            { return 0 }
        1            { return 1 }
        { $_ -lt 0 } { return [Math]::Pow(-1, -$n + 1) * (fib (-$n)) }
        default      { return (fib ($n - 1)) + (fib ($n - 2)) }
    }
}

generate the nth Fibonacci number, using either an iterative or recursive approach. The function also optionally supports negative index values in the Fibonacci sequence.


$array = -15..37
$array | Where-Object { $_ % 2 -eq 0 }

select certain elements from an array into a new array in a generic way. Specifically, it selects all even numbers from an array. Optionally, it can also filter destructively by modifying the original array instead of creating a new one.


# test string
$s = "abcdefgh"
# test parameters
$n, $m, $c, $s2 = 2, 3, [char]'d', $s2 = 'cd'

# starting from n characters in and of m length
# n = 2, m = 3
$s.Substring($n-1, $m)              # returns 'bcd'

# starting from n characters in, up to the end of the string
# n = 2
$s.Substring($n-1)                  # returns 'bcdefgh'

# whole string minus last character
$s.Substring(0, $s.Length - 1)      # returns 'abcdefg'

# starting from a known character within the string and of m length
# c = 'd', m =3
$s.Substring($s.IndexOf($c), $m)    # returns 'def'

# starting from a known substring within the string and of m length
# s2 = 'cd', m = 3
$s.Substring($s.IndexOf($s2), $m)   # returns 'cde'

- Displays a substring starting from a specified character index and of a given length.
- Displays a substring starting from a specified character index to the end of the string.
- Displays the entire string excluding the last character.
- Displays a substring starting from a known character within the string and of a specified length.
- Displays a substring starting from a known substring within the string and of a specified length.
- Supports any valid Unicode code point in UTF-8 or UTF-16 encoding.
- References logical characters (code points) instead of 8-bit code units for UTF-8 or 16-bit code units for UTF-16.
- Adjusts character indexes by reducing by one for .NET and PowerShell due to their zero-based indexing.


$s = "asdf"

Works with: PowerShell version 1
[string]::Join('', $s[$s.Length..0])
Works with: PowerShell version 2
-join ($s[$s.Length..0])
Works with: PowerShell version 2
[array]::Reverse($s)

Works with: PowerShell version 1
$s -replace
      ('(.)' * $s.Length),
      [string]::Join('', ($s.Length..1 | ForEach-Object { "`$$_" }))
Works with: PowerShell version 2
$s -replace
      ('(.)' * $s.Length),
      -join ($s.Length..1 | ForEach-Object { "`$$_" } )
Works with: PowerShell version 3
[Regex]::Matches($s,'.','RightToLeft').Value -join ''

$a = 'abc 🐧 def'
$enum = $a.EnumerateRunes() | % { "$_" }
-join $enum[$enum.length..0] # fed 🐧 cba

$a = "aeiou`u{0308}yz"
$enum = [System.Globalization.StringInfo]::GetTextElementEnumerator($a)
$arr = @()
while($enum.MoveNext()) { $arr += $enum.GetTextElement() }
[array]::reverse($arr)
$arr -join '' # zyüoiea

The code takes a string input, reverses it and outputs the reversed string. It also preserves Unicode combining characters during the reversal. It creates a character array from the end to the start of the string and joins it into a new string. It uses a regular expression substitution to capture every character of the string and constructs the reversed string. It also enumerates Unicode codepoints for multi-byte characters but not for composing or joining. For composing or joining, it enumerates graphemes.


$r = New-Object Random
for () {
    $n = $r.Next(20)
    Write-Host $n
    if ($n -eq 10) {
        break
    }
    Write-Host $r.Next(20)
}

generate and print random numbers from 0 to 19. If the generated number is 10, the loop stops. If the number is not 10, a second random number is generated and printed before the loop restarts. If 10 is never generated, the loop runs indefinitely.


$document = [xml]@'
<inventory title="OmniCorp Store #45x10^3">

    <item upc="123456789" stock="12">
      <name>Invisibility Cream</name>
      <price>14.50</price>
      <description>Makes you invisible</description>
    </item>
    <item upc="445322344" stock="18">
      <name>Levitation Salve</name>
      <price>23.99</price>
      <description>Levitate yourself for up to 3 hours per application</description>
    </item>

    <item upc="485672034" stock="653">
      <name>Blork and Freen Instameal</name>
      <price>4.95</price>
      <description>A tasty meal in a tablet; just add water</description>
    </item>
    <item upc="132957764" stock="44">
      <name>Grob winglets</name>
      <price>3.56</price>
      <description>Tender winglets of Grob. Just add water</description>
    </item>

</inventory>
'@

$query = "/inventory/section/item"
$items = $document.SelectNodes($query)

$items[0]

The code performs three XPath queries on a given XML document. It retrieves the first "item" element, prints out each "price" element, and gathers an array of all the "name" elements. The XML document is cast as [xml] to access .NET methods for XML manipulation.


[System.Collections.Generic.HashSet[object]]$set1 = 1..4
[System.Collections.Generic.HashSet[object]]$set2 = 3..6

#            Operation           +     Definition      +          Result
#--------------------------------+---------------------+-------------------------
$set1.UnionWith($set2)           # Union                 $set1 = 1, 2, 3, 4, 5, 6
$set1.IntersectWith($set2)       # Intersection          $set1 = 3, 4
$set1.ExceptWith($set2)          # Difference            $set1 = 1, 2
$set1.SymmetricExceptWith($set2) # Symmetric difference  $set1 = 1, 2, 6, 5
$set1.IsSupersetOf($set2)        # Test superset         False
$set1.IsSubsetOf($set2)          # Test subset           False
$set1.Equals($set2)              # Test equality         False
$set1.IsProperSupersetOf($set2)  # Test proper superset  False
$set1.IsProperSubsetOf($set2)    # Test proper subset    False

5 -in $set1                      # Test membership       False
7 -notin $set1                   # Test non-membership   True

demonstrate various set operations including set creation, element testing, union, intersection, difference, subset, and equality. It also optionally shows additional set operations and modifications to a mutable set. The implementation can be done using an associative array, binary search tree, hash table, or an ordered array of binary bits. The basic element test operation's complexity varies based on the implementation. The code also explores the use of the HashSet type in .NET, specifically in PowerShell.


2008..2121 | Where-Object { (Get-Date $_-12-25).DayOfWeek -eq "Sunday" }
function Get-ChristmasHoliday
{
    [CmdletBinding()]
    [OutputType([PSCustomObject])]
    Param
    (
        [Parameter(Mandatory=$false,
                   ValueFromPipeline=$true,
                   ValueFromPipelineByPropertyName=$true,
                   Position=0)]
        [ValidateRange(1,9999)]
        [int[]]
        $Year = (Get-Date).Year
    )

    Process
    {
        [datetime]$christmas = Get-Date $Year/12/25

        switch ($christmas.DayOfWeek)
        {
            "Sunday"   {[datetime[]]$dates = 1..5 | ForEach-Object {$christmas.AddDays($_)}}
            "Monday"   {[datetime[]]$dates = $christmas, $christmas.AddDays(1)}
            "Saturday" {[datetime[]]$dates = $christmas.AddDays(-2), $christmas.AddDays(-1)}
            Default    {[datetime[]]$dates = $christmas.AddDays(-1), $christmas}
        }

        $dates | Group-Object  -Property Year |
                 Select-Object -Property @{Name="Year"     ; Expression={$_.Name}},
                                         @{Name="DayOfWeek"; Expression={$christmas.DayOfWeek}},
                                         @{Name="Christmas"; Expression={$christmas.ToString("MM/dd/yyyy")}},
                                         @{Name="DaysOff"  ; Expression={$_.Group | ForEach-Object {$_.ToString("MM/dd/yyyy")}}}
    }
}

2008..2121 | Get-ChristmasHoliday | where DayOfWeek -match Su

1. Determines the years between 2008 and 2121 when Christmas falls on a Sunday.
2. Uses standard date handling libraries to perform the calculation.
3. Compares the calculated dates with outputs from other languages to identify any discrepancies due to issues like overflow in date/time representation.
4. Provides the number of days off for a random year.
5. Calculates the days off for the current year using the Year property returned by Get-Date.
6. Returns the days off for the current year as [DateTime] objects.


The code performs QR decomposition of a given matrix using the Householder reflections method. It demonstrates this decomposition on a specific example matrix and uses it to solve linear least squares problems. The code also handles cases where the matrix is not square by cutting off zero padded bottom rows. Finally, it solves the square upper triangular system by back substitution.


$data = 1,2,3,1,2,3,4,1

$h = @{}
foreach ($x in $data) {
    $h[$x] = 1
}
$h.Keys

$data | Sort-Object -Unique

$data | Select-Object -Unique

implement three methods to remove duplicate elements from an array. The first method uses a hash table, the second one sorts the elements before removing duplicates, and the third one iterates through the list to discard any recurring elements. Additionally, the code includes the use of Sort-Object and Select-Object cmdlets for sorting and removing duplicates respectively.


Function SortThree( [Array] $data )
{
	if( $data[ 0 ] -gt $data[ 1 ] )
	{
		if( $data[ 0 ] -lt $data[ 2 ] )
		{
			$data = $data[ 1, 0, 2 ]
		} elseif ( $data[ 1 ] -lt $data[ 2 ] ){
			$data = $data[ 1, 2, 0 ]
		} else {
			$data = $data[ 2, 1, 0 ]
		}
	} else {
		if( $data[ 0 ] -gt $data[ 2 ] )
		{
			$data = $data[ 2, 0, 1 ]
		} elseif( $data[ 1 ] -gt $data[ 2 ] ) {
			$data = $data[ 0, 2, 1 ]
		}
	}
	$data
}

Function QuickSort( [Array] $data, $rand = ( New-Object Random ) )
{
	$datal = $data.length
	if( $datal -gt 3 )
	{
		[void] $datal--
		$median = ( SortThree $data[ 0, ( $rand.Next( 1, $datal - 1 ) ), -1 ] )[ 1 ]
		$lt = @()
		$eq = @()
		$gt = @()
		$data | ForEach-Object { if( $_ -lt $median ) { $lt += $_ } elseif( $_ -eq $median ) { $eq += $_ } else { $gt += $_ } }
		$lt = ( QuickSort $lt $rand )
		$gt = ( QuickSort $gt $rand )
		$data = @($lt) + $eq + $gt
	} elseif( $datal -eq 3 ) {
		$data = SortThree( $data )
	} elseif( $datal -eq 2 ) {
		if( $data[ 0 ] -gt $data[ 1 ] )
		{
			$data = $data[ 1, 0 ]
		}
	}
	$data
}

QuickSort 5,3,1,2,4
QuickSort 'e','c','a','b','d'
QuickSort 0.5,0.3,0.1,0.2,0.4
$l = 100; QuickSort ( 1..$l | ForEach-Object { $Rand = New-Object Random }{ $Rand.Next( 0, $l - 1 ) } )

function quicksort($array) {
    $less, $equal, $greater = @(), @(), @()
    if( $array.Count -gt 1 ) {
        $pivot = $array[0]
        foreach( $x in $array) {
            if($x -lt $pivot) { $less += @($x) }
            elseif ($x -eq $pivot) { $equal += @($x)}
            else { $greater += @($x) }
        }
        $array = (@(quicksort $less) + @($equal) + @(quicksort $greater))
    }
    $array
}
$array = @(60, 21, 19, 36, 63, 8, 100, 80, 3, 87, 11)
"$(quicksort $array)"
The output is: 3 8 11 19 21 36 60 63 80 87 100

function quicksort($in) {
    $n = $in.count
    switch ($n) {
        0 {}
        1 { $in[0] }
        2 { if ($in[0] -lt $in[1]) {$in[0], $in[1]} else {$in[1], $in[0]} }
        default {
            $pivot = $in | get-random
            $lt = $in | ? {$_ -lt $pivot}
            $eq = $in | ? {$_ -eq $pivot}
            $gt = $in | ? {$_ -gt $pivot}
            @(quicksort $lt) + @($eq) + @(quicksort $gt)
        }
    }
}

implement the quicksort algorithm to sort an array or list. The algorithm works by choosing a pivot element and dividing the rest of the elements into two partitions, one with elements less than the pivot and the other with elements greater than the pivot. It then recursively sorts these partitions and joins them with the pivot to form the sorted array. The codes also include an optimized version of quicksort that works in place by swapping elements within the array to avoid additional memory allocation. The pivot selection method is not specified and can vary.


"{0:yyyy-MM-dd}" -f (Get-Date)
"{0:dddd, MMMM d, yyyy}" -f (Get-Date)
# or
(Get-Date).ToString("yyyy-MM-dd")
(Get-Date).ToString("dddd, MMMM d, yyyy")

display the current date in the formats "2007-11-23" and "Friday, November 23, 2007", respecting the currently set locale for names of months and days.


function power-set ($array) {
    if($array) {
        $n = $array.Count
        function state($set, $i){
            if($i -gt -1) {
                state $set ($i-1)
                state ($set+@($array[$i])) ($i-1)
            } else {
                "$($set | sort)"
            }
        }
        $set = state @() ($n-1)
        $power = 0..($set.Count-1) | foreach{@(0)}
        $i = 0
        $set | sort | foreach{$power[$i++] = $_.Split()}
        $power | sort {$_.Count}
    } else {@()}

}
$OFS = " "
$setA = power-set  @(1,2,3,4)
"number of sets in setA: $($setA.Count)"
"sets in setA:"
$OFS = ", "
$setA | foreach{"{"+"$_"+"}"}
$setB = @()
"number of sets in setB: $($setB.Count)"
"sets in setB:"
$setB | foreach{"{"+"$_"+"}"}
$setC = @(@(), @(@()))
"number of sets in setC: $($setC.Count)"
"sets in setC:"
$setC | foreach{"{"+"$_"+"}"}
$OFS = " "

number of sets in setA: 16
sets in setA:
{}
{1}
{2}
{3}
{4}
{1, 2}
{1, 3}
{1, 4}
{2, 3}
{2, 4}
{3, 4}
{1, 2, 3}
{1, 2, 4}
{1, 3, 4}
{2, 3, 4}
{1, 2, 3, 4}
number of sets in setB: 0
sets in setB:
number of sets in setC: 2
sets in setC:
{}
{}

implement a function that takes a set as input and returns its power set. The power set includes all possible subsets of the input set, including the empty set and the set itself. The function also demonstrates the ability to generate power sets of the empty set and a set containing only the empty set.


Filter ToRoman {
	$output = ''

	if ($_ -ge 4000) {
		throw 'Number too high'
	}

	$current = 1000
	$subtractor = 'M'
	$whole = $False
	$decimal = $_
	'C','D','X','L','I','V',' ' `
	| %{
		$divisor = $current
		if ($whole = !$whole) {
			$current /= 10
			$subtractor = $_ + $subtractor[0]
			$_ = $subtractor[1]
		}
		else {
			$divisor *= 5
			$subtractor = $subtractor[0] + $_
		}

		$multiple = [Math]::floor($decimal / $divisor)
		if ($multiple) {
			$output += [string]$_ * $multiple
			$decimal %= $divisor
		}
		if ($decimal -ge ($divisor -= $current)) {
			$output += $subtractor
			$decimal -= $divisor
		}
	}

	$output
}
19,4,0,2479,3001 | ToRoman

create a function that converts a positive integer into its equivalent Roman numeral representation.