let n = 61
let l = [0, 1]

func fusc(n) {
    return l[n] when n < l.Length()
    let f = (n &&& 1) == 0 ? l[n >>> 1] : l[(n - 1) >>> 1] + l[(n + 1) >>> 1]
    l.Add(f)
    return f
}

var lst = true
var w = -1
var c = 0
var t = nil
var res = ""

print("First \(n) numbers in the fusc sequence:")
for i in 0..Integer.Max {
    let f = fusc(i)
    if lst {
        if i < 61 {
            print("\(f) ", terminator: "")
        } else {
            lst = false
            print("")
            print("Points in the sequence where an item has more digits than any previous items:")
            print("Index/Value:")
            print(res)
            res = ""
        }
    }
    t = f.ToString().Length()
    if t > w {
        w = t
        res += (res == "" ? "" : "\n") + "\(i)/\(f)"
        if !lst {
            print(res)
            res = ""
        }
        c += 1
        if c > 5 {
            break
        }
    }
}
l.Clear()


// Generate the fusc sequence. Nigel Galloway: March 20th., 2019
let fG n=seq{for (n,g) in Seq.append n [1] |> Seq.pairwise do yield n; yield n+g}
let fusc=seq{yield 0; yield! Seq.unfold(fun n->Some(n,fG n))(seq[1])|>Seq.concat}|> Seq.mapi(fun n g->(n,g))


USING: arrays assocs formatting io kernel make math math.parser
math.ranges namespaces prettyprint sequences
tools.memory.private ;
IN: rosetta-code.fusc

<PRIVATE

: (fusc) ( n -- seq )
    [ 2 ] dip [a,b) [
        0 , 1 , [
            [ building get ] dip dup even?
            [ 2/ swap nth ]
            [ [ 1 - 2/ ] [ 1 + 2/ ] 2bi [ swap nth ] [email protected] + ]
            if ,
        ] each
    ] { } make ;

: increases ( seq -- assoc )
    [ 0 ] dip [
        [
            2array 2dup first number>string length <
            [ [ 1 + ] [ , ] bi* ] [ drop ] if
        ] each-index
    ] { } make nip ;

PRIVATE>

: fusc ( n -- seq )
    dup 3 < [ { 0 1 } swap head ] [ (fusc) ] if ;

: fusc-demo ( -- )
    "First 61 fusc numbers:" print 61 fusc [ pprint bl ] each
    nl nl
    "Fusc numbers with more digits than all previous ones:"
    print "Value   Index\n======  =======" print
    1,000,000 fusc increases
   [ [ commas ] [email protected] "%-6s  %-7s\n" printf ] assoc-each ;

MAIN: fusc-demo


\ Gforth 0.7.9_20211014

: fusc ( n -- n)                     \  input n -- output fusc(n)
  dup  dup  0= swap  1 = or          \  n = 0 or 1
  if  exit                           \  return n
  else dup 2 mod 0=                  \  test even
       if 2/ recurse                 \  even fusc(n)= fusc(n/2)
       else dup  1- 2/ recurse       \  odd  fusc(n) = fusc((n-1)/2) +
            swap 1+ 2/ recurse  +    \                 fusc((n+1)/2)
       then
  then
;

: cntDigits ( n -- n )               \ returns the numbers of digits
  0 begin 1+ swap
        10 /
        swap  over
  0= until
  swap drop
;

: fuscLen ( n -- )                    \ count until end index
  cr 1   swap  0
  do
    i fusc cntDigits
    over > if 1+
                  ." fusc( " i . ." ) : "
                  i fusc  . cr
           then
  loop
;

: firstFusc ( n -- )                  \ show  fusc(i)   until  limit
   dup ." First " . ." fusc(n) : " cr
   0 do  I fusc .  loop cr
;

61 firstFusc

20 1000 1000 * * fuscLen

bye


' version 01-03-2019
' compile with: fbc -s console

#Define max 20000000

Dim Shared As UInteger f(max)

Sub fusc

    f(0) = 0
    f(1) = 1

    For n As UInteger = 2 To max
        If n And 1 Then
            f(n) = f((n -1) \ 2) + f((n +1) \ 2)
        Else
            f(n) = f(n \ 2)
        End If
    Next

End Sub

' ------=< MAIN >=------

Dim As UInteger i, d
Dim As String fs

fusc

For i = 0 To 60
    Print f(i); " ";
Next

Print : Print
Print "       Index       Value"
For i = 0 To max
    If f(i) >= d Then
        Print Using "###########," ; i; f(i)
        If d = 0 Then d = 1
        d *= 10
    End If
Next

' empty keyboard buffer
While Inkey <> "" : Wend
Print : Print "hit any key to end program"
Sleep
End


package main

import (
    "fmt"
    "strconv"
)

func fusc(n int) []int {
    if n <= 0 {
        return []int{}
    }
    if n == 1 {
        return []int{0}
    }
    res := make([]int, n)
    res[0] = 0
    res[1] = 1
    for i := 2; i < n; i++ {
        if i%2 == 0 {
            res[i] = res[i/2]
        } else {
            res[i] = res[(i-1)/2] + res[(i+1)/2]
        }
    }
    return res
}

func fuscMaxLen(n int) [][2]int {
    maxLen := -1
    maxFusc := -1
    f := fusc(n)
    var res [][2]int
    for i := 0; i < n; i++ {
        if f[i] <= maxFusc {
            continue // avoid expensive strconv operation where possible
        }
        maxFusc = f[i]
        le := len(strconv.Itoa(f[i]))
        if le > maxLen {
            res = append(res, [2]int{i, f[i]})
            maxLen = le
        }
    }
    return res
}

func commatize(n int) string {
    s := fmt.Sprintf("%d", n)
    if n < 0 {
        s = s[1:]
    }
    le := len(s)
    for i := le - 3; i >= 1; i -= 3 {
        s = s[0:i] + "," + s[i:]
    }
    if n >= 0 {
        return s
    }
    return "-" + s
}

func main() {
    fmt.Println("The first 61 fusc numbers are:")
    fmt.Println(fusc(61))
    fmt.Println("\nThe fusc numbers whose length > any previous fusc number length are:")
    res := fuscMaxLen(20000000)  // examine first twenty million numbers say
    for i := 0; i < len(res); i++ {
        fmt.Printf("%7s (index %10s)\n", commatize(res[i][1]), commatize(res[i][0]))
    }
}


class FuscSequence {
    static void main(String[] args) {
        println("Show the first 61 fusc numbers (starting at zero) in a horizontal format")
        for (int n = 0; n < 61; n++) {
            printf("%,d ", fusc[n])
        }

        println()
        println()
        println("Show the fusc number (and its index) whose length is greater than any previous fusc number length.")
        int start = 0
        for (int i = 0; i <= 5; i++) {
            int val = i != 0 ? (int) Math.pow(10, i) : -1
            for (int j = start; j < FUSC_MAX; j++) {
                if (fusc[j] > val) {
                    printf("fusc[%,d] = %,d%n", j, fusc[j])
                    start = j
                    break
                }
            }
        }
    }

    private static final int FUSC_MAX = 30000000
    private static int[] fusc = new int[FUSC_MAX]

    static {
        fusc[0] = 0
        fusc[1] = 1
        for (int n = 2; n < FUSC_MAX; n++) {
            int n2 = (int) (n / 2)
            int n2m = (int) ((n - 1) / 2)
            int n2p = (int) ((n + 1) / 2)
            fusc[n] = n % 2 == 0
                ? fusc[n2]
                : fusc[n2m] + fusc[n2p]
        }
    }
}


---------------------- FUSC SEQUENCE ---------------------

fusc :: Int -> Int
fusc i
  | 1 > i = 0
  | otherwise = fst $ go (pred i)
  where
    go n
      | 0 == n = (1, 0)
      | even n = (x + y, y)
      | otherwise = (x, x + y)
      where
        (x, y) = go (div n 2)

--------------------------- TEST -------------------------
main :: IO ()
main = do
  putStrLn "First 61 terms:"
  print $ fusc <$> [0 .. 60]
  putStrLn "\n(Index, Value):"
  mapM_ print $ take 5 widths

widths :: [(Int, Int)]
widths =
  fmap
    (\(_, i, x) -> (i, x))
    (iterate nxtWidth (2, 0, 0))

nxtWidth :: (Int, Int, Int) -> (Int, Int, Int)
nxtWidth (w, i, v) = (succ w, j, x)
  where
    fi = (,) <*> fusc
    (j, x) =
      until
        ((w <=) . length . show . snd)
        (fi . succ . fst)
        (fi i)


