Pascal Programming Examples

Ordering

pascal

program Ordering;

var
  sortArray: array [0..9] of integer;
  count, tempNumber: integer;
  mode: string;
  swapMade: boolean;

begin
  repeat
    write('Ascending [1] or descending [2]? ');
    readln(mode);
  until (mode = '1') or (mode = '2');
  for count := 0 to 9 do
    begin
      write('Enter a number: ');
      readln(tempNumber);
      sortArray[count] := tempNumber;
    end;
  repeat
    swapMade := false;
    for count := 0 to 8 do
      if sortArray[count] > sortArray[count + 1] then
        begin
          tempNumber := sortArray[count];
          sortArray[count] := sortArray[count + 1];
          sortArray[count + 1] := tempNumber;
          swapMade := true;
        end;
  until not swapMade;
  if mode = '1' then
    for count := 0 to 9 do
      writeln(sortArray[count]);
  if mode = '2' then
    for count := 0 to 9 do
      writeln(sortArray[9 - count]);
  readln;
end.

Fibbing

pascal

program Fibbing;

var
  places, count, total: integer;
  sequence: array of integer;

procedure setSequence ();
begin
  setlength(sequence, places);
  sequence[0] := 1;
  sequence[1] := 1;
  for count := 2 to places - 1 do
      sequence[count] := sequence[count - 1] + sequence[count - 2];
end;

begin
  writeln('How many places?');
  readln(places);
  setSequence();
  write('Sequence:');
  for count := 0 to places - 1 do
    write(' ', sequence[count]);
  writeln;
  write('Reverse:');
  for count := 1 to places do
    write(' ', sequence[places - count]);
  writeln;
  total := 0;
  for count := 0 to places - 1 do
    total += sequence[count];
  writeln('Total: ', total);
  readln;
end.

indovina un numero

pascal

program indovina_un_numero;
var
c:integer;
ncasuale:integer;
n:integer;
begin
randomize;
c:=0;
n:=0;
writeln('ora penso a un numero e tu dovrai indovinarlo');
ncasuale:=random(99)+1;
while n <> ncasuale do
begin
c:=c+1;
readln(n);
if n < ncasuale then
writeln('il numero che hai scelto e più basso del mio');
if n > ncasuale then
writeln('il numero che hai scelto e più alto del mio');
end;
writeln('complimenti, hai indovinato il numero con',c,'tentativi');
readln;
end.

FTREAP

pascal

(* (C) I. Kakoulidis *)
{$mode objfpc}{$H+}{$J-}
{$ASSERTIONS ON}
{$warnings on}
{$hints on}
{$R+}{$Q+}

program ftreapapp;
 
uses SysUtils, gset, gutil;
 
type
  generic TTreapNode<T> = class
  private
    // Key
    FKey: T;
    // Random heap priority
    FPriority: extended;
    // Number of nodes in subtree
    FSize: SizeUInt;
    // Left subtree reference
    FLeft: TTreapNode;
    // Right subtree reference
    FRight: TTreapNode;
  public
    (* Tree node constructor. *)
    constructor Create(const k: T);
 
    (* Tree node destructor. *)
    destructor Destroy; override;
 
    (* Returns number of keys in the tree rooted at @code(node). *)
    class function GetSize(const node: TTreapNode): SizeUInt; inline;
 
    (* Recalculates number of keys in the tree rooted at @code(node) after insert, delete operations. *)
    class procedure UpdateSize(const node: TTreapNode); inline;
 
    (* Creates new tree from two trees, where @code(Min(r) >= Max(l)). *)
    class function Meld(l, r: TTreapNode): TTreapNode;
 
    (* Divides tree into two trees. Where @code(Max(l) <= k). *)
    class procedure Divide(node: TTreapNode; k: T; var l, r: TTreapNode);
 
    (* Divides tree into two trees. Where @code(Size(l) = pos). *)
    class procedure DivideAt(node: TTreapNode; const pos: SizeUInt;
      var l, r: TTreapNode);
 
    (* Returns @true if tree rooted at @code(node) is empty, @false otherwise *)
    class function IsEmpty(const node: TTreapNode): boolean; inline;
 
    (* Insert key @code(k) in tree rooted at @code(node). *)
    class procedure Insert(var node: TTreapNode; const k: T); inline;
 
    (* Check if tree rooted at @code(root) node contains key @code(k). *)
    class function Contains(node: TTreapNode; const k: T): boolean; inline;
 
    (* Number of keys less than @code(k) *)
    class function BisectLeft(node: TTreapNode; const k: T): SizeUInt;
    (* Number of keys less or equal @code(k) *)
    class function BisectRight(node: TTreapNode; const k: T): SizeUInt;
 
    class function GetPosition(node: TTreapNode; const k: T): SizeUInt;
 
    (* @raises(EArgumentException) *)
    class function GetAt(node: TTreapNode; pos: SizeUInt): T;
 
    (* Removes key from the tree.
       @returns(@true if successful, @false otherwise) *)
    class function Remove(var node: TTreapNode; const k: T): boolean;
 
    (* Removes key from the given position.
       @returns(key) *)
    class function RemoveAt(var node: TTreapNode; const pos: SizeUInt): T;
 
    (* Destroy tree. *)
    class procedure DestroyTreap(var node: TTreapNode);
 
    class function CheckStucture(node: TTreapNode): boolean;
  end;
 
