mirror
/
RosettaCodeData
mirror of https://github.com/acmeism/RosettaCodeData.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity
RosettaCodeData/Task/Higher-order-functions/Pascal/higher-order-functions-3.pas

721 lines
16 KiB
ObjectPascal
Raw Permalink Blame History

UNIT MRF;
{$mode Delphi} {$H+} {$J-} {$R+} (*) https://www.freepascal.org/docs-html/prog/progch1.html (*)
(*)
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 *
Can run independently from DELPHI / Lazarus
For debian Linux: apt -y install fpc
It contains a text IDE called fp
https://www.freepascal.org/advantage.var
(*)
INTERFACE
USES
Math,
SysUtils,
variants;
{$WARN 6058 off : Call to subroutine "$1" marked as inline is not inlined} // Use for variants
TYPE
Varyray = array of variant ;
FunA = FUNCTION ( x : variant ) : variant ;
FunB = PROCEDURE ( x : variant ) ;
FunC = FUNCTION ( x,y : variant ) : variant ;
FunD = FUNCTION ( x,y : longint ) : longint ;
FunE = FUNCTION ( x,y : variant ) : variant ;
PROCEDURE Show ( x : variant ) ;
FUNCTION Reverse ( x : Varyray ) : Varyray ;
FUNCTION Head ( x : Varyray ) : variant ;
FUNCTION Last ( x : Varyray ) : variant ;
FUNCTION Tail ( x : Varyray ) : Varyray ;
FUNCTION Take ( y : variant ; x : Varyray ) : Varyray ;
FUNCTION Map ( f : FunA ; x: Varyray ) : Varyray ; overload ;
PROCEDURE Map ( f : FunB ; x: Varyray ) ; overload ;
FUNCTION Map ( f : FunC ; x, y: Varyray ) : Varyray ; overload ;
FUNCTION Map ( f : FunD ; x, y: Varyray ) : Varyray ; overload ;
FUNCTION Filter ( f : FunA ; x: Varyray ) : Varyray ; overload ;
FUNCTION Filter ( f : FunE ; y: variant; x: Varyray ) : Varyray ; overload ;
FUNCTION FoldL ( f : FunC ; x: Varyray ) : variant ; overload ;
FUNCTION FoldL ( f : FunD ; x: Varyray ) : variant ; overload ;
FUNCTION FoldL ( f : FunE ; y: variant; x: Varyray ) : variant ; overload ;
FUNCTION Reduce ( f : FunC ; x: Varyray ) : variant ; overload ;
FUNCTION Reduce ( f : FunD ; x: Varyray ) : variant ; overload ;
FUNCTION Reduce ( f : FunE ; y: variant; x: Varyray ) : variant ; overload ;
FUNCTION FoldR ( f : FunC ; x: Varyray ) : variant ; overload ;
FUNCTION FoldR ( f : FunD ; x: Varyray ) : variant ; overload ;
(*) FOR TESTING (*)
FUNCTION RandFillInt ( x: variant ) : variant ;
FUNCTION RandFillReal ( x: variant ) : variant ;
FUNCTION AND_xy ( x, y: variant ) : variant ;
FUNCTION OR_xy ( x, y: variant ) : variant ;
FUNCTION AVG ( x: Varyray ) : variant ;
FUNCTION All ( f: FunA ; x: Varyray ) : variant ;
FUNCTION Any ( f: FunA ; x: Varyray ) : variant ;
FUNCTION Add ( x, y: variant ) : variant ;
FUNCTION Mult ( x, y: variant ) : variant ;
FUNCTION contain ( x, y: variant ) : variant ;
FUNCTION delete ( x, y: variant ) : variant ;
FUNCTION Add1 ( x: variant ) : variant ;
FUNCTION sine ( x: variant ) : variant ;
FUNCTION cosine ( x: variant ) : variant ;
FUNCTION cotangens ( x: variant ) : variant ;
FUNCTION Is_Even ( x: variant ) : variant ;
FUNCTION Is_Odd ( x: variant ) : variant ;
IMPLEMENTATION
PROCEDURE Show ( x: variant ) ;
BEGIN write( x, ' ' ) ; END ;
FUNCTION Reverse ( x : Varyray ) : Varyray ;
VAR
__ : varyray ;
k : integer ;
BEGIN
IF length ( x ) < Low ( x ) + 2 THEN Exit ;
Setlength ( __, length ( x ) );
FOR k := Low ( x ) to High ( x ) DO
__ [ k ] := x [ High ( x ) - k ] ;
result := __ ;
Setlength ( __, 0 );
END;
FUNCTION Head ( x : Varyray ) : variant ;
BEGIN result := x [ Low ( x ) ] ; END;
FUNCTION Last ( x : Varyray ) : variant ;
BEGIN result := x [ High ( x ) ] ; END;
FUNCTION Tail ( x : Varyray ) : Varyray ;
VAR
__ : varyray ;
k : integer ;
BEGIN
Setlength ( __, High ( x ) );
FOR k := Low ( x ) + 1 to High ( x ) DO
__ [ k - 1 ] := x [ k ] ;
result := __ ;
Setlength ( __, 0 );
END;
FUNCTION Take ( y : variant ; x : Varyray ) : Varyray ;
VAR
__ : varyray ;
k : integer ;
BEGIN
Setlength ( __, y );
FOR k := Low ( x ) to y - 1 DO
__ [ k ] := x [ k ] ;
result := __ ;
Setlength ( __, 0 );
END;
FUNCTION Map ( f: FunA ; x: Varyray ) : Varyray ; overload ;
VAR
Ar : array of variant ;
k : integer ;
BEGIN
SetLength ( Ar, length ( x ) ) ;
result := Ar ;
FOR k := Low ( Ar ) TO High ( Ar ) DO
Ar [ k ] := f ( x [ k ] ) ;
result := Ar ;
Setlength ( Ar, 0 );
END;
PROCEDURE Map ( f: FunB ; x: Varyray ) ; overload ;
VAR
k : integer ;
BEGIN
FOR k := Low ( x ) TO High ( x ) DO f ( x [ k ] ) ;
END;
FUNCTION Map ( f: FunC ; x, y: Varyray ) : Varyray ; overload ;
VAR
Ar : array of variant ;
k : integer ;
BEGIN
SetLength ( Ar, min ( length ( x ) , length ( y ) ) ) ;
FOR k := Low ( Ar ) TO High ( Ar ) DO
Ar [ k ] := f ( x [ k ] , y [ k ] ) ;
result := Ar ;
Setlength ( Ar, 0 );
END;
FUNCTION Map ( f: FunD ; x, y: Varyray ) : Varyray ; overload ;
VAR
Ar : array of variant ;
k : integer ;
BEGIN
SetLength ( Ar, min ( length ( x ) , length ( y ) ) ) ;
FOR k := Low ( Ar ) TO High ( Ar ) DO
Ar [ k ] := f ( x [ k ] , y [ k ] ) ;
result := Ar ;
Setlength ( Ar, 0 );
END;
FUNCTION Map ( f: FunE ; x: variant; y: Varyray ) : Varyray ; overload ;
VAR
Ar : array of variant ;
k : integer ;
BEGIN
SetLength ( Ar, min ( length ( x ) , length ( y ) ) ) ;
FOR k := Low ( Ar ) TO High ( Ar ) DO
Ar [ k ] := f ( x , y [ k ] ) ;
result := Ar ;
Setlength ( Ar, 0 );
END;
FUNCTION Filter ( f: FunA ; x: Varyray ) : Varyray ; overload ;
VAR
Ar : array of variant ;
__ : variant ;
k : integer ;
len : integer ;
BEGIN
SetLength ( Ar, 0 ) ;
result := Ar ;
FOR k := Low ( x ) TO High ( x ) DO
BEGIN
__ := f ( x [ k ] ) ;
IF __ <> False THEN
BEGIN
len := Length ( Ar ) ;
SetLength ( Ar, len + 1 ) ;
Ar [ len ] := __ ;
END ;
END ;
result := Ar ;
Setlength ( Ar, 0 );
END;
FUNCTION Filter ( f: FunE ; y: variant; x: Varyray ) : Varyray ; overload ;
VAR
Ar : array of variant ;
__ : variant ;
k : integer ;
len : integer ;
BEGIN
SetLength ( Ar, 0 ) ;
result := Ar ;
FOR k := Low ( x ) TO High ( x ) DO
BEGIN
__ := f ( y, x [ k ] ) ;
IF __ <> False THEN
BEGIN
len := Length ( Ar ) ;
SetLength ( Ar, len + 1 ) ;
Ar [ len ] := __ ;
END ;
END ;
result := Ar ;
Setlength ( Ar, 0 );
END;
FUNCTION FoldL ( f: FunC ; x: Varyray ) : variant ; overload ;
VAR
k : integer ;
BEGIN
result := x [ Low ( x ) ] ;
FOR k := Low ( x ) + 1 TO High ( x ) DO
result := f ( result , x [ k ] ) ;
END ;
FUNCTION FoldL ( f: FunD ; x: Varyray ) : variant ; overload ;
VAR
k : integer ;
BEGIN
result := x [ Low ( x ) ] ;
FOR k := Low ( x ) + 1 TO High ( x ) DO
result := f ( result , x [ k ] ) ;
END ;
FUNCTION FoldL ( f: FunE ; y: variant; x: Varyray ) : variant ; overload ;
VAR
k : integer ;
BEGIN
FOR k := Low ( x ) TO High ( x ) DO
result := f ( y , x [ k ] ) ;
END ;
FUNCTION Reduce ( f: FunC ; x: Varyray ) : variant ; overload ;
BEGIN result := FoldL ( f , x ) ; END ;
FUNCTION Reduce ( f: FunD ; x: Varyray ) : variant ; overload ;
BEGIN result := FoldL ( f , x ) ; END ;
FUNCTION Reduce ( f: FunE ; y: variant; x: Varyray ) : variant ; overload ;
BEGIN result := FoldL ( f , y, x ) ; END ;
FUNCTION FoldR ( f: FunC ; x: Varyray ) : variant ; overload ;
VAR
k : integer ;
BEGIN
result := x [ High ( x ) ] ;
FOR k := High ( x ) - 1 DOWNTO Low ( x ) DO
result := f ( result, x [ k ] ) ;
END ;
FUNCTION FoldR ( f: FunD ; x: Varyray ) : variant ; overload ;
VAR
k : integer ;
BEGIN
result := x [ High ( x ) ];
FOR k := High ( x ) - 1 DOWNTO Low ( x ) DO
result := f ( result, x [ k ] ) ;
END ;
(*) TEST Functions (*)
(*)
Special thanks to PascalDragon , winni & BobDog ( FreePascal.org ),
who explained the specifics of the compiler.
(*)
FUNCTION Add ( x, y: variant ) : variant ;
BEGIN result := x + y ; END ;
FUNCTION Add1 ( x: variant ) : variant ;
BEGIN result := x + 1 ; END ;
FUNCTION AND_xy ( x, y: variant ) : variant ;
BEGIN result := ( x and y ) = True ; END ;
FUNCTION AVG ( x: Varyray ) : variant ;
VAR
k : integer ;
BEGIN
result := 0.0 ;
FOR k := Low ( x ) TO High ( x ) DO
result := result + ( x [ k ] - result ) / ( k + 1 );
END ;
FUNCTION Cosine ( x: variant ) : variant ;
BEGIN result := cos ( x ); END ;
FUNCTION Cotangens ( x: variant ) : variant ;
BEGIN
IF ( x = 0 ) Then Exit ( 'Inf');
result := cot ( x );
END ;
FUNCTION Is_Even ( x: variant ) : variant ;
BEGIN
IF ( ( x mod 2 ) = 0 ) THEN
result := x
ELSE
result := False
END;
FUNCTION Mult( x, y: variant ) : variant ;
BEGIN result := x * y ; END ;
FUNCTION Contain ( x, y: variant ) : variant ;
BEGIN result := x = y ; END ;
FUNCTION Delete ( x, y: variant ) : variant ;
BEGIN
IF ( x = y ) THEN Exit ( False ) ;
result := y;
END ;
FUNCTION Is_Odd ( x: variant ) : variant ;
BEGIN
IF ( ( x mod 2 ) <> 0 ) THEN
result := x
ELSE
result := False
END;
FUNCTION OR_xy ( x, y: variant ) : variant ;
BEGIN result := ( x or y ) = True; END ;
FUNCTION RandFillInt ( x: variant ) : variant ;
BEGIN result := Random ( 100 ) ; END ;
FUNCTION RandFillReal ( x: variant ) : variant ;
VAR
tmp : real = 100.0 ;
BEGIN result := ( Random ( ) ) * tmp ; END ;
FUNCTION sine ( x: variant ) : variant ;
BEGIN result := sin ( x ); END ;
FUNCTION All ( f: FunA ; x: Varyray ) : variant ;
VAR
k : integer ;
BEGIN
result := True ;
FOR k := Low ( x ) TO High ( x ) DO
result := AND_xy ( result , f ( x [ k ] ) ) ;
END ;
FUNCTION Any ( f: FunA ; x: Varyray ) : variant ;
VAR
k : integer ;
BEGIN
result := False ;
FOR k := Low ( x ) TO High ( x ) DO
result := OR_xy ( result , f ( x [ k ] ) ) ;
END ;
END.
(*) === How to use in a program === (*)
program testMRF.pas;
{$mode Delphi} {$H+} {$J-} {$R+} (*) https://www.freepascal.org/docs-html/prog/progch1.html (*)
USES
MRF,
Math,
SysUtils,
Variants;
{$WARN 6058 off : Call to subroutine "$1" marked as inline is not inlined} // Use for variants
VAR
a,b,c : array of variant ;
Acc : variant ;
BEGIN
Randomize ;
setlength ( a, 6 ) ;
setlength ( b, 4 ) ;
setlength ( c, 6 ) ;
a := Map ( RandFillInt , a ) ;
Map ( show , a ) ;
writeln ;
b := Map ( RandFillInt , b ) ;
Map ( show , b ) ;
writeln ;
c := Map ( RandFillInt , c ) ;
Map ( show , c ) ;
writeln ;
Acc := FoldL ( add , a ) ;
WriteLn ( 'Sum = ' , Acc ) ;
writeln ;
Acc := Reduce ( contain , 31, a ) ;
WriteLn ( 'contains = ' , Acc ) ;
writeln ;
c := Filter ( delete , 31, a ) ;
WriteLn ( 'del c :' ) ;
Map ( show , c ) ;
writeln ;
a := Reverse ( c ) ;
WriteLn ( 'reverse c :' ) ;
Map ( show , a ) ;
writeln ;
Acc := avg ( b ) ;
WriteLn ( 'avg = ' , Acc ) ;
writeln ;
c := Map ( cotangens , b ) ;
writeln ( 'cot : ' ) ;
Map ( show , c ) ;
writeln ;
Acc := FoldR ( min , b ) ;
WriteLn ( 'min = ' , Acc );
writeln ;
Acc := FoldR ( max , b ) ;
WriteLn ( 'max = ' , Acc );
writeln ;
Map ( show , b ) ;
Acc := All ( Is_Odd , b ) ;
writeln ;
WriteLn ( 'All Is_Odd = ' , Acc ) ;
writeln ;
Map ( show , b ) ;
Acc := Any ( Is_Even , b ) ;
writeln ;
WriteLn ( 'Any Is_Even = ' , Acc ) ;
writeln ;
Acc := Head ( b ) ;
WriteLn ( 'Head = ' , Acc ) ;
Acc := Last ( b ) ;
WriteLn ( 'Last = ' , Acc ) ;
Map ( show , b ) ;
a := Tail ( b ) ;
writeln ;
WriteLn ( 'Tail of b :' ) ;
Map ( show , a ) ;
writeln ;
Map ( show , b ) ;
a := Take ( 2, b ) ;
writeln ;
WriteLn ( 'Take 2 from b :' ) ;
Map ( show , a ) ;
writeln ;
setlength ( c, 0 ) ;
setlength ( b, 0 ) ;
setlength ( a, 0 ) ;
END.
Reference in New Issue View Git Blame Copy Permalink