Раздел «Алгоритмы».FreePascalSamples:

Примеры на FreePascal

All Source For fpascal
Ackermann's Function
program ackermann;
uses SysUtils;

function Ack(M, N : integer) : integer;
begin    
    if M = 0 then Ack := N+1
    else if N = 0 then Ack := Ack(M-1, 1)
    else Ack := Ack(M-1, Ack(M, N-1))
End;

var NUM, a : integer;

begin
    if ParamCount = 0 then
        NUM := 1
    else
        NUM := StrToInt(ParamStr(1));
        
    if NUM < 1 then NUM := 1;
    a := Ack(3, NUM);
    WriteLn( 'Ack(3,' + IntToStr(NUM) + '): ' + IntToStr(a) );
end.
Array Access
Program ary3;
uses SysUtils, Classes;

var
    n, i, k, last : longint;
    X, Y : TList;
begin
    if ParamCount = 0 then
        n := 1
    else
        n := StrToInt(ParamStr(1));
        
    if n < 1 then n := 1;
    
    last := n - 1;
    X := TList.Create;
    X.Capacity := n;
    For i := 0 To last do
        X.Add( Pointer(i+1) );
    
    Y := TList.Create;
    Y.Capacity := n;
    For i := 0 To last do
        Y.Add( Pointer(0) );
    
    
    For k := 0 To 999 do
    begin
        For i := last downto 0 do
        begin
            Y.Items[i] := Pointer(longint(Y.Items[i]) + longint(X.Items[i]));
        end;
    end;
    Writeln (IntToStr(longint(Y.Items[0])), ' ', IntToStr(longint(Y.Items[last])));
end.
Count Lines/Words/Chars
program wc;


uses SysUtils;

var
    nl, nw, nc: longint;
    Buf: array[1..4096] of byte;
    NumRead: Integer;

    A: Integer;
    Tmp: String;
    TmpPos : Byte;
    Ch: String;
    InWord: Boolean;
begin
    nl := 0;
    nc := 0;
    nw := 0;
    InWord := False;
    NumRead := FileRead(StdInputHandle, Buf, 4096);
    While NumRead > 0 Do
    begin
        Inc(nc, NumRead);
        For A := 1 To NumRead Do
        begin
            if Buf[A] = 10 Then Inc(nl);
            if Buf[A] = 13 Then Dec(nc);
            if (Buf[A] = 32) Or (Buf[A] = 10) Or (Buf[A] = 13) Or (Buf[A] = 9) Then 
                InWord := False
            else
            begin
                If InWord = False Then
                begin
                    Inc(nw);
                    InWord := True;
                end;
            end;
        end;
        NumRead := FileRead(StdInputHandle, Buf, 4096);
    end;
    WriteLn(IntToStr(nl) + ' ' + IntToStr(nw) + ' ' + IntToStr(nc));
end.
Fibonacci Numbers
program fibo;
uses SysUtils;

function fib(N : integer) : longint;
begin    
    if N < 2 then fib := 1
    else fib := fib(N-2) + fib(N-1);
End;

var 
    NUM : integer;
    f : longint;

begin
    if ParamCount = 0 then
        NUM := 1
    else
        NUM := StrToInt(ParamStr(1));
        
    if NUM < 1 then NUM := 1;
    f := fib(NUM);
    WriteLn( IntToStr(f) );
end.
Hash (Associative Array) Access
Program hash;

uses SysUtils, Classes;


type
   THashEntryPtr = ^THashEntryRec;
   THashEntryRec = record
      name : string;
      number : longint;
      next : THashEntryPtr;
   end;

const
   TABLE_SIZE = 100000;

type THash = class
    private
        hashtable : array[0..TABLE_SIZE - 1] of THashEntryRec;
        function hash(s : string) : longint;
    public
        constructor Create;
        function store(name : string; number : longint; var error : longint) : boolean;
        function fetch(name : string; var number : longint) : boolean;
        function exists(name : string) : boolean;
end;