fusc_term =: ({~ -:@#)`([: +/ ({~ ([: -: _1 1 + #)))@.(2 | #)
fusc =: (, fusc_term)@:]^:[ 0 1"_

   NB. show the first 61 fusc numbers (starting at zero) in a horizontal format.
   61 {. fusc 70
0 1 1 2 1 3 2 3 1 4 3 5 2 5 3 4 1 5 4 7 3 8 5 7 2 7 5 8 3 7 4 5 1 6 5 9 4 11 7 10 3 11 8 13 5 12 7 9 2 9 7 12 5 13 8 11 3 10 7 11 4

   9!:17]2 2 NB. specify bottom right position in box

   FUSC =: fusc 99999
   DIGITS =: ; ([: # 10&#.inv)&.> FUSC

   (;: 'index value') ,. <"0(,: {&A) DIGITS i. 1 2 3 4
┌─────┬─┬──┬────┬─────┐
│index│0│37│1173│35499│
├─────┼─┼──┼────┼─────┤
│value│0│11│ 108│ 1076│
└─────┴─┴──┴────┴─────┘


public class FuscSequence {

    public static void main(String[] args) {
        System.out.println("Show the first 61 fusc numbers (starting at zero) in a horizontal format");
        for ( int n = 0 ; n < 61 ; n++ ) {
            System.out.printf("%,d ", fusc[n]);
        }

        System.out.printf("%n%nShow the fusc number (and its index) whose length is greater than any previous fusc number length.%n");
        int start = 0;
        for (int i = 0 ; i <= 5 ; i++ ) {
            int val = i != 0 ? (int) Math.pow(10, i) : -1;
            for ( int j = start ; j < FUSC_MAX ; j++ ) {
                if ( fusc[j] > val ) {
                    System.out.printf("fusc[%,d] = %,d%n", j, fusc[j] );
                    start = j;
                    break;
                }
            }
        }
    }

    private static final int FUSC_MAX = 30000000;
    private static int[] fusc = new int[FUSC_MAX];

    static {
        fusc[0] = 0;
        fusc[1] = 1;
        for ( int n = 2 ; n < FUSC_MAX ; n++ ) {
            fusc[n] = (n % 2 == 0 ? fusc[n/2] : fusc[(n-1)/2] + fusc[(n+1)/2]);
        }
    }
}


# input should be a non-negative integer
def commatize:
  # "," is 44
  def digits: tostring | explode | reverse;
  [foreach digits[] as $d (-1; .+1;
     (select(. > 0 and . % 3 == 0)|44), $d)]
  | reverse | implode  ;

def lpad($len): tostring | ($len - length) as $l | (" " * $l)[:$l] + .;


using Memoize, Formatting

@memoize function sternbrocot(n)
    if n < 2
        return n
    elseif iseven(n)
        return sternbrocot(div(n, 2))
    else
        m = div(n - 1, 2)
        return sternbrocot(m) + sternbrocot(m + 1)
    end
end

function fusclengths(N=100000000)
    println("sequence number : fusc value")
    maxlen = 0
    for i in 0:N
        x = sternbrocot(i)
        if (len = length(string(x))) > maxlen
            println(lpad(format(i, commas=true), 15), " : ", format(x, commas=true))
            maxlen = len
        end
    end
end

println("The first 61 fusc numbers are: ", [sternbrocot(x) for x in 0:60])
fusclengths()


// Version 1.3.21

fun fusc(n: Int): IntArray {
    if (n <= 0) return intArrayOf()
    if (n == 1) return intArrayOf(0)
    val res = IntArray(n)
    res[1] = 1
    for (i in 2 until n) {
        if (i % 2 == 0) {
            res[i] = res[i / 2]
        } else {
            res[i] = res[(i - 1) / 2] + res[(i + 1) / 2]
        }
    }
    return res
}

fun fuscMaxLen(n: Int): List<Pair<Int, Int>> {
    var maxLen = -1
    var maxFusc = -1
    val f = fusc(n)
    val res = mutableListOf<Pair<Int, Int>>()
    for (i in 0 until n) {
        if (f[i] <= maxFusc) continue // avoid string conversion
        maxFusc = f[i]
        val len = f[i].toString().length
        if (len > maxLen) {
            res.add(Pair(i, f[i]))
            maxLen = len
        }
    }
    return res
}

fun main() {
    println("The first 61 fusc numbers are:")
    println(fusc(61).asList())
    println("\nThe fusc numbers whose length > any previous fusc number length are:")
    val res = fuscMaxLen(20_000_000)  // examine first 20 million numbers say
    for (r in res) {
        System.out.printf("%,7d (index %,10d)\n", r.second, r.first)
    }
}


function fusc(n)
    n = math.floor(n)
    if n == 0 or n == 1 then
        return n
    elseif n % 2 == 0 then
        return fusc(n / 2)
    else
        return fusc((n - 1) / 2) + fusc((n + 1) / 2)
    end
end

function numLen(n)
    local sum = 1
    while n > 9 do
        n = math.floor(n / 10)
        sum = sum + 1
    end
    return sum
end

function printLargeFuscs(limit)
    print("Printing all largest Fusc numbers up to " .. limit)
    print("Index-------Value")
    local maxLen = 1
    for i=0,limit do
        local f = fusc(i)
        local le = numLen(f)
        if le > maxLen then
            maxLen = le
        print(string.format("%5d%12d", i, f))
        end
    end
end

function main()
    print("Index-------Value")
    for i=0,60 do
        print(string.format("%5d%12d", i, fusc(i)))
    end
    printLargeFuscs(math.pow(2, 31) - 1)
end

main()


ClearAll[Fusc]
Fusc[0] := 0
Fusc[1] := 1
Fusc[n_] := Fusc[n] = If[EvenQ[n], Fusc[n/2], Fusc[(n - 1)/2] + Fusc[(n + 1)/2]]
Fusc /@ Range[0, 60]
res = {{0, 1}};
i = 0;
PrintTemporary[Dynamic[{res, i}]];
While[Length[res] < 6,
  f = Fusc[i];
  If[IntegerLength[res[[-1, -1]]] < IntegerLength[f],
   AppendTo[res, {i, f}]
   ];
  i++;
  ];
res


import strformat

func fusc(n: int): int =
  if n == 0 or n == 1:
    n
  elif n mod 2 == 0:
    fusc(n div 2)
  else:
    fusc((n - 1) div 2) + fusc((n + 1) div 2)

echo "The first 61 Fusc numbers:"
for i in 0..61:
  write(stdout, fmt"{fusc(i)} ")
echo "\n\nThe Fusc numbers whose lengths are greater than those of previous Fusc numbers:"
echo fmt"        n   fusc(n)"
echo    "--------- ---------"
var maxLength = 0
for i in 0..700_000:
  var f = fusc(i)
  var length = len($f)
  if length > maxLength:
    maxLength = length
    echo fmt"{i:9} {f:9}"


program fusc;
uses
  sysutils;
const
{$IFDEF FPC}
  MaxIdx = 1253 * 1000 * 1000; //19573420; // must be even
{$ELSE}
  // Dynamics arrays in Delphi cann't be to large
  MaxIdx = 19573420;
 {$ENDIF}

type
  tFuscElem = LongWord;
  tFusc = array of tFuscElem;
var
  FuscField : tFusc;

function commatize(n:NativeUint):string;
var
  l,i : NativeUint;
begin
  str(n,result);
  l := length(result);
  //no commatize
  if l < 4 then
    exit;
  //new length
  i := l+ (l-1) DIV 3;
  setlength(result,i);
  //copy chars to the right place
  While i <> l do
  Begin
    result[i]:= result[l];result[i-1]:= result[l-1];
    result[i-2]:= result[l-2];result[i-3]:= ',';
    dec(i,4);dec(l,3);
  end;
end;

procedure OutFusc(StartIdx,EndIdx :NativeInt;const FF:tFusc);
Begin
  IF StartIdx < Low(FF) then StartIdx :=Low(FF);
  IF EndIdx > High(FF) then EndIdx := High(FF);
  For StartIdx := StartIdx to EndIdx do
    write(FF[StartIdx],' ');
  writeln;
end;

procedure FuscCalc(var FF:tFusc);
var
  pFFn,pFFi : ^tFuscElem;
  i,n,sum : NativeUint;
Begin
  FF[0]:= 0;
  FF[1]:= 1;
  n := 2;
  i := 1;
  pFFn := @FF[n];
  pFFi := @FF[i];
  sum := pFFi^;
  while n <= MaxIdx-2 do
  begin
    //even
    pFFn^ := sum;//FF[n] := FF[i];
    //odd
    inc(pFFi);//FF[i+1]
    inc(pFFn);//FF[n+1]
    sum := sum+pFFi^;
    pFFn^:= sum; //FF[n+1] := FF[i]+FF[i+1];
    sum := pFFi^;
    inc(pFFn);
    inc(n,2);
    //inc(i);
  end;
end;

procedure OutHeader(base:NativeInt);
begin
  writeln('Fusc numbers with more digits in base ',base,' than all previous ones:');
  writeln('Value':10,'Index':10,'  IndexNum/IndexNumBefore');
  writeln('======':10,' =======':14);
end;

procedure CheckFuscDigits(const FF:tFusc;Base:NativeUint);
var
  pFF : ^tFuscElem;
  Dig,
  i,lastIdx: NativeInt;
Begin
  OutHeader(base);
  Dig := -1;
  i := 0;
  lastIdx := 0;
  pFF := @FF[0];// aka FF[i]
  repeat
    //search in tight loop speeds up
    repeat
      inc(pFF);
      inc(i);
    until pFF^ >Dig;

    if i>= MaxIdx then
      BREAK;
    //output
    write(commatize(pFF^):10,commatize(i):14);//,DIG:10);
    IF lastIdx> 0 then
      write(i/lastIdx:12:7);
    writeln;
    lastIdx := i;
    IF Dig >0 then
      Dig := Dig*Base+Base-1
    else
     Dig := Base-1;
  until false;
  writeln;
end;

BEGIN
  setlength(FuscField,MaxIdx);
  FuscCalc(FuscField);
  writeln('First 61 fusc numbers:');
  OutFusc(0,60,FuscField);

  CheckFuscDigits(FuscField,10);
  CheckFuscDigits(FuscField,11); //11 ~phi^5  1.6180..^5 = 11,09
  setlength(FuscField,0);
  {$IFDEF WIN}readln;{$ENDIF}
END.


use strict;
use warnings;
use feature 'say';

sub comma { reverse ((reverse shift) =~ s/(.{3})/$1,/gr) =~ s/^,//r }

sub stern_diatomic {
  my ($p,$q,$i) = (0,1,shift);
  while ($i) {
    if ($i & 1) { $p += $q; } else { $q += $p; }
    $i >>= 1;
  }
  $p;
}

say "First 61 terms of the Fusc sequence:\n" . join ' ', map { stern_diatomic($_) } 0..60;
say "\nIndex and value for first term longer than any previous:";

my $i =  0;
my $l = -1;
while ($l < 5) {
    my $v = stern_diatomic($i);
    printf("%15s : %s\n", comma($i), comma($v)) and $l = length $v if length $v > $l;
    $i++;
}


constant limit = 20_000_000
sequence fuscs = repeat(0,limit); -- NB 1-based indexing; fusc(0)===fuscs[1]
fuscs[2] = 1                                        -- ie fusc(1):=1
for n=3 to limit do
  fuscs[n] = iff(remainder(n-1,2)?fuscs[n/2]+fuscs[n/2+1]:fuscs[(n+1)/2])
end for
--printf(1,"First 61 terms of the Fusc sequence:\n%v\n",{fuscs[1..61]})
string s = ""
for n=1 to 61 do s&=sprintf("%,d ",fuscs[n]) end for
printf(1,"First 61 terms of the Fusc sequence:\n%s\n\n",{s})
printf(1,"Elements with more digits than any previous items:\n")
printf(1,"          Index : Value\n")
integer d = 0
for n=1 to length(fuscs) do
  if fuscs[n]>=d then
    printf(1,"%,15d : %,d\n",{n-1,fuscs[n]})
    d = iff(d=0?10:d*10)
  end if
end for


main =>
  println("First 61 fusc numbers:"),
  println([fusc(I) : I in 0..60]),
  nl,
  println("Points in the sequence whose length is greater than any previous fusc number length:\n"),
  println("   Index     fusc  Len"),
  largest_fusc_string(20_000_000).

table
fusc(0) = 0.
fusc(1) = 1.
fusc(N) = fusc(N//2), even(N) => true.
fusc(N) = fusc((N-1)//2) + fusc((N+1)//2) => true.

largest_fusc_string(Limit) =>
  largest_fusc_string(0,Limit,0).

largest_fusc_string(Limit,Limit,_).
largest_fusc_string(N,Limit,LargestLen) :-
  N <= Limit,
  F = fusc(N),
  Len = F.to_string.len,
  (Len > LargestLen ->
     printf("%8d %8d %4d\n",N,F,Len),
     LargestLen1 = Len
   ;
     LargestLen1 = LargestLen
  ),
  largest_fusc_string(N+1,Limit,LargestLen1).


void setup() {
  println("First 61 terms:");
  for (int i = 0; i < 60; i++) {
    print(fusc(i) + " ");
  }
  println(fusc(60));
  println();
  println("Sequence elements where number of digits of the value increase:");
  int max_len = 0;
  for (int i = 0; i < 700000; i++) {
    int temp = fusc(i);
    if (str(temp).length() > max_len) {
      max_len = str(temp).length();
      println("(" + i + ", " + temp + ")");
    }
  }
}

int fusc(int n) {
  if (n <= 1) {
    return n;
  } else if (n % 2 == 0) {
    return fusc(n / 2);
  } else {
    return fusc((n - 1) / 2) + fusc((n + 1) / 2);
  }
}


:- dynamic fusc_cache/2.

fusc(0, 0):-!.
fusc(1, 1):-!.
fusc(N, F):-
    fusc_cache(N, F),
    !.
fusc(N, F):-
    0 is N mod 2,
    !,
    M is N//2,
    fusc(M, F),
    assertz(fusc_cache(N, F)).
fusc(N, F):-
    N1 is (N - 1)//2,
    N2 is (N + 1)//2,
    fusc(N1, F1),
    fusc(N2, F2),
    F is F1 + F2,
    assertz(fusc_cache(N, F)).

print_fusc_sequence(N):-
    writef('First %w fusc numbers:\n', [N]),
    print_fusc_sequence(N, 0),
    nl.

print_fusc_sequence(N, M):-
    M >= N,
    !.
print_fusc_sequence(N, M):-
    fusc(M, F),
    writef('%w ', [F]),
    M1 is M + 1,
    print_fusc_sequence(N, M1).

print_max_fusc(N):-
    writef('Fusc numbers up to %w that are longer than any previous one:\n', [N]),
    print_max_fusc(N, 0, 0).

print_max_fusc(N, M, _):-
    M >= N,
    !.
print_max_fusc(N, M, Max):-
    fusc(M, F),
    (F >= Max ->
        writef('n = %w, fusc(n) = %w\n', [M, F]), Max1 = max(10, Max * 10)
        ;
        Max1 = Max
    ),
    M1 is M + 1,
    print_max_fusc(N, M1, Max1).

main:-
    print_fusc_sequence(61),
    print_max_fusc(1000000).


from collections import deque
from itertools import islice, count

def fusc():
    q = deque([1])
    yield 0
    yield 1

    while True:
        x = q.popleft()
        q.append(x)
        yield x

        x += q[0]
        q.append(x)
        yield x

def longest_fusc():
    sofar = 0
    for i, f in zip(count(), fusc()):
        if f >= sofar:
            yield(i, f)
            sofar = 10 * sofar or 10

print('First 61:')
print(list(islice(fusc(), 61)))

print('\nLength records:')
for i, f in islice(longest_fusc(), 6):
    print(f'fusc({i}) = {f}')


  [ 1 & ]                is odd       ( n --> b )

  [ 0 swap
   [ dip 1+
     10 / dup
     0 = until ]
    drop ]               is digits    ( n --> n )

  [ dup dup size
    dup odd iff
      [ dup 1 - 2 /
        dip
          [ 1 + 2 / peek
            over ]
        peek + ]
    else
      [ 2 / peek ]
    join ]               is nextfusc  ( [ --> [ )

  say "First 61 terms." cr
  ' [ 0 1 ]
  59 times nextfusc
  witheach [ echo sp ]
  cr cr
  say "Terms where the digit count increases." cr
  say "fusc(0) = 0" cr
  1 ' [ 0 1 ]
  [ nextfusc
    dup -1 peek digits
    rot 2dup > iff
      [ drop swap
        say "fusc("
        dup -1 peek echo
        say ") = "
        dup size 1 - echo cr ]
    else [ nip swap ]
    dup size 1000000 = until ]
  2drop


firstNFuscNumbers <- function(n)
{
  stopifnot(n > 0)
  if(n == 1) return(0) else fusc <- c(0, 1)
  if(n > 2)
  {
    for(i in seq(from = 3, to = n, by = 1))
    {
      fusc[i] <- if(i %% 2) fusc[(i + 1) / 2] else fusc[i / 2] + fusc[(i + 2) / 2]
    }
  }
  fusc
}
first61 <- firstNFuscNumbers(61)
cat("The first 61 Fusc numbers are:", "\n", first61, "\n")


#lang racket

(require racket/generator)

(define (memoize f)
  (define table (make-hash))
  (λ args (hash-ref! table args (thunk (apply f args)))))

(define fusc
  (memoize
   (λ (n)
     (cond
       [(<= n 1) n]
       [(even? n) (fusc (/ n 2))]
       [else (+ (fusc (/ (sub1 n) 2)) (fusc (/ (add1 n) 2)))]))))

(define (comma x)
  (string-join
   (reverse
    (for/list ([digit (in-list (reverse (string->list (~a x))))] [i (in-naturals)])
      (cond
        [(and (= 0 (modulo i 3)) (> i 0)) (string digit #\,)]
        [else (string digit)])))
   ""))

;; Task 1
(displayln (string-join (for/list ([i (in-range 61)]) (comma (fusc i))) " "))
(newline)

;; Task 2
(define gen
  (in-generator
   (let loop ([prev 0] [i 0])
     (define result (fusc i))
     (define len (string-length (~a result)))
     (cond
       [(> len prev)
        (yield (list i result))
        (loop len (add1 i))]
       [else (loop prev (add1 i))]))))

(for ([i (in-range 5)] [x gen])
  (match-define (list index result) x)
  (printf "~a: ~a\n" (comma index) (comma result)))


my @Fusc = 0, 1, 1, { |(@Fusc[$_ - 1] + @Fusc[$_], @Fusc[$_]) given ++$+1 } ... *;

sub comma { $^i.flip.comb(3).join(',').flip }

put "First 61 terms of the Fusc sequence:\n{@Fusc[^61]}" ~
    "\n\nIndex and value for first term longer than any previous:";

for flat 'Index', 'Value', 0, 0, (1..4).map({
    my $l = 10**$_;
    @Fusc.first(* > $l, :kv).map: &comma
  }) -> $i, $v {
      printf "%15s : %s\n", $i, $v
}


/*REXX program  calculates and displays the   fusc   (or  Stern's Diatomic)   sequence. */
parse arg st # xw .                              /*obtain optional arguments from the CL*/
if st=='' | st==","  then st=  0                 /*Not specified?  Then use the default.*/
if  #=='' |  #==","  then  #= 61                 /* "      "         "   "   "     "    */
if xw=='' | xw==","  then xw=  0                 /* "      "         "   "   "     "    */
list= xw<1                                       /*boolean value:  LIST  to show numbers*/
@.=;        @.0= 0;       @.1= 1                 /*assign array default; assign low vals*/
mL= 0                                            /*the maximum length (digits)  so far. */
$=                                               /* "  list of  fusc  numbers    "  "   */
   do j=0  for #                                 /*process a bunch of integers from zero*/
   if j>1  then if j//2  then do;  _= (j-1) % 2;   p= (j+1) % 2;   @.j= @._ + @.p;   end
                         else do;  _= j % 2;                       @.j= @._;         end
   if list  then if j>=st  then $= $ commas(@.j)                      /*add it to a list*/
                           else nop                                   /*NOP≡placeholder.*/
            else do;   if length(@.j)<=mL  then iterate               /*still too small.*/
                       mL= length(@.j)                                /*found increase. */
                       if mL==1  then say '═══index═══   ═══fusc number═══'
                       say right( commas(j), 9)     right( commas(@.j), 14)
                       if mL==xw  then leave     /*Found max length?  Then stop looking.*/
                 end                             /* [↑]  display fusc #s of maximum len.*/
   end   /*j*/
                                                 /*$   has a superfluous leading blank. */
if $\==''  then say strip($)                     /*display a horizontal list of fusc #s.*/
exit 0                                           /*stick a fork in it,  we're all done. */
/*──────────────────────────────────────────────────────────────────────────────────────*/
commas:  parse arg ?;  do _=length(?)-3  to 1  by -3; ?=insert(',', ?, _); end;   return ?


# Project: Fusc sequence

max = 60
fusc = list(36000)
fusc[1] = 1
see "working..." + nl
see "wait for done..." + nl
see "The first 61 fusc numbers are:" + nl
fuscseq(max)
see "0"
for m = 1 to max
    see " " + fusc[m]
next

see nl
see "The fusc numbers whose length > any previous fusc number length are:" + nl
see "Index Value" + nl
see " 0     0" + nl
d = 10
for i = 1 to 36000
    if fusc[i] >= d
        see " " + i + "   " + fusc[i] + nl
        if d = 0
           d = 1
        ok
        d = d*10
    ok
next
see "done..." + nl

func fuscseq(max)
     for n = 2 to 36000
         if n%2 = 1
            fusc[n] = fusc[(n-1)/2] + fusc[(n+1)/2]
         but n%2 = 0
             fusc[n] = fusc[n/2]
         ok
     next


fusc = Enumerator.new do |y|
  y << 0
  y << 1
  arr = [0,1]
  2.step do |n|
    res = n.even? ? arr[n/2] : arr[(n-1)/2] + arr[(n+1)/2]
    y   << res
    arr << res
  end
end

fusc_max_digits = Enumerator.new do |y|
   cur_max, cur_exp = 0, 0
   0.step do |i|
      f = fusc.next
      if f >= cur_max
        cur_exp += 1
        cur_max = 10**cur_exp
        y << [i, f]
      end
   end
end

puts fusc.take(61).join(" ")
fusc_max_digits.take(6).each{|pair| puts "%15s : %s" % pair }


fn fusc_sequence() -> impl std::iter::Iterator<Item = u32> {
    let mut sequence = vec![0, 1];
    let mut n = 0;
    std::iter::from_fn(move || {
        if n > 1 {
            sequence.push(match n % 2 {
                0 => sequence[n / 2],
                _ => sequence[(n - 1) / 2] + sequence[(n + 1) / 2],
            });
        }
        let result = sequence[n];
        n += 1;
        Some(result)
    })
}

fn main() {
    println!("First 61 fusc numbers:");
    for n in fusc_sequence().take(61) {
        print!("{} ", n)
    }
    println!();

    let limit = 1000000000;
    println!(
        "Fusc numbers up to {} that are longer than any previous one:",
        limit
    );
    let mut max = 0;
    for (index, n) in fusc_sequence().take(limit).enumerate() {
        if n >= max {
            max = std::cmp::max(10, max * 10);
            println!("index = {}, fusc number = {}", index, n);
        }
    }
}


func fusc(n) is cached {

    return 0 if n.is_zero
    return 1 if n.is_one

    n.is_even ? fusc(n/2) : (fusc((n-1)/2) + fusc(((n-1)/2)+1))
}

say ("First 61 terms of the Stern-Brocot sequence: ", 61.of(fusc).join(' '))

say "\nIndex and value for first term longer than any previous:"
printf("%15s : %s\n", "Index", "Value");

var (index=0, len=0)

5.times {
    index = (index..Inf -> first_by { fusc(_).len > len })
    len = fusc(index).len
    printf("%15s : %s\n", index.commify, fusc(index).commify)
}


struct FuscSeq: Sequence, IteratorProtocol {
  private var arr = [0, 1]
  private var i = 0

  mutating func next() -> Int? {
    defer {
      i += 1
    }

    guard i > 1 else {
      return arr[i]
    }

    switch i & 1 {
    case 0:
      arr.append(arr[i / 2])
    case 1:
      arr.append(arr[(i - 1) / 2] + arr[(i + 1) / 2])
    case _:
      fatalError()
    }

    return arr.last!
  }
}

let first = FuscSeq().prefix(61)

print("First 61: \(Array(first))")

var max = -1

for (i, n) in FuscSeq().prefix(20_000_000).enumerated() {
  let f = String(n).count

  if f > max {
    max = f

    print("New max: \(i): \(n)")
  }
}


proc fusc n {
    if {$n < 2} {
        return $n
    }

    if {[info exists ::g_fusc($n)]} { return $::g_fusc($n) }

    if {$n % 2} {               ;# n is odd
        set r [expr {[fusc [expr {($n-1)/2}]] + [fusc [expr {($n+1)/2}]]}]
    } else {                    ;# n is even
        set r [fusc [expr {$n/2}]]
    }

    if {$n < 999999} { set ::g_fusc($n) $r }

    return $r
}

proc ,,, {str {sep ,} {grouplen 3}} {
    set strlen [string length $str]
    set padlen [expr {($grouplen - ($strlen % $grouplen)) % $grouplen}]
    set r [regsub -all ... [string repeat " " $padlen]$str &$sep]
    return [string range $r $padlen end-[string length $sep]]
}

proc tabline {a b c} {
    puts "[format %2s $a] [format %10s $b] [format %8s $c]"
}

proc doit {{nmax 20000000}} {
    for {set i 0} {$i < 61} {incr i} {
        puts -nonewline " [fusc $i]"
    }
    puts ""
    tabline L n fusc(n)
    set maxL 0
    for {set n 0} {$n < $nmax} {incr n} {
        set f [fusc $n]
        set L [string length $f]
        if {$L > $maxL} {
            set maxL $L
            tabline $L [,,, $n] [,,, $f]
        }
    }
}
doit


Print "Index-------Value"

For i = 0 To 60
  Print Using "____#"; i; Using "___________#"; FUNC(_fusc(i))
Next

Proc _printLargeFuscs (35500)
End

_fusc
  Param (1)

  If ([email protected] = 0) + ([email protected] = 1) Then Return ([email protected])
  If ([email protected] % 2) = 0 Then Return (FUNC(_fusc([email protected]/2)))
Return (FUNC(_fusc(([email protected] - 1)/2)) + FUNC(_fusc(([email protected] + 1)/2)))

_printLargeFuscs
  Param (1)
  Local (4)             '              (int) i, f, len, maxLen = 1

  [email protected] = 1
  Print "\n\nPrinting all largest Fusc numbers upto "; [email protected]; "\nIndex-------Value"

  For [email protected] = 0 To [email protected]
    [email protected] = FUNC(_fusc([email protected]))
    [email protected] = Len(Str([email protected]))

    If [email protected] > [email protected] Then
      [email protected] = [email protected]
      Print Using "____#"; [email protected]; Using "___________#"; [email protected]
    EndIf
  Next
Return


int fusc(int n) {
  if (n == 0 || n == 1)
    return n;
  else if (n % 2 == 0)
    return fusc(n / 2);
  else
    return fusc((n - 1) / 2) + fusc((n + 1) / 2);
}

void main() {
  print("The first 61 fusc numbers:\n");
  for (int i = 0; i < 61; i++)
    print(@"$(fusc(i)) ");
  print("\n\nThe fusc numbers whose lengths are greater than those of previous fusc numbers:\n");
  print("        n   fusc(n)\n");
  print("-------------------\n");
  var max_length = 0;
  for (int i = 0; i < 700000; i++) {
    var f = fusc(i);
    var length = f.to_string().length;
    if (length > max_length) {
      max_length = length;
      print("%9d %9d\n", i, f);
    }
  }
}


Module Module1

    Dim n As Integer = 61, l As List(Of Integer) = {0, 1}.ToList

    Function fusc(n As Integer) As Integer
        If n < l.Count Then Return l(n)
        fusc = If((n And 1) = 0, l(n >> 1), l((n - 1) >> 1) + l((n + 1) >> 1))
        l.Add(fusc)
    End Function

    Sub Main(args As String())
        Dim lst As Boolean = True, w As Integer = -1, c As Integer = 0,
            fs As String = "{0,11:n0}  {1,-9:n0}", res As String = ""
        Console.WriteLine("First {0} numbers in the fusc sequence:", n)
        For i As Integer = 0 To Integer.MaxValue
            Dim f As Integer = fusc(i)
            If lst Then
                If i < 61 Then
                    Console.Write("{0} ", f)
                Else
                    lst = False
                    Console.WriteLine()
                    Console.WriteLine("Points in the sequence where an item has more digits than any previous items:")
                    Console.WriteLine(fs, "Index\", "/Value") : Console.WriteLine(res) : res = ""
                End If
            End If
            Dim t As Integer = f.ToString.Length
            If t > w Then
                w = t
                res &= If(res = "", "", vbLf) & String.Format(fs, i, f)
                If Not lst Then Console.WriteLine(res) : res = ""
                c += 1 : If c > 5 Then Exit For
            End If
        Next : l.Clear()
    End Sub
End Module


import "/fmt" for Fmt

System.print("The first 61 numbers in the fusc sequence are:")
var fusc = [0, 1]
var fusc2 = [[0, 0]]
var maxLen = 1
var n = 2
while (n < 20e6) { // limit to indices under 20 million say
    var f  = (n % 2  == 0) ? fusc[n/2] : fusc[(n-1)/2] + fusc[(n+1)/2]
    fusc.add(f)
    var len = "%(f)".count
    if (len > maxLen) {
        maxLen = len
        if (n <= 60) {
            fusc2.add([n, f])
        } else {
            System.print("%(Fmt.dc(10, n))  %(Fmt.dc(0, f))")
        }
    }
    if (n == 60 ) {
        for (f in fusc) System.write("%(f) ")
        System.print("\n\nFirst terms longer than any previous ones for indices < 20,000,000:")
        System.print("     Index  Value")
        for (iv in fusc2) System.print("%(Fmt.d(10, iv[0]))  %(iv[1])")
    }
    n = n + 1
}


func IntLen(N); \Return number of digits in N
int  N, L;
[L:= 0;
repeat  N:= N/10;
        L:= L+1;
until   N = 0;
return L;
];

def Size = 1000000;
int Fusc(Size), N, Len, Max;
[Fusc(0):= 0;  Fusc(1):= 1;
for N:= 2 to Size-1 do
    Fusc(N):= if N&1 then Fusc((N-1)/2) + Fusc((N+1)/2) else Fusc(N/2);
for N:= 0 to 60 do
        [IntOut(0, Fusc(N));  ChOut(0, ^ )];
Text(0, "
n       fusc(n)
");
Max:= 0;
for N:= 0 to Size-1 do
    [Len:= IntLen(Fusc(N));
    if Len > Max then
        [Max:= Len;
        IntOut(0, N);  ChOut(0, 9\tab\);
        IntOut(0, Fusc(N));  CrLf(0);
        ];
    ];
]


maximo = 20000000
dim f(maximo)

fusc()

for i = 0 to 60
    print f(i), " ";
next i

print "\n\n      Index       Value"
d = 0
for i = 0 to maximo-1
    if f(i) >= d then
        print i using "###,###,###", f(i) using "###,###,###"
        if d = 0 d = 1
        d = d * 10
    end if
next i
end

sub fusc()
    f(0) = 0 : f(1) = 1
    for n = 2 to maximo-1
        if mod(n, 2) then
            f(n) = f((n-1) / 2) + f((n+1) / 2)
        else
            f(n) = f(n / 2)
        end if
    next n
end sub


fuscs:=List.createLong(1_000_000, 0); fuscs[1]=1; // we'll just use a big count
foreach n in ([2..fuscs.len()-1]){		 // and generate
   fuscs[n]=( if(n.isEven()) fuscs[n/2] else fuscs[(n-1)/2] + fuscs[(n+1)/2] )
}

println("First 61 terms of the Stern-Brocot sequence:");
fuscs[0,61].concat(" ").println();

println("\nIndex and value for first term longer than any previous:");
println("          Index : Value");
prevMax:=-1;
foreach n in (fuscs.len()){
   f,fd := fuscs[n], f.numDigits;
   if(fd>prevMax){ println("%15,d : %,d".fmt(n,f)); prevMax=fd }
}


#include <stdio.h>
#include <stdlib.h>
#include <math.h>
#include <gsl/gsl_sf_gamma.h>
#ifndef M_PI
#define M_PI 3.14159265358979323846
#endif

/* very simple approximation */
double st_gamma(double x)
{
  return sqrt(2.0*M_PI/x)*pow(x/M_E, x);
}

#define A 12
double sp_gamma(double z)
{
  const int a = A;
  static double c_space[A];
  static double *c = NULL;
  int k;
  double accm;

  if ( c == NULL ) {
    double k1_factrl = 1.0; /* (k - 1)!*(-1)^k with 0!==1*/
    c = c_space;
    c[0] = sqrt(2.0*M_PI);
    for(k=1; k < a; k++) {
      c[k] = exp(a-k) * pow(a-k, k-0.5) / k1_factrl;
	  k1_factrl *= -k;
    }
  }
  accm = c[0];
  for(k=1; k < a; k++) {
    accm += c[k] / ( z + k );
  }
  accm *= exp(-(z+a)) * pow(z+a, z+0.5); /* Gamma(z+1) */
  return accm/z;
}

int main()
{
  double x;

  printf("%15s%15s%15s%15s\n", "Stirling", "Spouge", "GSL", "libm");
  for(x=1.0; x <= 10.0; x+=1.0) {
    printf("%15.8lf%15.8lf%15.8lf%15.8lf\n", st_gamma(x/3.0), sp_gamma(x/3.0),
	   gsl_sf_gamma(x/3.0), tgamma(x/3.0));
  }
  return 0;
}


#include <math.h>
#include <numbers>
#include <stdio.h>
#include <vector>

// Calculate the coefficients used by Spouge's approximation (based on the C
// implemetation)
std::vector<double> CalculateCoefficients(int numCoeff)
{
    std::vector<double> c(numCoeff);
    double k1_factrl = 1.0;
    c[0] = sqrt(2.0 * std::numbers::pi);
    for(size_t k=1; k < numCoeff; k++)
    {
        c[k] = exp(numCoeff-k) * pow(numCoeff-k, k-0.5) / k1_factrl;
        k1_factrl *= -(double)k;
    }
    return c;
}

// The Spouge approximation
double Gamma(const std::vector<double>& coeffs, double x)
{
        const size_t numCoeff = coeffs.size();
        double accm = coeffs[0];
        for(size_t k=1; k < numCoeff; k++)
        {
            accm += coeffs[k] / ( x + k );
        }
        accm *= exp(-(x+numCoeff)) * pow(x+numCoeff, x+0.5);
        return accm/x;
}

int main()
{
    // estimate the gamma function with 1, 4, and 10 coefficients
    const auto coeff1 = CalculateCoefficients(1);
    const auto coeff4 = CalculateCoefficients(4);
    const auto coeff10 = CalculateCoefficients(10);

    const auto inputs = std::vector<double>{
        0.001, 0.01, 0.1, 0.5, 1.0,
        1.461632145, // minimum of the gamma function
        2, 2.5, 3, 4, 5, 6, 7, 8, 9, 10, 50, 100,
        150 // causes overflow for this implemetation
        };

    printf("%16s%16s%16s%16s%16s\n", "gamma( x ) =", "Spouge 1", "Spouge 4", "Spouge 10", "built-in");
    for(auto x : inputs)
    {
        printf("gamma(%7.3f) = %16.10g %16.10g %16.10g %16.10g\n",
            x,
            Gamma(coeff1, x),
            Gamma(coeff4, x),
            Gamma(coeff10, x),
            std::tgamma(x)); // built-in gamma function
    }
}


open System

let gamma z =
    let lanczosCoefficients = [76.18009172947146;-86.50532032941677;24.01409824083091;-1.231739572450155;0.1208650973866179e-2;-0.5395239384953e-5]
    let rec sumCoefficients acc i coefficients =
        match coefficients with
        | []   -> acc
        | h::t -> sumCoefficients (acc + (h/i)) (i+1.0) t
    let gamma = 5.0
    let x = z - 1.0
    Math.Pow(x + gamma + 0.5, x + 0.5) * Math.Exp( -(x + gamma + 0.5) ) * Math.Sqrt( 2.0 * Math.PI ) * sumCoefficients 1.000000000190015 (x + 1.0) lanczosCoefficients

seq { for i in 1 .. 20 do yield ((double)i/10.0) } |> Seq.iter ( fun v -> System.Console.WriteLine("{0} : {1}", v, gamma v ) )
seq { for i in 1 .. 10 do yield ((double)i*10.0) } |> Seq.iter ( fun v -> System.Console.WriteLine("{0} : {1}", v, gamma v ) )


! built in
USING: picomath prettyprint ;
0.1 gamma .  ! 9.513507698668723
2.0 gamma .  ! 1.0
10. gamma .  ! 362880.0


8 constant (gamma-shift)

: (mortici)                            ( f1 -- f2)
  -1 s>f f+ 1 s>f
  fover 271828183e-8 f* 12 s>f f* f/
  fover 271828183e-8 f/ f+
  fover f** fswap
  628318530e-8 f* fsqrt f*             \ 2*pi
;

: gamma                                ( f1 -- f2)
  fdup f0< >r fdup f0= r> or abort" Gamma less or equal to zero"
  fdup (gamma-shift) s>f f+ (mortici) fswap
  1 s>f (gamma-shift) 0 do fover i s>f f+ f* loop fswap fdrop f/
;


program ComputeGammaInt

  implicit none

  integer :: i

  write(*, "(3A15)") "Simpson", "Lanczos", "Builtin"
  do i=1, 10
     write(*, "(3F15.8)") my_gamma(i/3.0), lacz_gamma(i/3.0), gamma(i/3.0)
  end do

contains

  pure function intfuncgamma(x, y) result(z)
    real :: z
    real, intent(in) :: x, y

    z = x**(y-1.0) * exp(-x)
  end function intfuncgamma

  function my_gamma(a) result(g)
    real :: g
    real, intent(in) :: a

    real, parameter :: small = 1.0e-4
    integer, parameter :: points = 100000

    real :: infty, dx, p, sp(2, points), x
    integer :: i
    logical :: correction

    x = a

    correction = .false.
    ! value with x<1 gives \infty, so we use
    ! \Gamma(x+1) = x\Gamma(x)
    ! to avoid the problem
    if ( x < 1.0 ) then
       correction = .true.
       x = x + 1
    end if

    ! find a "reasonable" infinity...
    ! we compute this integral indeed
    ! \int_0^M dt t^{x-1} e^{-t}
    ! where M is such that M^{x-1} e^{-M} ≤ \epsilon
    infty = 1.0e4
    do while ( intfuncgamma(infty, x) > small )
       infty = infty * 10.0
    end do

    ! using simpson
    dx = infty/real(points)
    sp = 0.0
    forall(i=1:points/2-1) sp(1, 2*i) = intfuncgamma(2.0*(i)*dx, x)
    forall(i=1:points/2) sp(2, 2*i - 1) = intfuncgamma((2.0*(i)-1.0)*dx, x)
    g = (intfuncgamma(0.0, x) + 2.0*sum(sp(1,:)) + 4.0*sum(sp(2,:)) + &
         intfuncgamma(infty, x))*dx/3.0

    if ( correction ) g = g/a

  end function my_gamma

  recursive function lacz_gamma(a) result(g)
    real, intent(in) :: a
    real :: g

    real, parameter :: pi = 3.14159265358979324
    integer, parameter :: cg = 7

    ! these precomputed values are taken by the sample code in Wikipedia,
    ! and the sample itself takes them from the GNU Scientific Library
    real, dimension(0:8), parameter :: p = &
         (/ 0.99999999999980993, 676.5203681218851, -1259.1392167224028, &
         771.32342877765313, -176.61502916214059, 12.507343278686905, &
         -0.13857109526572012, 9.9843695780195716e-6, 1.5056327351493116e-7 /)

    real :: t, w, x
    integer :: i

    x = a

    if ( x < 0.5 ) then
       g = pi / ( sin(pi*x) * lacz_gamma(1.0-x) )
    else
       x = x - 1.0
       t = p(0)
       do i=1, cg+2
          t = t + p(i)/(x+real(i))
       end do
       w = x + real(cg) + 0.5
       g = sqrt(2.0*pi) * w**(x+0.5) * exp(-w) * t
    end if
  end function lacz_gamma

end program ComputeGammaInt


' FB 1.05.0 Win64

Const pi = 3.1415926535897932
Const e  = 2.7182818284590452

Function gammaStirling (x As Double) As Double
  Return Sqr(2.0 * pi / x) * ((x / e) ^ x)
End Function

Function gammaLanczos (x As Double) As Double
  Dim p(0 To 8) As Double = _
  { _
       0.99999999999980993, _
     676.5203681218851, _
   -1259.1392167224028, _
     771.32342877765313, _
    -176.61502916214059, _
      12.507343278686905, _
      -0.13857109526572012, _
       9.9843695780195716e-6, _
       1.5056327351493116e-7 _
  }

  Dim As Integer g = 7
  If x < 0.5 Then Return pi / (Sin(pi * x) * gammaLanczos(1-x))
  x -= 1
  Dim a As Double = p(0)
  Dim t As Double = x + g + 0.5

  For i As Integer = 1 To 8
    a += p(i) / (x + i)
  Next

  Return Sqr(2.0 * pi) * (t ^ (x + 0.5)) * Exp(-t) * a
End Function

Print " x", "    Stirling",, "    Lanczos"
Print
For i As Integer = 1 To 20
   Dim As Double d = i / 10.0
   Print   Using "#.##"; d;
   Print , Using "#.###############"; gammaStirling(d);
   Print , Using "#.###############"; gammaLanczos(d)
Next
Print
Print "Press any key to quit"
Sleep


procedure main()
    every write(left(i := !10/10.0,5),gamma(.i))
end

procedure gamma(z)	# Stirling's approximation
    return (2*&pi/z)^0.5 * (z/&e)^z
end


public class GammaFunction {

	public double st_gamma(double x){
		return Math.sqrt(2*Math.PI/x)*Math.pow((x/Math.E), x);
	}

	public double la_gamma(double x){
		double[] p = {0.99999999999980993, 676.5203681218851, -1259.1392167224028,
			     	  771.32342877765313, -176.61502916214059, 12.507343278686905,
			     	  -0.13857109526572012, 9.9843695780195716e-6, 1.5056327351493116e-7};
		int g = 7;
		if(x < 0.5) return Math.PI / (Math.sin(Math.PI * x)*la_gamma(1-x));

		x -= 1;
		double a = p[0];
		double t = x+g+0.5;
		for(int i = 1; i < p.length; i++){
			a += p[i]/(x+i);
		}

		return Math.sqrt(2*Math.PI)*Math.pow(t, x+0.5)*Math.exp(-t)*a;
	}

	public static void main(String[] args) {
		GammaFunction test = new GammaFunction();
		System.out.println("Gamma \t\tStirling \t\tLanczos");
		for(double i = 1; i <= 20; i += 1){
			System.out.println("" + i/10.0 + "\t\t" + test.st_gamma(i/10.0) + "\t" + test.la_gamma(i/10.0));
		}
	}
}


// version 1.0.6

fun gammaStirling(x: Double): Double = Math.sqrt(2.0 * Math.PI / x) * Math.pow(x / Math.E, x)

fun gammaLanczos(x: Double): Double {
    var xx = x
    val p = doubleArrayOf(
        0.99999999999980993,
      676.5203681218851,
    -1259.1392167224028,
      771.32342877765313,
     -176.61502916214059,
       12.507343278686905,
       -0.13857109526572012,
        9.9843695780195716e-6,
        1.5056327351493116e-7
    )
    val g = 7
    if (xx < 0.5) return Math.PI / (Math.sin(Math.PI * xx) * gammaLanczos(1.0 - xx))
    xx--
    var a = p[0]
    val t = xx + g + 0.5
    for (i in 1 until p.size) a += p[i] / (xx + i)
    return Math.sqrt(2.0 * Math.PI) * Math.pow(t, xx + 0.5) * Math.exp(-t) * a
}

fun main(args: Array<String>) {
    println(" x\tStirling\t\tLanczos\n")
    for (i in 1 .. 20) {
        val d = i / 10.0
        print("%4.2f\t".format(d))
        print("%17.15f\t".format(gammaStirling(d)))
        println("%17.15f".format(gammaLanczos(d)))
    }
}


implement Lanczos7;

include "sys.m"; sys: Sys;
include "draw.m";
include "math.m"; math: Math;
	lgamma, exp, pow, sqrt: import math;

Lanczos7: module {
	init: fn(nil: ref Draw->Context, nil: list of string);
};

init(nil: ref Draw->Context, nil: list of string)
{
	sys = load Sys Sys->PATH;
	math = load Math Math->PATH;
	# We ignore some floating point exceptions:
	math->FPcontrol(0, Math->OVFL|Math->UNFL);
	ns : list of real = -0.5 :: 0.1 :: 0.5 :: 1.0 :: 1.5 :: 2.0 :: 3.0 :: 10.0 :: 140.0 :: 170.0 :: nil;

	sys->print("%5s %24s %24s\n", "x", "math->lgamma", "lanczos7");
	while(ns != nil) {
		x := hd ns;
		ns = tl ns;
		# math->lgamma returns a tuple.
		(i, r) := lgamma(x);
		g := real i * exp(r);
		sys->print("%5.1f %24.16g %24.16g\n", x, g, lanczos7(x));
	}
}

lanczos7(z: real): real
{
	t := z + 6.5;
	x := 0.99999999999980993 +
		676.5203681218851/z -
		1259.1392167224028/(z+1.0) +
		771.32342877765313/(z+2.0) -
		176.61502916214059/(z+3.0) +
		12.507343278686905/(z+4.0) -
		0.13857109526572012/(z+5.0) +
		9.9843695780195716e-6/(z+6.0) +
		1.5056327351493116e-7/(z+7.0);
	return sqrt(2.0) * sqrt(Math->Pi) * pow(t, z - 0.5) * exp(-t) * x;
}


gamma, coeff, quad, qui, set = 0.577215664901, -0.65587807152056, -0.042002635033944, 0.16653861138228,	-0.042197734555571
function recigamma(z)
  return z + gamma * z^2 + coeff * z^3 + quad * z^4 + qui * z^5 + set * z^6
end

function gammafunc(z)
  if z == 1 then return 1
  elseif math.abs(z) <= 0.5 then return 1 / recigamma(z)
  else return (z - 1) * gammafunc(z-1)
  end
end


Module PrepareLambdaFunctions {
      Const e = [email protected]
      Exp= Lambda e (x) -> e^x
      gammaStirling=lambda e (x As decimal)->Sqrt(2.0 * pi / x) * ((x / e) ^ x)
      Rad2Deg =Lambda pidivby180=pi/180 (RadAngle)->RadAngle / pidivby180
      Dim p(9)
      p(0)[email protected], [email protected],   [email protected],  [email protected]
      p(4)[email protected],  [email protected],  [email protected],  [email protected]
      p(8)[email protected]
      gammaLanczos =Lambda p(), Rad2Deg, Exp (x As decimal) -> {
            Def Decimal a, t
            If x < 0.5 Then =pi / (Sin(Rad2Deg(pi * x)) *Lambda(1-x)) : Exit
            x -= [email protected]
            a=p(0)
            t = x + [email protected]
            For i= [email protected] To [email protected] {
                  a += p(i) / (x + i)
            }
             = Sqrt(2.0 * pi) * (t ^ (x + 0.5)) * Exp(-t) * a
      }
      Push gammaStirling, gammaLanczos
}
Call PrepareLambdaFunctions
Read gammaLanczos, gammaStirling
Font "Courier New"
Form 120, 40
document doc$="     χ                        Stirling                     Lanczos"+{
}
Print $(2,20),"x", "Stirling",@(55),"Lanczos", $(0)
Print
For d = 0.1 To 2 step 0.1
      Print   $("0.00"), d,
      Print  $("0.000000000000000"), gammaStirling(d),
      Print  $("0.0000000000000000000000000000"), gammaLanczos(d)
      doc$=format$("{0:-10}  {1:-30}   {2:-34}",str$(d,"0.00"), str$(gammaStirling(d),"0.000000000000000"), str$(gammaLanczos(d),"0.0000000000000000000000000000"))+{
      }
Next d
Print $("")
clipboard doc$


fpprec: 30$

gamma_coeff(n) := block([a: makelist(1, n)],
   a[2]: bfloat(%gamma),
   for k from 3 thru n do
      a[k]: bfloat((sum((-1)^j * zeta(j) * a[k - j], j, 2, k - 1) - a[2] * a[k - 1]) / (1 - k * a[1])),
   a)$

poleval(a, x) := block([y: 0],
   for k from length(a) thru 1 step -1 do
      y: y * x + a[k],
   y)$

gc: gamma_coeff(20)$

gamma_approx(x) := block([y: 1],
   while x > 2 do (x: x - 1, y: y * x),
   y / (poleval(gc, x - 1)))$

gamma_approx(12.3b0) - gamma(12.3b0);
/* -9.25224705314470500985141176997b-15 */


let e = exp 1.
let pi = 4. *. atan 1.
let sqrttwopi = sqrt (2. *. pi)

module Lanczos = struct
  (* Lanczos method *)
  (* Coefficients used by the GNU Scientific Library *)
  let g = 7.
  let c = [|0.99999999999980993; 676.5203681218851; -1259.1392167224028;
	    771.32342877765313; -176.61502916214059; 12.507343278686905;
	    -0.13857109526572012; 9.9843695780195716e-6; 1.5056327351493116e-7|]

  let rec ag z d =
    if d = 0 then c.(0) +. ag z 1
    else if d < 8 then c.(d) /. (z +. float d) +. ag z (succ d)
    else c.(d) /. (z +. float d)

  let gamma z =
    let z = z -. 1. in
    let p = z +. g +. 0.5 in
    sqrttwopi *. p ** (z +. 0.5) *. exp (-. p) *. ag z 0
end

module Stirling = struct
  (* Stirling method *)
  let gamma z =
    sqrttwopi /. sqrt z *. (z /. e) ** z

end

module Stirling2 = struct
  (* Extended Stirling method seen in Abramowitz and Stegun *)
  let d = [|1./.12.; 1./.288.; -139./.51840.; -571./.2488320.|]

  let rec corr z x n =
    if n < Array.length d - 1 then d.(n) /. x +. corr z (x *. z) (succ n)
    else d.(n) /. x

  let gamma z = Stirling.gamma z *. (1. +. corr z z 0)
end

let mirror gma z =
  if z > 0.5 then gma z
  else pi /. sin (pi *. z) /. gma (1. -. z)

let _ =
  Printf.printf "z\t\tLanczos\t\tStirling\tStirling2\n";
  for i = 1 to 20 do
    let z = float i /. 10. in
    Printf.printf "%-10.8g\t%10.8e\t%10.8e\t%10.8e\n"
    		  z
		  (mirror Lanczos.gamma z)
		  (mirror Stirling.gamma z)
		  (mirror Stirling2.gamma z)
  done;
  for i = 1 to 7 do
    let z = 10. *. float i in
    Printf.printf "%-10.8g\t%10.8e\t%10.8e\t%10.8e\n"
    		  z
		  (Lanczos.gamma z)
		  (Stirling.gamma z)
		  (Stirling2.gamma z)
  done


program GammaTest;
{$mode objfpc}{$H+}
uses SysUtils;

function Gamma( x : extended) : extended;
const COF : array [0..14] of extended =
(  0.999999999999997092, // may as well include this in the array
  57.1562356658629235,
 -59.5979603554754912,
  14.1360979747417471,
 -0.491913816097620199,
  0.339946499848118887e-4,
  0.465236289270485756e-4,
 -0.983744753048795646e-4,
  0.158088703224912494e-3,
 -0.210264441724104883e-3,
  0.217439618115212643e-3,
 -0.164318106536763890e-3,
  0.844182239838527433e-4,
 -0.261908384015814087e-4,
  0.368991826595316234e-5);
const
  K = 2.5066282746310005;
  PI_OVER_K = PI / K;
var
  j : integer;
  tmp, w, ser : extended;
  reflect : boolean;
begin
  reflect := (x < 0.5);
  if reflect then w := 1.0 - x else w := x;
  tmp := w + 5.2421875;
  tmp := (w + 0.5)*Ln(tmp) - tmp;
  ser := COF[0];
  for j := 1 to 14 do ser := ser + COF[j]/(w + j);
  try
    if reflect then
      result := PI_OVER_K * w * Exp(-tmp) / (Sin(PI*x) * ser)
    else
      result := K * Exp(tmp) * ser / w;
  except
    raise SysUtils.Exception.CreateFmt(
        'Gamma(%g) is undefined or out of floating-point range', [x]);
  end;
end;

// Main routine for testing the Gamma function
var
    x, k : extended;
begin
  WriteLn( 'Is it seamless at x = 1/2 ?');
  x := 0.49999999999999;
  WriteLn( SysUtils.Format( 'Gamma(%g) = %g', [x, Gamma(x)]));
  x := 0.50000000000001;
  WriteLn( SysUtils.Format( 'Gamma(%g) = %g', [x, Gamma(x)]));
  WriteLn( 'Test a few values:');
  WriteLn( SysUtils.Format( 'Gamma(1)   = %g', [Gamma(1)]));
  WriteLn( SysUtils.Format( 'Gamma(2)   = %g', [Gamma(2)]));
  WriteLn( SysUtils.Format( 'Gamma(3)   = %g', [Gamma(3)]));
  WriteLn( SysUtils.Format( 'Gamma(10)  = %g', [Gamma(10)]));
  WriteLn( SysUtils.Format( 'Gamma(101) = %g', [Gamma(101)]));
  WriteLn( '      100! = 9.33262154439442E157');
  WriteLn( SysUtils.Format( 'Gamma(1/2) = %g', [Gamma(0.5)]));
  WriteLn( SysUtils.Format( 'Sqrt(pi)   = %g', [Sqrt(PI)]));
  WriteLn( SysUtils.Format( 'Gamma(-7/2)       =  %g', [Gamma(-3.5)]));
(*
  Note here a bug or misfeature in Lazarus (doesn't occur in Delphi):
  Putting (16.0/105.0)*Sqrt(PI) does not give the required precision.
  We have to explicitly define the integers as extended floating-point.
*)
  k := extended(16.0)/extended(105.0);
  WriteLn( SysUtils.Format( ' (16/105)Sqrt(pi) =  %g', [k*Sqrt(PI)]));
  WriteLn( SysUtils.Format( 'Gamma(-9/2)       = %g', [Gamma(-4.5)]));
  k := extended(32.0)/extended(945.0);
  WriteLn( SysUtils.Format( '-(32/945)Sqrt(pi) = %g', [-k*Sqrt(PI)]));
end.


with javascript_semantics
sequence c = repeat(0,12)

function gamma(atom z)
    atom accm = c[1]
    if accm=0 then
        accm = sqrt(2*PI)
        c[1] = accm
        atom k1_factrl = 1  -- (k - 1)!*(-1)^k with 0!==1
        for k=2 to 12 do
            c[k] = exp(13-k)*power(13-k,k-1.5)/k1_factrl
            k1_factrl *= -(k-1)
        end for
    end if
    for k=2 to 12 do
        accm += c[k]/(z+k-1)
    end for
    accm *= exp(-(z+12))*power(z+12,z+0.5) -- Gamma(z+1)
    return accm/z
end function

procedure sq(atom x, atom mul)
atom p = x*mul
    printf(1,"%18.16g,%18.15g\n",{x,p*p})
end procedure

procedure si(atom x)
    printf(1,"%18.15f\n",{x})
end procedure

sq(gamma(-3/2),3/4)
sq(gamma(-1/2),-1/2)
sq(gamma(1/2),1)
si(gamma(1))
sq(gamma(3/2),2)
si(gamma(2))
sq(gamma(5/2),4/3)
si(gamma(3))
sq(gamma(7/2),8/15)
si(gamma(4))


0.577215664901 var gamma
-0.65587807152056 var coeff
-0.042002635033944 var quad
0.16653861138228 var qui
-0.042197734555571 var theSet

def recigamma var z /# n -- n #/
    z 6 power theSet *
    z 5 power qui *
    z 4 power quad *
    z 3 power coeff *
    z 2 power gamma *
    z + + + + +
enddef

/# without var
def recigamma
    dup 6 power theSet * swap
    dup 5 power qui * swap
    dup 4 power quad * swap
    dup 3 power coeff * swap
    dup 2 power gamma * swap
    + + + + +
enddef
#/

def gammafunc   /# n -- n #/
    dup 1 == if
    else
        dup abs 0.5 <= if
            recigamma 1 swap /
        else
            dup 1 - gammafunc swap 1 - *
        endif
    endif
enddef

0.1 2.1 .1 3 tolist
for
    dup print " = " print gammafunc print nl
endfor


/* From Rosetta Fortran */
test: procedure options (main);

  declare i fixed binary;

  on underflow ;

  put skip list ('Lanczos', 'Builtin' );
  do i = 1 to 10;
     put skip list (lanczos_gamma(i/3.0q0), gamma(i/3.0q0) );
  end;

lanczos_gamma: procedure (a) returns (float (18)) recursive;
    declare a float (18);
    declare pi float (18) value (3.14159265358979324E0);
    declare cg fixed binary initial ( 7 );

    /* these precomputed values are taken by the sample code in Wikipedia, */
    /* and the sample itself takes them from the GNU Scientific Library */
    declare p(0:8) float (18) static initial
         ( 0.99999999999980993e0, 676.5203681218851e0, -1259.1392167224028e0,
         771.32342877765313e0, -176.61502916214059e0, 12.507343278686905e0,
         -0.13857109526572012e0, 9.9843695780195716e-6, 1.5056327351493116e-7 );

    declare ( t, w, x ) float (18);
    declare i fixed binary;

    x = a;

    if x < 0.5 then
       return ( pi / ( sin(pi*x) * lanczos_gamma(1.0-x) ) );
    else
       do;
          x = x - 1.0;
          t = p(0);
          do i = 1 to cg+2;
             t = t + p(i)/(x+i);
          end;
          w = x + float(cg) + 0.5;
          return ( sqrt(2*pi) * w**(x+0.5) * exp(-w) * t );
       end;
  end lanczos_gamma;

end test;


*        Gaussian elimination      09/02/2019
GAUSSEL  CSECT
         USING  GAUSSEL,R13        base register
         B      72(R15)            skip savearea
         DC     17F'0'             savearea
         SAVE   (14,12)            save previous context
         ST     R13,4(R15)         link backward
         ST     R15,8(R13)         link forward
         LR     R13,R15            set addressability
         LA     R7,1               j=1
       DO WHILE=(C,R7,LE,N)        do j=1 to n
         LA     R9,1(R7)             j+1
         LR     R6,R9                i=j+1
       DO WHILE=(C,R6,LE,N)          do i=j+1 to n
         LR     R1,R7                  j
         MH     R1,=AL2(NN)            *n
         AR     R1,R7                  +j
         BCTR   R1,0                   j*n+j-1
         SLA    R1,2                   ~
         LE     F0,A-(NN*4)(R1)        a(j,j)
         LR     R1,R6                  i
         MH     R1,=AL2(NN)            *n
         AR     R1,R7                  j
         BCTR   R1,0                   i*n+j-1
         SLA    R1,2                   ~
         LE     F2,A-(NN*4)(R1)        a(i,j)
         DER    F0,F2                  a(j,j)/a(i,j)
         STE    F0,W                   w=a(j,j)/a(i,j)
         LR     R8,R9                  k=j+1
       DO WHILE=(C,R8,LE,N)            do k=j+1 to n
         LR     R1,R7                    j
         MH     R1,=AL2(NN)              *n
         AR     R1,R8                    +k
         BCTR   R1,0                     j*n+k-1
         SLA    R1,2                     ~
         LE     F0,A-(NN*4)(R1)          a(j,k)
         LR     R1,R6                    i
         MH     R1,=AL2(NN)              *n
         AR     R1,R8                    +k
         BCTR   R1,0                     i*n+k-1
         SLA    R1,2                     ~
         LE     F2,A-(NN*4)(R1)          a(i,k)
         LE     F6,W                     w
         MER    F6,F2                    *a(i,k)
         SER    F0,F6                    a(j,k)-w*a(i,k)
         STE    F0,A-(NN*4)(R1)          a(i,k)=a(j,k)-w*a(i,k)
         LA     R8,1(R8)                 k=k+1
       ENDDO    ,                      end do k
         LR     R1,R7                  j
         SLA    R1,2                   ~
         LE     F0,B-4(R1)             b(j)
         LR     R1,R6                  i
         SLA    R1,2                   ~
         LE     F2,B-4(R1)             b(i)
         LE     F6,W                   w
         MER    F6,F2                  *b(i)
         SER    F0,F6                  b(j)-w*b(i)
         STE    F0,B-4(R1)             b(i)=b(j)-w*b(i)
         LA     R6,1(R6)               i=i+1
       ENDDO    ,                    end do i
         LA     R7,1(R7)             j=j+1
       ENDDO    ,                  end do j
         L      R2,N               n
         SLA    R2,2               ~
         LE     F0,B-4(R1)         b(n)
         L      R1,N               n
         MH     R1,=AL2(NN)        *n
         A      R1,N               n
         BCTR   R1,0               n*n+n-1
         SLA    R1,2               ~
         LE     F2,A-(NN*4)(R1)    a(n,n)
         DER    F0,F2              b(n)/a(n,n)
         STE    F0,X-4(R2)         x(n)=b(n)/a(n,n)
         L      R7,N               n
         BCTR   R7,0               j=n-1
       DO WHILE=(C,R7,GE,=F'1')    do j=n-1 to 1 by -1
         LE     F0,=E'0'             0
         STE    F0,W                 w=0
         LA     R9,1(R7)             j+1
         LR     R6,R9                i=j+1
       DO WHILE=(C,R6,LE,N)          do i=j+1 to n
         LR     R1,R7                  j
         MH     R1,=AL2(NN)            *n
         AR     R1,R6                  i
         BCTR   R1,0                   j*n+i-1
         SLA    R1,2                   ~
         LE     F0,A-(NN*4)(R1)        a(j,i)
         LR     R1,R6                  i
         SLA    R1,2                   ~
         LE     F2,X-4(R1)             x(i)
         MER    F0,F2                  a(j,i)*x(i)
         LE     F6,W                   w
         AER    F6,F0                  +a(j,i)*x(i)
         STE    F6,W                   w=w+a(j,i)*x(i)
         LA     R6,1(R6)               i=i+1
       ENDDO    ,                    end do i
         LR     R2,R7                j
         SLA    R2,2                 ~
         LE     F0,B-4(R2)           b(j)
         SE     F0,W                 -w
         LR     R1,R7                j
         MH     R1,=AL2(NN)          *n
         AR     R1,R7                j
         BCTR   R1,0                 j*n+j-1
         SLA    R1,2                 ~
         LE     F2,A-(NN*4)(R1)      a(j,j)
         DER    F0,F2                (b(j)-w)/a(j,j)
         STE    F0,X-4(R2)           x(j)=(b(j)-w)/a(j,j)
         BCTR   R7,0                 j=j-1
       ENDDO    ,                  end do j
         XPRNT  =CL8'SOLUTION',8   print
         MVC    PG,=CL91' '        clear buffer
         LA     R6,1               i=1
       DO WHILE=(C,R6,LE,N)        do i=1 to n
         LR     R1,R6                i
         SLA    R1,2                 ~
         LE     F0,X-4(R1)           x(i)
         LA     R0,5                 number of decimals
         BAL    R14,FORMATF          edit
         MVC    PG(13),0(R1)         output
         XPRNT  PG,L'PG              print
         LA     R6,1(R6)             i=i+1
       ENDDO    ,                  end do i
         L      R13,4(0,R13)       restore previous savearea pointer
         RETURN (14,12),RC=0       restore registers from calling sav
         COPY   plig\$_FORMATF.MLC format F13.n
NN       EQU    (X-B)/4            n
N        DC     A(NN)              n
A        DC  E'1',E'0',E'0',E'0',E'0',E'0'
         DC  E'1',E'0.63',E'0.39',E'0.25',E'0.16',E'0.10'
         DC  E'1',E'1.26',E'1.58',E'1.98',E'2.49',E'3.13'
         DC  E'1',E'1.88',E'3.55',E'6.70',E'12.62',E'23.80'
         DC  E'1',E'2.51',E'6.32',E'15.88',E'39.90',E'100.28'
         DC  E'1',E'3.14',E'9.87',E'31.01',E'97.41',E'306.02'
B        DC  E'-0.01',E'0.61',E'0.91',E'0.99',E'0.60',E'0.02'
X        DS     (NN)E              x(n)
W        DS     E                  w
PG       DC     CL91' '            buffer
         REGEQU
         END    GAUSSEL


with Ada.Text_IO;
with Ada.Numerics.Generic_Real_Arrays;

procedure Gaussian_Eliminations is

   type Real is new Float;

   package Real_Arrays is
      new Ada.Numerics.Generic_Real_Arrays (Real);
   use Real_Arrays;

   function Gaussian_Elimination (A : in Real_Matrix;
                                  B : in Real_Vector) return Real_Vector
   is

      procedure Swap_Row (A        : in out Real_Matrix;
                          B        : in out Real_Vector;
                          R_1, R_2 : in     Integer)
      is
         Temp : Real;
      begin
         if R_1 = R_2 then return; end if;

         --  Swal matrix row
         for Col in A'Range (1) loop
            Temp := A (R_1, Col);
            A (R_1, Col) := A (R_2, Col);
            A (R_2, Col) := Temp;
         end loop;

         --  Swap vector row
         Temp    := B (R_1);
         B (R_1) := B (R_2);
         B (R_2) := Temp;
      end Swap_Row;

      AC : Real_Matrix := A;
      BC : Real_Vector := B;
      X  : Real_Vector (A'Range (1)) := BC;
      Max, Tmp : Real;
      Max_Row  : Integer;
   begin
      if
        A'Length (1) /= A'Length (2) or
        A'Length (1) /= B'Length
      then
         raise Constraint_Error with "Dimensions do not match";
      end if;

      if
        A'First (1) /= A'First (2) or
        A'First (1) /= B'First
      then
         raise Constraint_Error with "First index must be same";
      end if;

      for Dia in Ac'Range (1) loop
         Max_Row := Dia;
         Max     := Ac (Dia, Dia);

         for Row in Dia + 1 .. Ac'Last (1) loop
            Tmp := abs (Ac (Row, Dia));
            if Tmp > Max then
               Max_Row := Row;
               Max     := Tmp;
            end if;
         end loop;
         Swap_Row (Ac, Bc, Dia, Max_Row);

         for Row in Dia + 1 .. Ac'Last (1) loop
            Tmp := Ac (Row, Dia) / Ac (Dia, Dia);
            for Col in Dia + 1 .. Ac'Last (1) loop
               Ac (Row, Col) := Ac (Row, Col) - Tmp * Ac (Dia, Col);
            end loop;
            Ac (Row, Dia) := 0.0;
            Bc (Row) := Bc (Row) - Tmp * Bc (Dia);
         end loop;
      end loop;

      for Row in reverse Ac'Range (1) loop
         Tmp := Bc (Row);
         for J in reverse Row + 1 .. Ac'Last (1) loop
            Tmp := Tmp - X (J) * Ac (Row, J);
         end loop;
         X (Row) := Tmp / Ac (Row, Row);
      end loop;

      return X;
   end Gaussian_Elimination;

   procedure Put (V : in Real_Vector) is
      use Ada.Text_IO;
      package Real_IO is
         new Ada.Text_IO.Float_IO (Real);
   begin
      Put ("[ ");
      for E of V loop
         Real_IO.Put (E, Exp => 0, Aft => 6);
         Put (" ");
      end loop;
      Put (" ]");
      New_Line;
   end Put;

   A : constant Real_Matrix :=
     ((1.00, 0.00, 0.00,  0.00,  0.00, 0.00),
      (1.00, 0.63, 0.39,  0.25,  0.16, 0.10),
      (1.00, 1.26, 1.58,  1.98,  2.49, 3.13),
      (1.00, 1.88, 3.55,  6.70, 12.62, 23.80),
      (1.00, 2.51, 6.32, 15.88, 39.90, 100.28),
      (1.00, 3.14, 9.87, 31.01, 97.41, 306.02));

   B : constant Real_Vector :=
     ( -0.01, 0.61, 0.91, 0.99, 0.60, 0.02 );

   X : constant Real_Vector := Gaussian_Elimination (A, B);
begin
   Put (X);
end Gaussian_Eliminations;


Add-Type -Path "C:\Program Files (x86)\Math\MathNet.Numerics.3.12.0\lib\net40\MathNet.Numerics.dll"

1..20 | ForEach-Object {[MathNet.Numerics.SpecialFunctions]::Gamma($_ / 10)}


# -*- coding: utf-8 -*- #
COMMENT PROVIDES
  MODE FIXED; INT fixed exception, unfixed exception;
  PROC (STRING message) FIXED raise, raise value error
END COMMENT

# Note: ℵ indicates attribute is "private", and
        should not be used outside of this prelude #

MODE FIXED = BOOL; # if an exception is detected, can it be fixed "on-site"? #
FIXED fixed exception = TRUE, unfixed exception = FALSE;

MODE #ℵ#SIMPLEOUTV = [0]UNION(CHAR, STRING, INT, REAL, BOOL, BITS);
MODE #ℵ#SIMPLEOUTM = [0]#ℵ#SIMPLEOUTV;
MODE #ℵ#SIMPLEOUTT = [0]#ℵ#SIMPLEOUTM;
MODE SIMPLEOUT  = [0]#ℵ#SIMPLEOUTT;

PROC raise = (#ℵ#SIMPLEOUT message)FIXED: (
  putf(stand error, ($"Exception:"$, $xg$, message, $l$));
  stop
);

PROC raise value error = (#ℵ#SIMPLEOUT message)FIXED:
  IF raise(message) NE fixed exception THEN exception value error; FALSE FI;

SKIP


DEFFUN   CSECT
         USING  DEFFUN,R13
SAVEAREA B      PROLOG-SAVEAREA(R15)
         DC     17F'0'
PROLOG   STM    R14,R12,12(R13)
         ST     R13,4(R15)
         ST     R15,8(R13)
         LR     R13,R15            set base register
BEGIN    L      R2,=F'13'
         ST     R2,X               X=13
         L      R2,=F'17'
         ST     R2,Y               Y=17
         LA     R1,PARMLIST        R1->PARMLIST
         B      SKIPPARM
PARMLIST DS     0F
         DC     A(X)
         DC     A(Y)
SKIPPARM BAL    R14,MULTPLIC       call MULTPLIC
         ST     R0,Z               Z=MULTPLIC(X,Y)
RETURN   L      R13,4(0,R13)       epilog
         LM     R14,R12,12(R13)
         XR     R15,R15            set return code
         BR     R14                return to caller
*
MULTPLIC EQU    *                  function MULTPLIC(X,Y)
         L      R2,0(R1)           R2=(A(X),A(Y))
         XR     R4,R4              R4=0
         L      R5,0(R2)           R5=X
         L      R6,4(R2)           R6=Y
         MR     R4,R6              R4R5=R4R5*R6
         LR     R0,R5              R0=X*Y   (R0 return value)
         BR     R14                end function MULTPLIC
*
X        DS     F
Y        DS     F
Z        DS     F
         YREGS
         END    DEFFUN


MULTIPLY: STX   MULN      ; 6502 has no "acc += xreg" instruction,
          TXA             ; so use a memory address
MULLOOP:  DEY
          CLC             ; remember to clear the carry flag before
          ADC   MULN      ; doing addition or subtraction
          CPY   #$01
          BNE   MULLOOP
          RTS


MOVE.L D0,#$0200
MOVE.L D1,#$0400

JSR doMultiply
;rest of program

JMP $           ;halt

;;;;; somewhere far away from the code above
doMultiply:
MULU D0,D1
RTS


#include <stdio.h>
#include <stdlib.h>
#include <math.h>

#define mat_elem(a, y, x, n) (a + ((y) * (n) + (x)))

void swap_row(double *a, double *b, int r1, int r2, int n)
{
	double tmp, *p1, *p2;
	int i;

	if (r1 == r2) return;
	for (i = 0; i < n; i++) {
		p1 = mat_elem(a, r1, i, n);
		p2 = mat_elem(a, r2, i, n);
		tmp = *p1, *p1 = *p2, *p2 = tmp;
	}
	tmp = b[r1], b[r1] = b[r2], b[r2] = tmp;
}

void gauss_eliminate(double *a, double *b, double *x, int n)
{
#define A(y, x) (*mat_elem(a, y, x, n))
	int i, j, col, row, max_row,dia;
	double max, tmp;

	for (dia = 0; dia < n; dia++) {
		max_row = dia, max = A(dia, dia);

		for (row = dia + 1; row < n; row++)
			if ((tmp = fabs(A(row, dia))) > max)
				max_row = row, max = tmp;

		swap_row(a, b, dia, max_row, n);

		for (row = dia + 1; row < n; row++) {
			tmp = A(row, dia) / A(dia, dia);
			for (col = dia+1; col < n; col++)
				A(row, col) -= tmp * A(dia, col);
			A(row, dia) = 0;
			b[row] -= tmp * b[dia];
		}
	}
	for (row = n - 1; row >= 0; row--) {
		tmp = b[row];
		for (j = n - 1; j > row; j--)
			tmp -= x[j] * A(row, j);
		x[row] = tmp / A(row, row);
	}
#undef A
}

int main(void)
{
	double a[] = {
		1.00, 0.00, 0.00,  0.00,  0.00, 0.00,
		1.00, 0.63, 0.39,  0.25,  0.16, 0.10,
		1.00, 1.26, 1.58,  1.98,  2.49, 3.13,
		1.00, 1.88, 3.55,  6.70, 12.62, 23.80,
		1.00, 2.51, 6.32, 15.88, 39.90, 100.28,
		1.00, 3.14, 9.87, 31.01, 97.41, 306.02
	};
	double b[] = { -0.01, 0.61, 0.91, 0.99, 0.60, 0.02 };
	double x[6];
	int i;

	gauss_eliminate(a, b, x, 6);

	for (i = 0; i < 6; i++)
		printf("%g\n", x[i]);

	return 0;
}


ORG RESET
mov a, #100
mov b, #10
call multiply
; at this point, the result of 100*10 = 1000 = 03e8h is stored in registers a and b
; a = e8
; b = 03
jmp $

multiply:
mul ab
ret


start:
mov al, 0x04
mov bl, 0x05
call multiply
;at this point in execution, the AX register contains 0x0900.
;more code goes here, ideally with some sort of guard against "fallthrough" into multiply.

; somewhere far away from start
multiply:
mul bl     ;outputs 0x0014 to ax
ret


/* ARM assembly AARCH64 Raspberry PI 3B */
/*  program functMul64.s   */

/*******************************************/
/* Constantes file                         */
/*******************************************/
/* for this file see task include a file in language AArch64 assembly*/
.include "../includeConstantesARM64.inc"

/***********************/
/* Initialized data */
/***********************/
.data
szRetourLigne: .asciz "\n"
szMessResult:  .asciz "Resultat : @ \n"      // message result
/***********************
/* No Initialized data */
/***********************/
.bss
sZoneConv:             .skip 24
.text
.global main
main:
                                // function multiply
    mov x0,8
    mov x1,50
    bl multiply                 // call function
    ldr x1,qAdrsZoneConv
    bl conversion10S            // call function with 2 parameter (x0,x1)
    ldr x0,qAdrszMessResult
    ldr x1,qAdrsZoneConv
    bl strInsertAtCharInc       // insert result at @ character
    bl affichageMess            // display message

    mov x0,0                    // return code

100:                            // end of  program
    mov x8,EXIT                 // request to exit program
    svc 0                       // perform the system call
qAdrsZoneConv:    .quad sZoneConv
qAdrszMessResult: .quad szMessResult
/******************************************************************/
/*   Function multiply              */
/******************************************************************/
/* x0 contains value 1 */
/* x1 contains value 2 */
/* x0 return résult   */
multiply:
    mul x0,x1,x0
    ret               // return function
/********************************************************/
/*        File Include fonctions                        */
/********************************************************/
/* for this file see task include a file in language AArch64 assembly */
.include "../includeARM64.inc"


using System;

namespace Rosetta
{
    internal class Vector
    {
        private double[] b;
        internal readonly int rows;

        internal Vector(int rows)
        {
            this.rows = rows;
            b = new double[rows];
        }

        internal Vector(double[] initArray)
        {
            b = (double[])initArray.Clone();
            rows = b.Length;
        }

        internal Vector Clone()
        {
            Vector v = new Vector(b);
            return v;
        }

        internal double this[int row]
        {
            get { return b[row]; }
            set { b[row] = value; }
        }

        internal void SwapRows(int r1, int r2)
        {
            if (r1 == r2) return;
            double tmp = b[r1];
            b[r1] = b[r2];
            b[r2] = tmp;
        }

        internal double norm(double[] weights)
        {
            double sum = 0;
            for (int i = 0; i < rows; i++)
            {
                double d = b[i] * weights[i];
                sum +=  d*d;
            }
            return Math.Sqrt(sum);
        }

        internal void print()
        {
            for (int i = 0; i < rows; i++)
                Console.WriteLine(b[i]);
            Console.WriteLine();
        }

        public static Vector operator-(Vector lhs, Vector rhs)
        {
            Vector v = new Vector(lhs.rows);
            for (int i = 0; i < lhs.rows; i++)
                v[i] = lhs[i] - rhs[i];
            return v;
        }
    }

    class Matrix
    {
        private double[] b;
        internal readonly int rows, cols;

        internal Matrix(int rows, int cols)
        {
            this.rows = rows;
            this.cols = cols;
            b = new double[rows * cols];
        }

        internal Matrix(int size)
        {
            this.rows = size;
            this.cols = size;
            b = new double[rows * cols];
            for (int i = 0; i < size; i++)
                this[i, i] = 1;
        }

        internal Matrix(int rows, int cols, double[] initArray)
        {
            this.rows = rows;
            this.cols = cols;
            b = (double[])initArray.Clone();
            if (b.Length != rows * cols) throw new Exception("bad init array");
        }

        internal double this[int row, int col]
        {
            get { return b[row * cols + col]; }
            set { b[row * cols + col] = value; }
        }

        public static Vector operator*(Matrix lhs, Vector rhs)
        {
            if (lhs.cols != rhs.rows) throw new Exception("I can't multiply matrix by vector");
            Vector v = new Vector(lhs.rows);
            for (int i = 0; i < lhs.rows; i++)
            {
                double sum = 0;
                for (int j = 0; j < rhs.rows; j++)
                    sum += lhs[i,j]*rhs[j];
                v[i] = sum;
            }
            return v;
        }

        internal void SwapRows(int r1, int r2)
        {
            if (r1 == r2) return;
            int firstR1 = r1 * cols;
            int firstR2 = r2 * cols;
            for (int i = 0; i < cols; i++)
            {
                double tmp = b[firstR1 + i];
                b[firstR1 + i] = b[firstR2 + i];
                b[firstR2 + i] = tmp;
            }
        }

        //with partial pivot
        internal void ElimPartial(Vector B)
        {
            for (int diag = 0; diag < rows; diag++)
            {
                int max_row = diag;
                double max_val = Math.Abs(this[diag, diag]);
                double d;
                for (int row = diag + 1; row < rows; row++)
                    if ((d = Math.Abs(this[row, diag])) > max_val)
                    {
                        max_row = row;
                        max_val = d;
                    }
                SwapRows(diag, max_row);
                B.SwapRows(diag, max_row);
                double invd = 1 / this[diag, diag];
                for (int col = diag; col < cols; col++)
                    this[diag, col] *= invd;
                B[diag] *= invd;
                for (int row = 0; row < rows; row++)
                {
                    d = this[row, diag];
                    if (row != diag)
                    {
                        for (int col = diag; col < cols; col++)
                            this[row, col] -= d * this[diag, col];
                        B[row] -= d * B[diag];
                    }
                }
            }
        }

        internal void print()
        {
            for (int i = 0; i < rows; i++)
            {
                for (int j = 0; j < cols; j++)
                    Console.Write(this[i,j].ToString()+"  ");
                Console.WriteLine();
            }
        }
    }
}


function multiply(a:Number, b:Number):Number {
    return a * b;
}


function Multiply (A, B : Float) return Float;


#include <algorithm>
#include <cassert>
#include <cmath>
#include <iomanip>
#include <iostream>
#include <vector>

template <typename scalar_type> class matrix {
public:
    matrix(size_t rows, size_t columns)
        : rows_(rows), columns_(columns), elements_(rows * columns) {}

    matrix(size_t rows, size_t columns,
        const std::initializer_list<std::initializer_list<scalar_type>>& values)
        : rows_(rows), columns_(columns), elements_(rows * columns) {
        assert(values.size() <= rows_);
        auto i = elements_.begin();
        for (const auto& row : values) {
            assert(row.size() <= columns_);
            std::copy(begin(row), end(row), i);
            i += columns_;
        }
    }

    size_t rows() const { return rows_; }
    size_t columns() const { return columns_; }

    const scalar_type& operator()(size_t row, size_t column) const {
        assert(row < rows_);
        assert(column < columns_);
        return elements_[row * columns_ + column];
    }
    scalar_type& operator()(size_t row, size_t column) {
        assert(row < rows_);
        assert(column < columns_);
        return elements_[row * columns_ + column];
    }
private:
    size_t rows_;
    size_t columns_;
    std::vector<scalar_type> elements_;
};

template <typename scalar_type>
void swap_rows(matrix<scalar_type>& m, size_t i, size_t j) {
    size_t columns = m.columns();
    for (size_t k = 0; k < columns; ++k)
        std::swap(m(i, k), m(j, k));
}

template <typename scalar_type>
std::vector<scalar_type> gauss_partial(const matrix<scalar_type>& a0,
                                       const std::vector<scalar_type>& b0) {
    size_t n = a0.rows();
    assert(a0.columns() == n);
    assert(b0.size() == n);
    // make augmented matrix
    matrix<scalar_type> a(n, n + 1);
    for (size_t i = 0; i < n; ++i) {
        for (size_t j = 0; j < n; ++j)
            a(i, j) = a0(i, j);
        a(i, n) = b0[i];
    }
    // WP algorithm from Gaussian elimination page
    // produces row echelon form
    for (size_t k = 0; k < n; ++k) {
        // Find pivot for column k
        size_t max_index = k;
        scalar_type max_value = 0;
        for (size_t i = k; i < n; ++i) {
            // compute scale factor = max abs in row
            scalar_type scale_factor = 0;
            for (size_t j = k; j < n; ++j)
                scale_factor = std::max(std::abs(a(i, j)), scale_factor);
            if (scale_factor == 0)
                continue;
            // scale the abs used to pick the pivot
            scalar_type abs = std::abs(a(i, k))/scale_factor;
            if (abs > max_value) {
                max_index = i;
                max_value = abs;
            }
        }
        if (a(max_index, k) == 0)
            throw std::runtime_error("matrix is singular");
        if (k != max_index)
            swap_rows(a, k, max_index);
        for (size_t i = k + 1; i < n; ++i) {
            scalar_type f = a(i, k)/a(k, k);
            for (size_t j = k + 1; j <= n; ++j)
                a(i, j) -= a(k, j) * f;
            a(i, k) = 0;
        }
    }
    // now back substitute to get result
    std::vector<scalar_type> x(n);
    for (size_t i = n; i-- > 0; ) {
        x[i] = a(i, n);
        for (size_t j = i + 1; j < n; ++j)
            x[i] -= a(i, j) * x[j];
        x[i] /= a(i, i);
    }
    return x;
}

int main() {
    matrix<double> a(6, 6, {
        {1.00, 0.00, 0.00, 0.00, 0.00, 0.00},
        {1.00, 0.63, 0.39, 0.25, 0.16, 0.10},
        {1.00, 1.26, 1.58, 1.98, 2.49, 3.13},
        {1.00, 1.88, 3.55, 6.70, 12.62, 23.80},
        {1.00, 2.51, 6.32, 15.88, 39.90, 100.28},
        {1.00, 3.14, 9.87, 31.01, 97.41, 306.02}
    });
    std::vector<double> b{-0.01, 0.61, 0.91, 0.99, 0.60, 0.02};
    std::vector<double> x{-0.01, 1.602790394502114, -1.6132030599055613,
            1.2454941213714368, -0.4909897195846576, 0.065760696175232};
    std::vector<double> y(gauss_partial(a, b));
    std::cout << std::setprecision(16);
    const double epsilon = 1e-14;
    for (size_t i = 0; i < y.size(); ++i) {
        assert(std::abs(x[i] - y[i]) <= epsilon);
        std::cout << y[i] << '\n';
    }
    return 0;
}


real
multiply(real a, real b)
{
    return a * b;
}


begin
    comment Function definition;

    integer procedure multiply(a,b);
    integer a,b;
    begin
        multiply:=a*b;
    end;

    integer c;
    c:=multiply(2,2);
    outinteger(1,c)
end


PROC multiply = ( LONG REAL a, b ) LONG REAL:
(
  a * b
)


decimals(3)
gamma = 0.577
coeff = -0.655
quad = -0.042
qui = 0.166
set = -0.042

for i=1 to 10
    see gammafunc(i / 3.0) + nl
next

func recigamma z
     return z + gamma * pow(z,2) + coeff * pow(z,3) + quad * pow(z,4) + qui * pow(z,5) + set * pow(z,6)

func gammafunc z
     if z = 1 return 1
     but fabs(z) <= 0.5 return 1 / recigamma(z)
     else return (z - 1) * gammafunc(z-1) ok


(defmacro mapcar-1 (fn n list)
 "Maps a function of two parameters where the first one is fixed, over a list"
  `(mapcar #'(lambda (l) (funcall ,fn ,n l)) ,list) )

(defun gauss (m)
  (labels
    ((redc (m) ; Reduce to triangular form
       (if (null (cdr m))
         m
        (cons (car m) (mapcar-1 #'cons 0 (redc (mapcar #'cdr (mapcar #'(lambda (r) (mapcar #'- (mapcar-1 #'* (caar m) r)
                                                                                (mapcar-1 #'* (car r) (car m)))) (cdr m)))))) ))
     (rev (m) ; Reverse each row except the last element
       (reverse (mapcar #'(lambda (r) (append (reverse (butlast r)) (last r))) m)) ))
    (catch 'result
      (let ((m1 (redc (rev (redc m)))))
        (reverse (mapcar #'(lambda (r) (let ((pivot (find-if-not #'zerop r))) (if pivot (/ (car (last r)) pivot) (throw 'result 'singular)))) m1)) ))))


import std.stdio, std.math, std.algorithm, std.range, std.numeric,
       std.typecons;

Tuple!(double[],"x", string,"err")
gaussPartial(in double[][] a0, in double[] b0) pure /*nothrow*/
in {
    assert(a0.length == a0[0].length);
    assert(a0.length == b0.length);
    assert(a0.all!(row => row.length == a0[0].length));
} body {
    enum eps = 1e-6;
    immutable m = b0.length;

    // Make augmented matrix.
    //auto a = a0.zip(b0).map!(c => c[0] ~ c[1]).array; // Not mutable.
    auto a = a0.zip(b0).map!(c => [] ~ c[0] ~ c[1]).array;

    // Wikipedia algorithm from Gaussian elimination page,
    // produces row-eschelon form.
    foreach (immutable k; 0 .. a.length) {
        // Find pivot for column k and swap.
        a[k .. m].minPos!((x, y) => x[k] > y[k]).front.swap(a[k]);
        if (a[k][k].abs < eps)
            return typeof(return)(null, "singular");

        // Do for all rows below pivot.
        foreach (immutable i; k + 1 .. m) {
            // Do for all remaining elements in current row.
            a[i][k+1 .. m+1] -= a[k][k+1 .. m+1] * (a[i][k] / a[k][k]);

            a[i][k] = 0; // Fill lower triangular matrix with zeros.
        }
    }

    // End of WP algorithm. Now back substitute to get result.
    auto x = new double[m];
    foreach_reverse (immutable i; 0 .. m)
        x[i] = (a[i][m] - a[i][i+1 .. m].dotProduct(x[i+1 .. m])) / a[i][i];

    return typeof(return)(x, null);
}

void main() {
    // The test case result is correct to this tolerance.
    enum eps = 1e-13;

    // Common RC example. Result computed with rational arithmetic
    // then converted to double, and so should be about as close to
    // correct as double represention allows.
    immutable a = [[1.00, 0.00, 0.00,  0.00,  0.00,   0.00],
                   [1.00, 0.63, 0.39,  0.25,  0.16,   0.10],
                   [1.00, 1.26, 1.58,  1.98,  2.49,   3.13],
                   [1.00, 1.88, 3.55,  6.70, 12.62,  23.80],
                   [1.00, 2.51, 6.32, 15.88, 39.90, 100.28],
                   [1.00, 3.14, 9.87, 31.01, 97.41, 306.02]];
    immutable b = [-0.01, 0.61, 0.91,  0.99,  0.60,   0.02];

    immutable r = gaussPartial(a, b);
    if (!r.err.empty)
        return writeln("Error: ", r.err);
    r.x.writeln;

    immutable result = [-0.01,               1.602790394502114,
                        -1.6132030599055613, 1.2454941213714368,
                        -0.4909897195846576, 0.065760696175232];
    foreach (immutable i, immutable xi; result)
        if (abs(r.x[i] - xi) > eps)
            return writeln("Out of tolerance: ", r.x[i], " ", xi);
}


long real procedure multiply( long real value a, b );
begin
    a * b
end


INTEGER FUNCTION MULTIPLY( A, B );
INTEGER A, B;
BEGIN
    MULTIPLY := A * B;
END;


PROC my_molt(a,b)
-> other statements if needed... here they are not
ENDPROC a*b    -> return value

-> or simplier

PROC molt(a,b) IS a*b

PROC main()
  WriteF('\d\n', my_molt(10,20))
ENDPROC


program GuassianElimination;

// Modified from:
// R. Sureshkumar (10 January 1997)
// Gregory J. McRae (22 October 1997)
// http://web.mit.edu/10.001/Web/Course_Notes/Gauss_Pivoting.c

{$APPTYPE CONSOLE}

{$R *.res}

uses
  System.SysUtils;

type
  TMatrix = class
     private
      _r, _c : integer;
      data : array of TDoubleArray;
      function    getValue(rIndex, cIndex : integer): double;
      procedure   setValue(rIndex, cIndex : integer; value: double);
     public
      constructor Create (r, c : integer);
      destructor  Destroy; override;

      property r : integer read _r;
      property c : integer read _c;
      property value[rIndex, cIndex: integer]: double read getValue write setValue; default;
  end;

constructor TMatrix.Create (r, c : integer);
begin
  inherited Create;
  self.r := r; self.c := c;
  setLength (data, r, c);
end;

destructor TMatrix.Destroy;
begin
  data := nil;
  inherited;
end;

function TMatrix.getValue(rIndex, cIndex: Integer): double;
begin
  Result := data[rIndex-1, cIndex-1]; // 1-based array
end;

procedure TMatrix.setValue(rIndex, cIndex : integer; value: double);
begin
  data[rIndex-1, cIndex-1] := value; // 1-based array
end;

// Solve A x = b
procedure gauss (A, b, x : TMatrix);
var rowx : integer;
    i, j, k, n, m : integer;
    amax, xfac, temp, temp1 : double;
begin
  rowx := 0;  // Keep count of the row interchanges
  n := A.r;
  for k := 1 to n - 1 do
      begin
      amax := abs (A[k,k]);
      m := k;
      // Find the row with largest pivot
      for i := k + 1 to n do
          begin
          xfac := abs (A[i,k]);
          if xfac > amax then
             begin
             amax := xfac;
             m := i;
             end;
          end;

      if m <> k then
         begin  // Row interchanges
         rowx := rowx+1;
         temp1 := b[k,1];
         b[k,1] := b[m,1];
         b[m,1]  := temp1;
         for j := k to n do
             begin
             temp := a[k,j];
             a[k,j] := a[m,j];
             a[m,j] := temp;
             end;
      end;

      for i := k+1 to n do
          begin
          xfac := a[i, k]/a[k, k];
          for j := k+1 to n do
              a[i,j] := a[i,j]-xfac*a[k,j];
          b[i,1] := b[i,1] - xfac*b[k,1]
          end;
      end;

  // Back substitution
  for j := 1 to n do
      begin
      k := n-j + 1;
      x[k,1] := b[k,1];
      for i := k+1 to n do
          begin
          x[k,1] := x[k,1] - a[k,i]*x[i,1];
          end;
  x[k,1] := x[k,1]/a[k,k];
  end;
end;

var A, b, x : TMatrix;

begin
  try
    // Could have been done with simple arrays rather than a specific TMatrix class
    A := TMatrix.Create (4,4);
    // Note ideal but use TMatrix to define the vectors as well
    b := TMatrix.Create (4,1);
    x := TMatrix.Create (4,1);

    A[1,1] := 2; A[1,2] := 1; A[1,3] := 0; A[1,4] := 0;
    A[2,1] := 1; A[2,2] := 1; A[2,3] := 1; A[2,4] := 0;
    A[3,1] := 0; A[3,2] := 1; A[3,3] := 2; A[3,4] := 1;
    A[4,1] := 0; A[3,2] := 0; A[4,3] := 1; A[4,4] := 2;

    b[1,1] := 2; b[2,1] := 1; b[3,1] := 4; b[4,1] := 8;

    gauss (A, b, x);

    writeln (x[1,1]:5:2);
    writeln (x[2,1]:5:2);
    writeln (x[3,1]:5:2);
    writeln (x[4,1]:5:2);

    readln;
  except
    on E: Exception do
      Writeln(E.ClassName, ': ', E.Message);
  end;
end.


multiply: * /`*' is a normal function
multiply: {x * y}


⍝⍝ APL2 'tradfn' (traditional function)
⍝⍝ This syntax works in all dialects including GNU APL and Dyalog.
∇ product ← a multiply b
  product ← a × b
∇

      ⍝⍝ A 'dfn' or 'lambda' (anonymous function)
      multiply ← {⍺×⍵}


to multiply(a as number, b as number)
    return a * b
end


// Gaussian Elimination. Nigel Galloway: February 2nd., 2019
let gelim augM=
  let f=List.length augM
  let fG n (g:bigint list) t=n|>List.map(fun n->List.map2(fun n g->g-n)(List.map(fun n->n*g.[t])n)(List.map(fun g->g*n.[t])g))
  let rec fN i (g::e as l)=
    match i with i when i=f->l|>List.mapi(fun n (g:bigint list)->(g.[f],g.[n]))
                |_->fN (i+1) (fG e g [email protected][g])
  fN 0 augM


10  DEF  FN MULTIPLY(P) =  P(P) * P(P+1)
20  P(1) = 611 : P(2) = 78 : PRINT  FN MULTIPLY(1)


use std
.: multiply <real a, real b> :. -> real {a * b}


/* ARM assembly Raspberry PI  */
/*  program functMul.s   */
/* Constantes    */
.equ STDOUT, 1
.equ WRITE,  4
.equ EXIT,   1

/***********************/
/* Initialized data */
/***********************/
.data
szRetourLigne: .asciz "\n"
szMessResult:  .ascii "Resultat : "      @ message result
sMessValeur:   .fill 12, 1, ' '
                   .asciz "\n"
/***********************
/* No Initialized data */
/***********************/
.bss

.text
.global main
main:
    push {fp,lr}    /* save  2 registers */

    @ function multiply
	mov r0,#8
	mov r1,#50
	bl multiply             @ call function
    ldr r1,iAdrsMessValeur
    bl conversion10S       @ call function with 2 parameter (r0,r1)
    ldr r0,iAdrszMessResult
    bl affichageMess            @ display message

    mov r0, #0                  @ return code

100: /* end of  program */
    mov r7, #EXIT              @ request to exit program
    swi 0                       @ perform the system call
iAdrsMessValeur: .int sMessValeur
iAdrszMessResult: .int szMessResult
/******************************************************************/
/*   Function multiply              */
/******************************************************************/
/* r0 contains value 1 */
/* r1 contains value 2 */
/* r0 return résult   */
multiply:
    mul r0,r1,r0
    bx lr	        /* return function */

/******************************************************************/
/*     display text with size calculation                         */
/******************************************************************/
/* r0 contains the address of the message */
affichageMess:
    push {fp,lr}    			/* save  registres */
    push {r0,r1,r2,r7}    		/* save others registers */
    mov r2,#0   				/* counter length */
1:      	/* loop length calculation */
    ldrb r1,[r0,r2]  			/* read octet start position + index */
    cmp r1,#0       			/* if 0 its over */
    addne r2,r2,#1   			/* else add 1 in the length */
    bne 1b          			/* and loop */
                                /* so here r2 contains the length of the message */
    mov r1,r0        			/* address message in r1 */
    mov r0,#STDOUT      		/* code to write to the standard output Linux */
    mov r7, #WRITE             /* code call system "write" */
    swi #0                      /* call systeme */
    pop {r0,r1,r2,r7}     		/* restaur others registers */
    pop {fp,lr}    				/* restaur des  2 registres */
    bx lr	        			/* return  */

/***************************************************/
/*   conversion register in string décimal signed  */
/***************************************************/
/* r0 contains the register   */
/* r1 contains address of conversion area */
conversion10S:
    push {fp,lr}    /* save registers frame and return */
    push {r0-r5}   /* save other registers  */
    mov r2,r1       /* early storage area */
    mov r5,#'+'     /* default sign is + */
    cmp r0,#0       /* négatif number ? */
    movlt r5,#'-'     /* yes sign is - */
    mvnlt r0,r0       /* and inverse in positive value */
    addlt r0,#1
    mov r4,#10   /* area length */
1: /* conversion loop */
    bl divisionpar10 /* division  */
    add r1,#48        /* add 48 at remainder for conversion ascii */
    strb r1,[r2,r4]  /* store byte area r5 + position r4 */
    sub r4,r4,#1      /* previous position */
    cmp r0,#0
    bne 1b	       /* loop if quotient not equal zéro */
    strb r5,[r2,r4]  /* store sign at current position  */
    subs r4,r4,#1   /* previous position */
    blt  100f         /* if r4 < 0  end  */
    /* else complete area with space */
    mov r3,#' '   /* character space */
2:
    strb r3,[r2,r4]  /* store  byte  */
    subs r4,r4,#1   /* previous position */
    bge 2b        /* loop if r4 greather or equal zero */
100:  /*  standard end of function  */
    pop {r0-r5}   /*restaur others registers */
    pop {fp,lr}   /* restaur des  2 registers frame et return  */
    bx lr

/***************************************************/
/*   division par 10   signé                       */
/* Thanks to http://thinkingeek.com/arm-assembler-raspberry-pi/*
/* and   http://www.hackersdelight.org/            */
/***************************************************/
/* r0 contient le dividende   */
/* r0 retourne le quotient */
/* r1 retourne le reste  */
divisionpar10:
  /* r0 contains the argument to be divided by 10 */
   push {r2-r4}   /* save autres registres  */
   mov r4,r0
   ldr r3, .Ls_magic_number_10 /* r1 <- magic_number */
   smull r1, r2, r3, r0   /* r1 <- Lower32Bits(r1*r0). r2 <- Upper32Bits(r1*r0) */
   mov r2, r2, ASR #2     /* r2 <- r2 >> 2 */
   mov r1, r0, LSR #31    /* r1 <- r0 >> 31 */
   add r0, r2, r1         /* r0 <- r2 + r1 */
   add r2,r0,r0, lsl #2   /* r2 <- r0 * 5 */
   sub r1,r4,r2, lsl #1   /* r1 <- r4 - (r2 * 2)  = r4 - (r0 * 10) */
   pop {r2-r4}
   bx lr                  /* leave function */
   .align 4
.Ls_magic_number_10: .word 0x66666667


LISTEN TO ME VERY CAREFULLY multiply
I NEED YOUR CLOTHES YOUR BOOTS AND YOUR MOTORCYCLE a
I NEED YOUR CLOTHES YOUR BOOTS AND YOUR MOTORCYCLE b
GIVE THESE PEOPLE AIR
HEY CHRISTMAS TREE product
YOU SET US UP @I LIED
GET TO THE CHOPPER product
HERE IS MY INVITATION a
YOU'RE FIRED b
ENOUGH TALK
I'LL BE BACK product
HASTA LA VISTA, BABY


Sub GaussJordan(matrix() As Double,rhs() As Double,ans() As Double)
    Dim As Long n=Ubound(matrix,1)
    Redim ans(0):Redim ans(1 To n)
    Dim As Double b(1 To n,1 To n),r(1 To n)
    For c As Long=1 To n 'take copies
        r(c)=rhs(c)
        For d As Long=1 To n
            b(c,d)=matrix(c,d)
        Next d
    Next c
    #macro pivot(num)
    For p1 As Long  = num To n - 1
        For p2 As Long  = p1 + 1 To n
            If Abs(b(p1,num))<Abs(b(p2,num)) Then
                Swap r(p1),r(p2)
                For g As Long=1 To n
                    Swap b(p1,g),b(p2,g)
                Next g
            End If
        Next p2
    Next p1
    #endmacro

    For k As Long=1 To n-1
        pivot(k)              'full pivoting
        For row As Long =k To n-1
            If b(row+1,k)=0 Then Exit For
            Var f=b(k,k)/b(row+1,k)
            r(row+1)=r(row+1)*f-r(k)
            For g As Long=1 To n
                b((row+1),g)=b((row+1),g)*f-b(k,g)
            Next g
        Next row
    Next k
    'back substitute
    For z As Long=n To 1 Step -1
        ans(z)=r(z)/b(z,z)
        For j As Long = n To z+1 Step -1
            ans(z)=ans(z)-(b(z,j)*ans(j)/b(z,z))
        Next j
    Next    z
End Sub

dim as double a(1 to 6,1 to 6) = { _
		                  {1.00, 0.00, 0.00,  0.00,  0.00, 0.00}, _
		                  {1.00, 0.63, 0.39,  0.25,  0.16, 0.10}, _
		                  {1.00, 1.26, 1.58,  1.98,  2.49, 3.13}, _
		                  {1.00, 1.88, 3.55,  6.70, 12.62, 23.80}, _
		                  {1.00, 2.51, 6.32, 15.88, 39.90, 100.28}, _
		                  {1.00, 3.14, 9.87, 31.01, 97.41, 306.02} _
	                      }

dim as double b(1 to 6) = { -0.01, 0.61, 0.91, 0.99, 0.60, 0.02 }

redim as double result()
GaussJordan(a(),b(),result())

for n as long=lbound(result) to ubound(result)
    print result(n)
next n
sleep


multiply: $[x,y][x*y]

print multiply 3 7

multiply2: function [x,y][
	return x*y
]

print multiply2 3 7


MsgBox % multiply(10,2)

multiply(multiplicand, multiplier) {
  Return (multiplicand * multiplier)
}


#AutoIt Version: 3.2.10.0
$I=11
$J=12
MsgBox(0,"Multiply", $I &" * "& $J &" = " & product($I,$J))
Func product($a,$b)
   Return $a * $b
EndFunc


package require math
package require math::calculus

# gamma(1) and gamma(1.5)

set f 1.0
set f2 [expr {sqrt(acos(-1.))/2.}]

for {set x 1.0} {$x <= 10.0} {set x [expr {$x + 0.5}]} {

    # method 1 - numerical integration, Romberg's method, special
    #            case for an improper integral

    set g1 [math::calculus::romberg  \
                [list apply {{x t} {expr {$t ** ($x-1) * exp(-$t)}}} $x] \
                0 1 -relerror 1e-8]
    set g2 [math::calculus::romberg_infinity \
                [list apply {{x t} {expr {$t ** ($x-1) * exp(-$t)}}} $x] \
                1 Inf -relerror 1e-8]
    set gamma [expr {[lindex $g1 0] + [lindex $g2 0]}]

    # method 2 - library function

    set libgamma [expr {exp([math::ln_Gamma $x])}]

    # method 3 - special forms for integer and half-integer arguments

    if {$x == entier($x)} {
        puts [format {%4.1f %13.6f %13.6f %13.6f} $x $gamma $libgamma $f]
        set f [expr $f * $x]
    } else {
        puts [format {%4.1f %13.6f %13.6f %13.6f} $x $gamma $libgamma $f2]
        set f2 [expr $f2 * $x]
    }
}