//
// TTreapNode Class methods
//
constructor TTreapNode.Create(const k: T);
begin
  FKey := k;
  FPriority := Random;
  FSize := 1;
  FLeft := nil;
  FRight := nil;
end;
 
destructor TTreapNode.Destroy;
begin
  FLeft := nil;
  FRight := nil;
  inherited;
end;
 
// PASSED
class function TTreapNode.GetSize(const node: TTreapNode): SizeUInt; inline;
begin
  if node <> nil then
    Exit(node.FSize);
  Exit(0);
end;
 
// PASSED
class procedure TTreapNode.UpdateSize(const node: TTreapNode); inline;
begin
  if node <> nil then
    node.FSize := GetSize(node.FLeft) + GetSize(node.FRight) + 1;
end;
 
class function TTreapNode.IsEmpty(const node: TTreapNode): boolean; inline;
begin
  Exit(node = nil);
end;
 
class function TTreapNode.Meld(l, r: TTreapNode): TTreapNode;
begin
  if l = nil then
    Exit(r);
  if r = nil then
    Exit(l);
  if l.FPriority > r.FPriority then
  begin
    l.FRight := Meld(l.FRight, r);
    Result := l;
  end
  else
  begin
    r.FLeft := Meld(l, r.FLeft);
    Result := r;
  end;
  UpdateSize(Result);
end;
 
class procedure TTreapNode.DivideAt(node: TTreapNode; const pos: SizeUInt;
  var l, r: TTreapNode);
begin
  if node = nil then
  begin
    l := nil;
    r := nil;
    Exit
  end;
  if pos > GetSize(node.FLeft) then
  begin
    DivideAt(node.FRight, pos - GetSize(node.FLeft) - 1, node.FRight, r);
    l := node
  end
  else
  begin
    DivideAt(node.FLeft, pos, l, node.FLeft);
    r := node
  end;
  UpdateSize(node)
end;
 
// DivideRight
class procedure TTreapNode.Divide(node: TTreapNode; k: T; var l, r: TTreapNode);
begin
  if node = nil then
  begin
    l := nil;
    r := nil;
    Exit;
  end;
  if k < node.FKey then
  begin
    Divide(node.FLeft, k, l, node.FLeft);
    r := node;
  end
  else
  begin
    Divide(node.FRight, k, node.FRight, r);
    l := node;
  end;
  UpdateSize(node);
end;
 
class procedure TTreapNode.Insert(var node: TTreapNode; const k: T); inline;
var
  l: TTreapNode = nil;
  r: TTreapNode = nil;
begin
  Divide(node, k, l, r);
  node := Meld(l, Meld(TTreapNode.Create(k), r));
end;
 
// PASSED
class function TTreapNode.Contains(node: TTreapNode; const k: T): boolean; inline;
begin
  while node <> nil do
  begin
    if k = node.FKey then
      Exit(True);
    if k > node.FKey then
      node := node.FRight
    else
      node := node.FLeft;
  end;
  Exit(False);
end;
 
class function TTreapNode.BisectLeft(node: TTreapNode; const k: T): SizeUInt;
var
  pos: SizeUInt = 0;
begin
  while node <> nil do
  begin
    if k > node.FKey then
    begin
      pos := pos + GetSize(node.FLeft) + 1;
      node := node.FRight;
    end
    else
      node := node.FLeft;
  end;
  Exit(pos);
end;
 
class function TTreapNode.BisectRight(node: TTreapNode; const k: T): SizeUInt;
var
  pos: SizeUInt = 0;
begin
  while node <> nil do
  begin
    if k < node.FKey then
      node := node.FLeft
    else
    begin
      pos := pos + GetSize(node.FLeft) + 1;
      node := node.FRight;
    end;
  end;
  Exit(pos);