constructor THash.Create;
var
   i : longint;
begin
   for i := 0 to TABLE_SIZE - 1 do
      hashtable[i].next := nil;
end;


function THash.hash(s : string) : longint;
var
   i, j : longint;
begin
    if length(s) = 0 then Result := 0
    else
    begin
        j := ord(s[1]) mod TABLE_SIZE;
        for i := 2 to length(s) do
            j := (j shl 8 + ord(s[i])) mod TABLE_SIZE;
        Result := j;
    end;
end;

function THash.store(name : string; number : longint; var error : longint) : boolean;
var
   node, prev : THashEntryPtr;
begin
   error := 0;

   prev := @hashtable[hash(name)];
   node := prev^.next;
   
   while (node <> nil) and (node^.name <> name) do
   begin
      prev := node;
      node := node^.next;
   end;

   if node <> nil then error := 1
   else begin
      new(prev^.next);
      node := prev^.next;
      if node = nil then error := -1
      else begin
         node^.name := name;
     node^.number := number;
     node^.next := nil;
      end;
   end;
   
   Result := error = 0;
end;

function THash.fetch(name : string; var number : longint) : boolean;
var
   node : THashEntryPtr;
begin
   node := hashtable[hash(name)].next;
   while (node <> nil) and (node^.name <> name) do
      node := node^.next;
   if node <> nil then number := node^.number;
   Result := node <> nil;
end;

function THash.exists(name : string) : boolean;
var
   node : THashEntryPtr;
begin
   node := hashtable[hash(name)].next;
   while (node <> nil) and (node^.name <> name) do
      node := node^.next;
   Result := node <> nil;
end;
    

var
    n, i, c, err : longint;
    X : THash;
begin
    if ParamCount = 0 then
        n := 1
    else
        n := StrToInt(ParamStr(1));
        
    if n < 1 then n := 1;
    
    X := THash.Create();
    
    For i := 1 To n do
        X.store( Format('%x', [i]), i, err );
    
    c := 0;
    For i:= n downto 1 do
    begin
        if X.exists( IntToStr(i) ) Then Inc(c);
    end;
    
    Writeln (IntToStr(c));
end.
Heapsort
program heapsort;
uses SysUtils, Classes;

const
    IM = 139968;
    IA =   3877;
    IC =  29573;

var 
    ary: TList;
    r : real;
    rr : ^real;
    N, i, LAST : longint;

function gen_random(n : longint) : real;
begin    
    LAST := (LAST * IA + IC) mod IM;
    gen_random := n * LAST / IM;
end;

procedure myheapsort(n : longint; var ra : TList);
var    
    rr : ^real;
    rra : real;
    i, j, l, ir : longint;
begin
    rra := 0;
    i := 0;
    j := 0;
    l := n shr 1 + 1;
    ir := n;
    
    while 1 = 1 do
    begin
        if l > 1 then begin
            Dec(l);
            rra := real(ra.Items[l]^);
        end
        else begin
            rra := real(ra.Items[ir]^);

            

            GetMem(rr, SizeOf(real));
            rr^ := real(ra.Items[1]^);
            ra.items[ir] := rr;                        
            
                        
            Dec(ir);
            if ir = 1 then 
            begin
                

                GetMem(rr, SizeOf(real));
                rr^ := rra;
                ra.items[1] := rr;
                
                exit;
            end;
        end;
        
        i := l;
        j := l shl 1;

        

        while j <= ir do begin
            if (j < ir) and (real(ra.items[j]^) < real(ra.items[j+1]^)) then Inc(j);
            
            
            
            
            if rra < real(ra.items[j]^) then begin
                

                GetMem(rr, SizeOf(real));
                rr^ := real(ra.items[j]^);
                ra.items[i] := rr;
                
                i := j;
                Inc(j, i);
            end
            else begin
                j := ir + 1;
            end;
        end;
        
        GetMem(rr, SizeOf(real));
        rr^ := rra;
        ra.items[i] := rr;
        
    end;
end;
            
