fannkuch-redux.fs

// The Computer Language Benchmarks Game
// https://salsa.debian.org/benchmarksgame-team/benchmarksgame/
//
// ported from C# version adding native by Anthony Lloyd
// Use struct tuples and Array.Parallel by Phillip Carter

#nowarn "9"

open Microsoft.FSharp.NativeInterop

[<EntryPoint>]
let main args =

    let run n fact taskSize taskId =
        let p = NativePtr.stackalloc n
        let pp = NativePtr.stackalloc n
        let count = NativePtr.stackalloc n

        let inline firstPermutation idx =
            for i = 0 to n-1 do NativePtr.set p i i
            let mutable idx = idx
            for i = n-1 downto 1 do
                let d = idx/NativePtr.get fact i
                NativePtr.set count i d
                if d<>0 then
                    for j = 0 to i do
                        NativePtr.get p j |> NativePtr.set pp j
                    for j = 0 to i do
                        NativePtr.get pp ((j+d) % (i+1)) |> NativePtr.set p j
                    idx <- idx % NativePtr.get fact i

        let inline nextPermutation() =
            let mutable first = NativePtr.get p 1
            NativePtr.get p 0 |> NativePtr.set p 1
            NativePtr.set p 0 first
            let mutable i = 1
            let mutable c = NativePtr.get count i
            while c>=i do
                NativePtr.set count i 0
                let next = NativePtr.get p 1
                NativePtr.set p 0 next
                for j = 1 to i do NativePtr.get p (j+1) |> NativePtr.set p j
                i <- i+1
                NativePtr.set p i first
                first <- next
                c <- NativePtr.get count i
            NativePtr.set count i (c+1)
            first

        let inline countFlips first =
            if first=0 then 0
            elif NativePtr.get p first=0 then 1
            else
                for i = 0 to n-1 do NativePtr.get p i |> NativePtr.set pp i
                let rec loop flips first =
                    let mutable lo = 1
                    let mutable hi = first-1
                    while lo<hi do
                        let t = NativePtr.get pp lo
                        NativePtr.get pp hi |> NativePtr.set pp lo
                        NativePtr.set pp hi t
                        lo <- lo+1
                        hi <- hi-1
                    let tp = NativePtr.get pp first
                    if NativePtr.get pp tp=0 then flips
                    else
                        NativePtr.set pp first first
                        loop (flips+1) tp
                loop 2 first

        firstPermutation (taskId*taskSize)
        let mutable chksum = countFlips (NativePtr.get p 0)
        let mutable maxflips = chksum
        for i = 1 to taskSize-1 do
            let flips = nextPermutation() |> countFlips
            chksum <- chksum + (1-(i%2)*2) * flips
            if flips>maxflips then maxflips <- flips
        struct(chksum, maxflips)

    let n = if args.Length=0 then 7 else int args.[0]
    use fact = fixed &(Array.zeroCreate (n+1)).[0]
    NativePtr.set fact 0 1
    let mutable factn = 1
    for i = 1 to n do
        factn <- factn * i
        NativePtr.set fact i factn
        
    let struct(chksum, maxFlips) =
        let taskSize = factn / System.Environment.ProcessorCount
        Array.Parallel.init System.Environment.ProcessorCount (fun i -> run n fact taskSize i)
        |> Array.reduce (fun struct(c1,f1) struct(c2,f2) -> struct(c1+c2,max f1 f2))
           
    string chksum+"\nPfannkuchen("+string n+") = "+string maxFlips
    |> stdout.WriteLine

    exit 0