end;
 
// PASSED
class function TTreapNode.GetPosition(node: TTreapNode; const k: T): SizeUInt;
var
  pos: SizeUInt = 0;
begin
  while node <> nil do
  begin
    if k = node.FKey then
      Exit(pos + GetSize(node.FLeft));
    if k > node.FKey then
    begin
      pos := pos + GetSize(node.FLeft) + 1;
      node := node.FRight;
    end
    else
      node := node.FLeft;
  end;
  raise Exception.Create('No such key');
end;
 
// PASSED
class function TTreapNode.GetAt(node: TTreapNode; pos: SizeUInt): T;
var
  lsize: SizeUInt = 0;
begin
  if (node = nil) or (pos > GetSize(node) - 1) then
    raise EArgumentException.Create('Set is empty or position is out of range.');
  while node <> nil do
  begin
    lsize := GetSize(node.FLeft);
    if pos = lsize then
      Exit(node.FKey);
    if pos > lsize then
    begin
      node := node.FRight;
      pos := pos - lsize - 1;
    end
    else
      node := node.FLeft;
  end;
  raise Exception.Create('Unreachable point.');
end;
 
class function TTreapNode.Remove(var node: TTreapNode; const k: T): boolean;
var
  n: TTreapNode;
begin
  Result := False;
  if node <> nil then
  begin
    if k = node.FKey then
    begin
      n := node;
      node := Meld(node.FLeft, node.FRight);
      FreeAndNil(n);
      Exit(True);
    end;
    if k > node.FKey then
      Result := Remove(node.FRight, k)
    else
      Result := Remove(node.FLeft, k);
    if Result then
      UpdateSize(node);
  end;
end;
 
// RWRT
class function TTreapNode.RemoveAt(var node: TTreapNode; const pos: SizeUInt): T;
var
  n: TTreapNode;
begin
  if (node = nil) or (pos > GetSize(node) - 1) then
    raise EArgumentException.Create('Set is empty or position is out of range.');
  if pos = GetSize(node.FLeft) then
  begin
    Result := node.FKey;
    n := node;
    node := Meld(node.FLeft, node.FRight);
    FreeAndNil(n);
    Exit;
  end;
  if pos > GetSize(node.FLeft) then
    Result := RemoveAt(node.FRight, pos - GetSize(node.FLeft) - 1)
  else
    Result := RemoveAt(node.FLeft, pos);
  UpdateSize(node);
end;
 
class procedure TTreapNode.DestroyTreap(var node: TTreapNode);
begin
  if node <> nil then
  begin
    DestroyTreap(node.FLeft);
    DestroyTreap(node.FRight);
    FreeAndNil(node);
  end;
end;
 
class function TTreapNode.CheckStucture(node: TTreapNode): boolean;
begin
  Result := True;
  if node = nil then
    Exit(Result);
  with node do
  begin
    Result := Result and CheckStucture(node.FLeft);
    Result := Result and CheckStucture(node.FRight);
    Result := Result and (GetSize(node) = GetSize(node.FLeft) +
      GetSize(node.FRight) + 1);
    if node.FLeft <> nil then
    begin
      Result := Result and (node.FPriority >= node.FLeft.FPriority);
      Result := Result and ((node.FKey > node.FLeft.FKey) or
        (node.FKey = node.FLeft.FKey));
    end;
    if node.FRight <> nil then
    begin
      Result := Result and (node.FPriority >= node.FRight.FPriority);
      Result := Result and (node.FKey < node.FRight.FKey);
    end;
  end;
end;
 
type
  TInt64TreapNode = specialize TTreapNode<Int64>;

  iLess = specialize TLess<Int64>;
  iSet = specialize TSet<Int64,iLess>;  
 
var
  ra: TInt64TreapNode = nil;
  i: longint;
  ct: QWord;
  
  S : iSet;
 
begin
  Randomize;
  ct := GetTickCount64; 
  for i:= 1 to 1600000 do
  begin
    TInt64TreapNode.Insert(ra, Random(9223372036854775807));
  end;
  Writeln('Treap Ticks - ', GetTickCount64 - ct);
  WriteLn('Treap Size - ', TInt64TreapNode.GetSize(ra));

  ct := GetTickCount64;
  S := iSet.Create();
  for i := 1  to 1600000 do 
    S.Insert(Random(9223372036854775807));
  Writeln('GSet Ticks - ', GetTickCount64 - ct);
  Writeln('GSet Size - ', S.Size);
  