begin
    if ParamCount = 0 then
        N := 1
    else
        N := StrToInt(ParamStr(1));
    if N < 1 then N := 1;
    LAST := 42;
    ary := TList.Create;
    ary.Capacity := N;
    r := 0.0;        
    GetMem( rr, SizeOf(real) );
    rr^ := r;        
    ary.Add( rr );
    for i:= 1 to N do begin
        r := gen_random(1);        
        GetMem( rr, SizeOf(real) );
        rr^ := r;        
        
        ary.Add( rr );
    end;
    for i:= 1 to N do begin
        r := real(ary.items[i]^);
        
    end;
    myheapsort(N, ary);
    r := real(ary.items[N]^);
    WriteLn( r:10:10 );
    ary.Free;
end.

Hello World
program hello;
uses SysUtils;

begin
    WriteLn( 'hello world' );
end.
List Operations
Program lists;
uses SysUtils, classes;

const SIZE : longint = 10000;

Function test_lists : integer;
var 
    i, len1, len2 : longint;
    Li1, Li2, Li3 : TList;
    lists_equal : Integer;
begin
        
    Li1 := TList.Create;
    Li1.Capacity := SIZE;
    For i := 0 to SIZE Do
        Li1.Add(Pointer(i));
    
    
    
    Li2 := TList.Create;
    Li2.Capacity := SIZE;
    For i:= 0 to SIZE Do
        Li2.Add(Li1.Items[i]);
    
    { remove each individual item from left side of Li2 and
      append to right side of Li3 (preserving order) }
    Li3 := TList.Create;
    Li3.Capacity := SIZE;
    For i := 0 to SIZE Do
    begin
        Li3.Add( Li2.First );
        Li2.Remove( Li2.First );
    end;
    
    
    { remove each individual item from right side of Li3 and
      append to right side of Li2 (reversing list) }
    For i := 0 To SIZE Do
    begin
        Li2.Add( Li3.Last );
        Li3.Count -= 1;       
    end;

    

    
    For i := 0 To (SIZE div 2) Do
    begin
        Li1.Exchange( i, SIZE-i );
    end;
    
    
    If longint(Li1.first) <> SIZE Then
    begin
        
        test_lists := 0;
        exit;
    end;

       
    len1 := Li1.Count - 1;
    len2 := Li2.Count - 1;
    If  len1 <> len2 Then
    begin
        test_lists := 0;
        exit;
    end;

    lists_equal := 1;    
    For i := 0 To len1 Do
    begin
        If longint(Li1.items[i]) <> longint(Li2.items[i]) Then
        begin
            lists_equal := 0;            
            break;
        end;
    end;
    
    If lists_equal = 0 Then
    begin
        test_lists := 0;
    end
    else
        test_lists := len1;
end;

var
    ITER, i, result: integer;

begin
    if ParamCount = 0 then
        ITER := 1
    else
        ITER := StrToInt(ParamStr(1));
        
    if ITER < 1 then ITER := 1;
    
    For i := 1 To ITER Do result := test_lists();
    Writeln (IntToStr(result));

end.
Matrix Multiplication
program matrix;
uses SysUtils;

const
    size = 30;

type tMatrix = array[0..size, 0..size] of longint;

procedure mkmatrix( rows, cols : integer; var mx : tMatrix);
var 
    R, C : integer;
    count : longint;
begin
    Dec(rows);
    Dec(cols);
    count := 1;
    for R := 0 to rows do
    begin
        for C := 0 to cols do
        begin
            mx[R, C] := count;
            Inc(count);
        end;
    end;
End;

procedure mmult(rows, cols : integer; m1, m2 : tMatrix; var mm : tMatrix );
var
    i, j, k : integer;
    val: longint;
begin
    Dec(rows);
    Dec(cols);    
    For i := 0 To rows do
    begin
        For j := 0 To cols do
        begin
            val := 0;
            For k := 0 To cols do
            begin
                Inc(val, m1[i, k] * m2[k, j]);
            end;
            mm[i, j] := val;
        end;
    end;