end.
(*
100000 - 0.08s
200000 - 0.19s
400000 - 0.42s
800000 - 1.06s
1600000 - 2.58s
*)

program n_8; var a,b,c: real; begin writeln ('Ð’Ð²ÐµÐ´Ð¸Ñ‚Ðµ Ð´Ð»Ð¸Ð½Ñ‹ ÑÑ‚Ð¾Ñ€Ð¾Ð½ Ñ‚Ñ€ÐµÑƒÐ³Ð¾Ð»ÑŒÐ½Ð¸ÐºÐ°'); readln (a,b,c); If a+b<c or b+c<a or c+a<b then writeln ('Ð¢Ð°ÐºÐ¾Ð³Ð¾ Ñ‚Ñ€ÐµÑƒÐ³Ð¾Ð»ÑŒÐ½Ð¸ÐºÐ° Ð½Ðµ ÑÑƒÑ‰ÐµÑÑ‚Ð²ÑƒÐµÑ‚') end.

pascal

program n_8;
var a,b,c: real;
begin
writeln ('Введите длины сторон треугольника');
readln (a,b,c);
If a+b<c or b+c<a or c+a<b then writeln ('Такого треугольника не существует')
end.
begin
if a=b or b=c or a=c and a>c or a<c or b>c or b<c or a<b or a>b then writeln ('Этот треуголник равнобедренный') 
end.

Compile and Execute Pascal Online

pascal

Program HelloWorld(output);
uses crt;
var
	Text1,text2:string;
	fn1,fn2,fn : integer;
	counter,selesai : Integer;
begin
    selesai := 10;
	fn1 := 0;
	fn2 := 1;
	fn :=0;
	for counter := 1 to Selesai do
	begin
	    fn := fn1 + fn2;
	    writeln(counter:2,' --> ',fn1:2,' + ',fn2:2,' = ',fn:2);
	    fn1 := fn2;
		fn2 := fn;
	end;
end.

summ

pascal

Program HelloWorld(output);
begin
  writeln('Hello, world!');
end.

summ

pascal

Program HelloWorld(output);
begin
  writeln('Hello, world!');
end.

reversenumber

pascal

Program ReveseNum;
var a,b,c,d,temp:integer;
begin
  writeln('Input a number with 4 digit.');
  readln(a,b,c,d);
  temp:=d;
  d:=a;
  a:=temp;
  temp:=b;
  b:=c;
  c:=temp;
  writeln('The number in revrse order is ',a,b,c,d,'.');
end.

pascal

Program orderBySimpleValue(output);
var initialArray,outputArray:  array[1..10] of integer;
var collectArray: array[1..3,1..10] of integer;
var n:integer;
function isSimple(n:integer):boolean;
var t:boolean;
  var i:integer;
  begin
    t :=true;
    if n<2 then begin
        isSimple:=false;
        exit;
    end;
	for i:= 2 to n-1 do
	
     begin
  		if (n mod i) = 0  then
        begin
            t :=false;
            break;
        end;
        
      end;
     isSimple :=t;
  end;
procedure input();
    var i:integer;
    begin
        for i:=1 to n do begin
            initialArray[i] := Random(30)+5;
            writeln(initialArray[i]);
            end;
    end;
procedure getCollectArray();
    var i,firstSimple, k1, k2, k3:integer;
    begin
        firstSimple := 0;
        k1:=1;
        k2:=1;
        k3:=1;
        for i:=1 to n do
            if (firstSimple = 0) and (isSimple(initialArray[i]) ) then 
            begin    
                firstSimple := initialArray[i];
                break;
            end;
        for i:=1 to n do
            begin
                if initialArray[i] < firstSimple then begin 
                    collectArray[1][k1]:= initialArray[i];
                    k1:=k1+1;
                end;
                if initialArray[i] = firstSimple then begin 
                    collectArray[2][k2]:=initialArray[i];
                    k2:=k2+1;
                end;
                if initialArray[i] > firstSimple then begin 
                    collectArray[3][k3]:=initialArray[i];
                    k3:=k3+1;
                end;
            end;
            writeln('simple', firstSimple);
    end;
    
    procedure outputResult();
        var i,j,outputIndex:integer;
        begin
        outputIndex:= 1;
        for i := 1 to 3 do
            for j:=1 to n do begin 
                if collectArray[i][j] = 0 then break;
                outputArray[outputIndex]:= collectArray[i][j];
                writeln(outputArray[outputIndex]);
                outputIndex := outputIndex + 1;
                
            end; 
        end;
begin
  n:=10;
  input();
  getCollectArray();
  outputResult();
end.

Follow

Newsletter