End;


var NUM, I : integer;
    M1, M2, MM : tMatrix;

begin
    if ParamCount = 0 then
        NUM := 1
    else
        NUM := StrToInt(ParamStr(1));
        
    if NUM < 1 then NUM := 1;

    mkmatrix(size, size, M1);
    mkmatrix(size, size, M2);
    
    for I := 0 To NUM do
    begin
        mmult(size, size, M1, M2, MM);
    end;
    WriteLn( IntToStr(MM[0, 0]) + ' ' + IntToStr(MM[2, 3]) + ' ' +
             IntToStr(MM[3, 2]) + ' ' + IntToStr(MM[4, 4]));
end.
Method Calls
program methcall;


uses SysUtils;

type TToggle = class 
    private
        value : boolean;

    public
        property Bool : boolean read value write value;
        procedure Activate;
end;    

type TNthToggle = class 
    constructor Create;
    private
        value : boolean;
        counter : integer;
        cmax : integer;
    public
        property CountMax : integer read cmax write cmax;
        property Bool : boolean read value write value;
        procedure Activate;
end;

constructor TNthToggle.Create;
begin
    counter := 0;
end;

procedure TToggle.Activate;
begin
    if value = True Then
        value := False
    else
        value := True;
end;

procedure TNthToggle.Activate;
begin
    counter := counter + 1;
    if counter >= cmax Then begin
        if value = True Then
            value := False
        Else
            value := True;
        counter := 0;
    end;
end;


var 
    NUM, i : longint;
    val : boolean;
    oToggle : TToggle;
    onToggle : TNthToggle;
begin
    if ParamCount = 0 then
        NUM := 1
    else
        NUM := StrToInt(ParamStr(1));
        
    if NUM < 1 then NUM := 1;

    val := True;
    oToggle := TToggle.Create;    
    oToggle.Bool := val;
    For i := 1 to NUM do
    begin
        oToggle.Activate;
        val := oToggle.Bool;
    end;
    If val = True Then
        WriteLn('true')
    else
        WriteLn('false');

    val := True;
    onToggle := TNthToggle.Create;
    onToggle.Bool := val;
    onToggle.CountMax := 3;
    For i := 1 to NUM do
    begin
        onToggle.Activate;
        val := onToggle.Bool;
    end;
    If val = True Then
        WriteLn('true')
    else
        WriteLn('false');
end.
Nested Loops
program nestedloop;
uses SysUtils;

var n, a, b, c, d, e, f : integer;
var x : longint;

begin
    if ParamCount = 0 then
        n := 1
    else
        n := StrToInt(ParamStr(1));
    if n < 1 then n := 1;
    x := 0;
    For a := 1 to n Do
    For b := 1 to n Do
    For c := 1 to n Do
    For d := 1 to n Do
    For e := 1 to n Do
    For f := 1 to n Do
    Inc(x);
    WriteLn( IntToStr(x) );
end.
Random Number Generator
program random;
uses SysUtils;

const
    IM = 139968;
    IA =   3877;
    IC =  29573;

var 
    LAST, NUM, i : longint;
    result : real;

function gen_random(n : integer) : real;
begin    
    LAST := (LAST * IA + IC) mod IM;
    gen_random := n * LAST / IM;
end;

begin
    if ParamCount = 0 then
        NUM := 1
    else
        NUM := StrToInt(ParamStr(1));
    if NUM < 1 then NUM := 1;
    LAST := 42;
    for i:= 1 to NUM do
    begin
        result := gen_random(100);
    end;
    WriteLn( result:10:9 );
end.
Reverse a File
Program reversefile;
uses SysUtils, Classes;

var
    i, N : longint;
    list : TList;
    line : string;
    pline : pointer;    
begin
    list := TList.Create;
    While Not Eof(input) do
    begin
        Readln(input, line);
        Getmem(pline, Length(line)+1);
        Move(line, pline^, Length(line)+1);
        list.Add( pline );
    end;
    N := list.Count;
    For i := N-1 Downto 0 do WriteLn( string(list.items[i]^) );
end.
Sieve of Erathostenes
program sieve;
uses SysUtils;

var 
    NUM, i, k, count : integer;
    flags : array[0..8192] of integer;

begin
    if ParamCount = 0 then
        NUM := 1
    else
        NUM := StrToInt(ParamStr(1));
        
    if NUM < 1 then NUM := 1;

    while NUM > 0 do
    begin
        Dec(NUM);
        count := 0;
        for i := 0 to 8192 do
        begin
            flags[i] := i;
        end;
        for i := 2 to 8192 do
        begin
            if flags[i] <> -1 then
            begin
                k := i+i;
                while k <= 8192 do
                begin
                    flags[k] := -1;
                    Inc(k, i);
                end;
                Inc(count);
            end;
        end;
    end;
    WriteLn('Count: ' + IntToStr(Count));
end.
Statistical Moments
Program moments;
uses SysUtils, Classes;

function Power(Base : Real ; Exponent: Integer): Real;
var i : integer;
var pow : real;
begin
    pow := Base;
    For i:= 2 To Exponent do pow := pow * Base;
    Power := pow;
end;

function Compare(A, B : Pointer) : longint;
begin
    if A > B then
        Compare := 1
    else if A < B Then
        Compare := -1
    else
        Compare := 0;
end;


var
    i, N, sum, num, middle : longint;
    list : TList;
    median, mean, deviation, 
    average_deviation, standard_deviation, 
    variance, skew, kurtosis : real;
begin
    list := TList.Create;
    While Not Eof(input) do
    begin
        Readln(input, num);
        list.Add( Pointer(num) );
    end;    
    N := list.Count;
    For i := 0 To N-1 do Inc(sum, longint(list.Items[i]));
    mean := sum / N;
    average_deviation := 0;
    standard_deviation := 0;
    variance := 0;
    skew := 0;
    kurtosis := 0;

    For i := 0 To N-1 do
    begin
        deviation := longint(list.Items[i]) - mean;
        average_deviation := average_deviation + Abs(deviation);
        variance := variance + Power(deviation, 2);
        skew := skew + Power(deviation, 3);
        kurtosis := kurtosis + Power(deviation, 4);
        
    end;
    average_deviation := average_deviation / N;
    variance := variance / (N-1);
    standard_deviation := Sqrt(variance);
    

    If variance <> 0 Then
    begin
        skew := skew / (N * variance * standard_deviation);
        kurtosis := kurtosis / (N * variance * variance ) - 3.0;
    end;

    list.Sort(@Compare);
    

    middle := N Div 2;

    If (N Mod 2) <> 0 Then
        median := longint(list.Items[middle])
    Else
        median := (longint(list.Items[middle]) + longint(list.Items[middle-1])) / 2;


    WriteLn('n:                  ', N);
    WriteLn('median:             ', median:6:6);
    WriteLn('mean:               ', mean:6:6);
    WriteLn('average_deviation:  ', average_deviation:6:6);
    WriteLn('standard_deviation: ', standard_deviation:6:6);
    WriteLn('variance:           ', variance:6:6);
    WriteLn('skew:               ', skew:6:6);
    WriteLn('kurtosis:           ', kurtosis:6:6);
end.
String Concatenation
program strcat;

uses SysUtils;
var 
    NUM, i : longint;
    str : string;

begin
    if ParamCount = 0 then NUM := 1
    else NUM := StrToInt(ParamStr(1));
    if NUM < 1 then NUM := 1;

    str := '';
    For i := 1 To NUM Do
        str := str + 'hello'#13;
    WriteLn( Longint(Length(str)) );
    WriteLn( str );    
end.
Sum a Column of Integers
program sumcol;

var
    num, tot: longint;
begin
    While Not Eof(input) Do
    begin
        ReadLn(input, num);    
        tot := tot + num;
    end;
    WriteLn(tot);
end.