with javascript_semantics
requires("0.8.2") -- (added sq_cmp() builtin that returns nested -1/0/+1 compare() results, just like the existing sq_eq() does for equal().)

integer mx = 4, -- max number of a die side (later set to 6)
        mn = 1  -- min number of a die side (later set to 0)

function possible_dice(integer sides)
    --
    -- construct all non-descending permutes of mn..mx,
    -- ie/eg {1,1,1,1}..{4,4,4,4} with (say), amongst
    --       others, {1,1,2,4} but not {1,1,4,2}.
    --
    sequence die = repeat(mn,sides),    -- (main work area)
             res = {deep_copy(die)}
    while true do
        -- find rightmost incrementable side
        --  ie/eg {1,2,4,4} -> set rdx to 2 (if 1-based indexing)
        integer rdx = rfind(true,sq_lt(die,mx))
        if rdx=0 then exit end if
        -- set that and all later to that incremented
        --  ie/eg {1,2,4,4} -> {1,3,3,3}
        die[rdx..$] = die[rdx]+1
        res = append(res,deep_copy(die))
    end while
    printf(1,"There are %d possible %d..%d %d-sided dice\n",{length(res),mn,mx,sides})
    return res
end function

function Dnn(sequence die)
    -- reconstruct the python die numbering (string)
    -- essentially just treat it as a base-N number.
    integer l = length(die),    -- (sides)
            N = mx-mn+1,        -- (base)
            n = 0               -- (result)
    for k=1 to l do
        n += (die[k]-mn)*power(N,l-k)
    end for
    return sprintf("D%d",n+1)
end function

function cmpd(sequence die1, die2)
    -- compares two die returning -1, 0, or +1 for <, =, >
    integer res = 0
    for i=1 to length(die1) do
        res += sum(sq_cmp(die1[i],die2))
    end for
    return sign(res)
end function

function low_rotation(sequence set)
    integer k = find(min(set),set)
    return set[k..$]&set[1..k-1]
end function

integer rotations
function find_non_trans(sequence dice, integer n=3)
    atom t1 = time()+1
    integer l = length(dice), sk, sk1, c
    sequence set = repeat(1,n), -- (indexes to dice)
             cache = repeat(repeat(-2,l),l),
             res = {}
    while true do
        bool valid = true
        for k=1 to n-1 do
            sk = set[k]
            sk1 = set[k+1]
            c = cache[sk][sk1]
            if c=-2 then
                c = cmpd(dice[sk],dice[sk1])
                cache[sk][sk1] = c
            end if
            if c!=-1 then
                valid = false
                -- force k+1 to be incremented next:
                set[k+2..$] = l
                exit
            end if
        end for
        if valid then
            sk = set[1]
            sk1 = set[$]
            c = cache[sk][sk1]
            if c=-2 then
                c = cmpd(dice[sk],dice[sk1])
                cache[sk][sk1] = c
            end if
            if c=+1 then
                res = append(res,low_rotation(set))
            end if
        end if
        -- find rightmost incrementable die index
        --  ie/eg if l is 35 and set is {1,2,35,35}
        --     -> set rdx to 2 (if 1-based indexing)
        integer rdx = rfind(true,sq_lt(set,l))
        if rdx=0 then exit end if
        -- increment that and reset all later
        --  ie/eg {1,2,35,35} -> {1,3,1,1}
        set[rdx] += 1
        set[rdx+1..$] = 1
        if time()>t1 and platform()!=JS then
            progress("working... (%d/%d)\r",{set[1],l})
            t1 = time()+1
        end if
    end while
    if platform()!=JS then
        progress("")
    end if
    rotations = length(res)
    res = unique(res)
    rotations -= length(res)
    return res
end function

function verbose_cmp(sequence die1, die2)
    -- compares two die returning their relationship of their names as a string
    integer c = cmpd(die1,die2)
    string op = {"<","=",">"}[c+2],
           n1 = Dnn(die1),
           n2 = Dnn(die2)
    return sprintf("%s %s %s",{n1,op,n2})
end function

function verbose_dice_cmp(sequence dice, set)
    sequence c = {}, d1, d2
    for j=1 to length(set)-1 do
        d1 = dice[set[j]]
        d2 = dice[set[j+1]]
        c = append(c,verbose_cmp(d1,d2))
    end for
    d1 = dice[set[1]]
    d2 = dice[set[$]]
    c = append(c,verbose_cmp(d1,d2))
    return join(c,", ")
end function

procedure show_dice(sequence dice, non_trans, integer N)
    integer l = length(non_trans),
            omissions = 0,
            last = 0
    if N then
        printf(1,"\n  Non_transitive length-%d combinations found: %d\n",{N,l+rotations})
    end if
    for i=1 to l do
        object ni = non_trans[i]
        if sequence(ni) then
            if i<5 then
                printf(1,"\n")
                for j=1 to length(ni) do
                    sequence d = dice[ni[j]]
                    printf(1,"    %s:%v\n",{Dnn(d),d})
                end for
                last = i
            else
                omissions += 1
            end if
        end if
    end for
    if omissions then
        printf(1,"    (%d omitted)\n",omissions)
    end if
    if rotations then
        printf(1,"    (%d rotations omitted)\n",rotations)
    end if
    if last then
        printf(1,"\n")
        if mx<=6 and mn=1 then
            printf(1,"  More verbose comparison of last result:\n")
        end if
        printf(1,"   %s\n",{verbose_dice_cmp(dice,non_trans[last])})
        printf(1,"\n  ====\n")
    end if
    printf(1,"\n")
end procedure

atom t0 = time()
sequence dice = possible_dice(4)
for N=3 to 4 do
    show_dice(dice,find_non_trans(dice,N),N)
end for

-- From the numberphile video (Efron's dice):
mx = 6
mn = 0
dice = possible_dice(6)
--show_dice(dice,find_non_trans(dice,4),4)
-- ok, dunno about you but I'm not waiting for power(924,4) permutes...
--      limit to the ones discussed, plus another 4 random ones
--      (hopefully it'll just pick out the right ones...)
printf(1,"\nEfron's dice\n")
dice = {{0,0,4,4,4,4},
        {1,1,1,1,1,1},  -- (rand)
        {1,1,1,5,5,5},
        {1,2,3,4,5,6},  -- (rand)
        {2,2,2,2,6,6},
        {5,5,5,6,6,6},  -- (rand)
        {3,3,3,3,3,3},
        {6,6,6,6,6,6}}  -- (rand)

show_dice(dice,find_non_trans(dice,4),0)

-- and from wp:
mx = 9
mn = 1
dice = possible_dice(6)
printf(1,"\nFrom wp\n")
dice = {{1,1,6,6,8,8},
        {2,2,4,4,9,9},
        {3,3,5,5,7,7}}

show_dice(dice,find_non_trans(dice,3),0)

-- Miwin's dice
printf(1,"Miwin's dice\n")
dice = {{1,2,5,6,7,9},
        {1,3,4,5,8,9},
        {2,3,4,6,7,8}}

show_dice(dice,find_non_trans(dice,3),0)
printf(1,"%s\n\n",elapsed(time()-t0))


import Foundation

precedencegroup ExponentiationGroup {
  higherThan: MultiplicationPrecedence
}

infix operator ** : ExponentiationGroup
infix operator ±

func ±(_ lhs: Double, _ rhs: Double) -> UncertainDouble { UncertainDouble(value: lhs, error: rhs) }

struct UncertainDouble {
  var value: Double
  var error: Double

  static func +(_ lhs: UncertainDouble, _ rhs: UncertainDouble) -> UncertainDouble {
    return UncertainDouble(value: lhs.value + rhs.value, error: pow(pow(lhs.error, 2) + pow(rhs.error, 2), 0.5))
  }

  static func +(_ lhs: UncertainDouble, _ rhs: Double) -> UncertainDouble {
    return UncertainDouble(value: lhs.value + rhs, error: lhs.error)
  }

  static func -(_ lhs: UncertainDouble, _ rhs: UncertainDouble) -> UncertainDouble {
    return UncertainDouble(value: lhs.value - rhs.value, error: pow(pow(lhs.error, 2) + pow(rhs.error, 2), 0.5))
  }

  static func -(_ lhs: UncertainDouble, _ rhs: Double) -> UncertainDouble {
    return UncertainDouble(value: lhs.value - rhs, error: lhs.error)
  }

  static func *(_ lhs: UncertainDouble, _ rhs: UncertainDouble) -> UncertainDouble {
    let val = lhs.value * rhs.value

    return UncertainDouble(
      value: val,
      error: pow(pow(val, 2) * (pow(lhs.error / lhs.value, 2) + pow(rhs.error / rhs.value, 2)), 0.5)
    )
  }

  static func *(_ lhs: UncertainDouble, _ rhs: Double) -> UncertainDouble {
    return UncertainDouble(value: lhs.value * rhs, error: abs(lhs.error * rhs))
  }

  static func /(_ lhs: UncertainDouble, _ rhs: UncertainDouble) -> UncertainDouble {
    let val = lhs.value / rhs.value

    return UncertainDouble(
      value: val,
      error: pow(val, 2) * (pow(lhs.error / lhs.value, 2) + pow(rhs.error / rhs.value, 2))
    )
  }

  static func /(_ lhs: UncertainDouble, _ rhs: Double) -> UncertainDouble {
    return UncertainDouble(value: lhs.value / rhs, error: abs(lhs.error * rhs))
  }

  static func **(_ lhs: UncertainDouble, _ power: Double) -> UncertainDouble {
    let val = pow(lhs.value, power)

    return UncertainDouble(value: val, error: abs((val * power) * (lhs.error / lhs.value)))
  }
}

extension UncertainDouble: CustomStringConvertible {
  public var description: String { "\(value) ± \(error)" }
}

let (x1, y1) = (100 ± 1.1, 50 ± 1.2)
let (x2, y2) = (200 ± 2.2, 100 ± 2.3)

let d = ((x2 - x1) ** 2 + (y2 - y1) ** 2) ** 0.5

print(d)


package require Tcl 8.6
oo::class create RAII-support {
    constructor {} {
	upvar 1 { end } end
	lappend end [self]
	trace add variable end unset [namespace code {my DieNicely}]
    }
    destructor {
	catch {
	    upvar 1 { end } end
	    trace remove variable end unset [namespace code {my DieNicely}]
	}
    }
    method return {{level 1}} {
	incr level
	upvar 1 { end } end
	upvar $level { end } parent
	trace remove variable end unset [namespace code {my DieNicely}]
	lappend parent [self]
	trace add variable parent unset [namespace code {my DieNicely}]
	return -level $level [self]
    }
    # Swallows arguments
    method DieNicely args {tailcall my destroy}
}
oo::class create RAII-class {
    superclass oo::class
    method return args {
	[my new {*}$args] return 2
    }
    method unknown {m args} {
	if {[string is double -strict $m]} {
	    return [tailcall my new $m {*}$args]
	}
	next $m {*}$args
    }
    unexport create unknown
    self method create args {
	set c [next {*}$args]
	oo::define $c superclass {*}[info class superclass $c] RAII-support
	return $c
    }
}
# Makes a convenient scope for limiting RAII lifetimes
proc scope {script} {
    foreach v [info global] {
	if {[array exists ::$v] || [string match { * } $v]} continue
	lappend vars $v
	lappend vals [set ::$v]
    }
    tailcall apply [list $vars [list \
	try $script on ok msg {$msg return}
    ] [uplevel 1 {namespace current}]] {*}$vals
}


from collections import namedtuple
from itertools import permutations, product
from functools import lru_cache

Die = namedtuple('Die', 'name, faces')

@lru_cache(maxsize=None)
def cmpd(die1, die2):
    'compares two die returning 1, -1 or 0 for >, < =='
    # Numbers of times one die wins against the other for all combinations
    # cmp(x, y) is `(x > y) - (y > x)` to return 1, 0, or -1 for numbers
    tot = [0, 0, 0]
    for d1, d2 in product(die1.faces, die2.faces):
        tot[1 + (d1 > d2) - (d2 > d1)] += 1
    win2, _, win1 = tot
    return (win1 > win2) - (win2 > win1)

def is_non_trans(dice):
    "Check if ordering of die in dice is non-transitive returning dice or None"
    check = (all(cmpd(c1, c2) == -1
                 for c1, c2 in zip(dice, dice[1:]))  # Dn < Dn+1
             and cmpd(dice[0], dice[-1]) ==  1)      # But D[0] > D[-1]
    return dice if check else False

def find_non_trans(alldice, n=3):
    return [perm for perm in permutations(alldice, n)
            if is_non_trans(perm)]

def possible_dice(sides, mx):
    print(f"\nAll possible 1..{mx} {sides}-sided dice")
    dice = [Die(f"D{n+1}", faces)
            for n, faces in enumerate(product(range(1, mx+1), repeat=sides))]
    print(f'  Created {len(dice)} dice')
    print('  Remove duplicate with same bag of numbers on different faces')
    found = set()
    filtered = []
    for d in dice:
        count = tuple(sorted(d.faces))
        if count not in found:
            found.add(count)
            filtered.append(d)
    l = len(filtered)
    print(f'   Return {l} filtered dice')
    return filtered

#%% more verbose extra checks
def verbose_cmp(die1, die2):
    'compares two die returning their relationship of their names as a string'
    # Numbers of times one die wins against the other for all combinations
    win1 = sum(d1 > d2 for d1, d2 in product(die1.faces, die2.faces))
    win2 = sum(d2 > d1 for d1, d2 in product(die1.faces, die2.faces))
    n1, n2 = die1.name, die2.name
    return f'{n1} > {n2}' if win1 > win2 else (f'{n1} < {n2}' if win1 < win2 else f'{n1} = {n2}')

def verbose_dice_cmp(dice):
    c = [verbose_cmp(x, y) for x, y in zip(dice, dice[1:])]
    c += [verbose_cmp(dice[0], dice[-1])]
    return ', '.join(c)

#%% Use
if __name__ == '__main__':
    dice = possible_dice(sides=4, mx=4)
    for N in (3, 4):   # length of non-transitive group of dice searched for
        non_trans = find_non_trans(dice, N)
        print(f'\n  Non_transitive length-{N} combinations found: {len(non_trans)}')
        for lst in non_trans:
            print()
            for i, die in enumerate(lst):
                print(f"    {' ' if i else '['}{die}{',' if i < N-1 else ']'}")
        if non_trans:
            print('\n  More verbose comparison of last non_transitive result:')
            print(' ',   verbose_dice_cmp(non_trans[-1]))
        print('\n  ====')


class Approx {
    construct new(nu, sigma) {
        _nu = nu
        _sigma = sigma
    }

    static new(a) {
        if (a is Approx) return Approx.new(a.nu, a.sigma)
        if (a is Num)    return Approx.new(a, 0)
    }

    nu    { _nu }
    sigma { _sigma }

    +(a) {
        if (a is Approx) return Approx.new(_nu + a.nu, (_sigma *_sigma + a.sigma*a.sigma).sqrt)
        if (a is Num)    return Approx.new(_nu + a, _sigma)
    }

    -(a) {
        if (a is Approx) return Approx.new(_nu - a.nu, (_sigma *_sigma + a.sigma*a.sigma).sqrt)
        if (a is Num)    return Approx.new(_nu - a, _sigma)
    }

    *(a) {
        if (a is Approx) {
            var v = _nu * a.nu
            return Approx.new(v, (v*v*_sigma*_sigma/(_nu*_nu) + a.sigma*a.sigma/(a.nu*a.nu)).sqrt)
        }
        if (a is Num) return Approx.new(_nu*a, (a*_sigma).abs)
    }

    /(a) {
        if (a is Approx) {
            var v = _nu / a.nu
            return Approx.new(v, (v*v*_sigma*_sigma/(_nu*_nu) + a.sigma*a.sigma/(a.nu*a.nu)).sqrt)
        }
        if (a is Num) return Approx.new(_nu/a, (a*_sigma).abs)
    }

    pow(d) {
        var v = _nu.pow(d)
        return Approx.new(v, (v*d*_sigma/_nu).abs)
    }

    toString { "%(_nu) ±%(_sigma)" }
}

var x1 = Approx.new(100, 1.1)
var y1 = Approx.new( 50, 1.2)
var x2 = Approx.new(200, 2.2)
var y2 = Approx.new(100, 2.3)
System.print(((x1 - x2).pow(2) + (y1 - y2).pow(2)).pow(0.5))


findNonTrans <- function()
{
  diceSet <- unique(t(apply(expand.grid(1:4, 1:4, 1:4, 1:4), 1, sort))) #By construction, each row is a unique dice.
  winningDice <- function(X, Y) #Recall 'Example 1' in the task.
  {
    comparisonTable <- data.frame(X = rep(X, each = length(X)), Y = rep(Y, times = length(Y)))
    rowWinner <- ifelse(comparisonTable["X"] > comparisonTable["Y"], "X",
                        ifelse(comparisonTable["X"] == comparisonTable["Y"], "-", "Y"))
    netXWins <- sum(rowWinner == "X") - sum(rowWinner == "Y")
    if(netXWins > 0) "X" else if(netXWins == 0) "Draw" else "Y"
  }
  rows <- seq_len(nrow(diceSet)) #Recall that each row of diceSet is a dice.
  XvsAllY <- function(X) sapply(rows, function(i) winningDice(X, diceSet[i, ]))
  winners <- as.data.frame(lapply(rows, function(i) XvsAllY(diceSet[i, ])),
                row.names = paste("Y=Dice", rows), col.names = paste("X=Dice", rows), check.names = FALSE)
  solutionCount <- 0
  for(S in rows)
  {
    beatsS <- which(winners[paste("X=Dice", S)] == "Y") #Finds the indices of all T such that S<T.
    beatsT <- lapply(beatsS, function(X) which(winners[paste("X=Dice", X)] == "Y")) #To begin finding U such that T<U.
    beatenByS <- which(winners[paste("X=Dice", S)] == "X") #Finds the indices of all U such that S>U.
    potentialU <- lapply(beatsT, function(X) intersect(X, beatenByS)) #Combining previous two lines.
    nonEmptyIndices <- lengths(potentialU) != 0 #Most of potentialU is usually empty lists.
    if(any(nonEmptyIndices)) #If any lists in potentialU are non-empty, then their entry is the index of a U with S>U & T<U.
    {
      solutionCount <- solutionCount + 1
      diceUIndex <- potentialU[nonEmptyIndices][[1]] #Assumes that there is only one valid U for this S.
      diceTIndex <- beatsS[nonEmptyIndices][[1]] #Finds the T corresponding to the chosen U.
      cat("Solution", solutionCount, "is:\n")
      output <- rbind(S = diceSet[S,], T = diceSet[diceTIndex,], U = diceSet[diceUIndex,])
      colnames(output) <- paste("Dice", 1:4)
      print(output)
    }
  }
}
findNonTrans()


# 20201225 Raku programming solution

my @dicepool = ^4 xx 4 ;

sub FaceCombs(\N, @dp) { # for brevity, changed to use 0-based dice on input
   my @res = my @found = [];
   for [X] @dp {
      unless @found[ my \key = [+] ( N «**« (N-1…0) ) Z* .sort ] {
         @found[key] = True;
         @res.push: $_ »+» 1
      }
   }
   @res
}

sub infix:<⚖>(@x, @y) { +($_{Less} <=> $_{More}) given (@x X<=> @y).Bag }

sub findIntransitive(\N, \cs) {
   my @res = [];
   race for [X] ^+cs xx N -> @lot {
      my $skip = False;
      for @lot.rotor(2 => -1) {
         { $skip = True and last } unless cs[ @_[0] ] ⚖ cs[ @_[1] ] == -1
      }
      next if $skip;
      if cs[ @lot[0] ] ⚖ cs[ @lot[*-1] ] == 1 { @res.push: [ cs[ @lot ] ] }
   }
   @res
}

say "Number of eligible 4-faced dice : ", +(my \combs = FaceCombs(4,@dicepool));
for 3, 4 {
   my @output = findIntransitive($_, combs);
   say +@output, " ordered lists of $_ non-transitive dice found, namely:";
   .say for @output;
}


import "/sort" for Sort

var fourFaceCombs = Fn.new {
    var res = []
    var found = List.filled(256, false)
    for (i in 1..4) {
        for (j in 1..4) {
            for (k in 1..4) {
                for (l in 1..4) {
                    var c = [i, j, k, l]
                    Sort.insertion(c)
                    var key = 64*(c[0]-1) + 16*(c[1]-1) + 4*(c[2]-1) + (c[3]-1)
                    if (!found[key]) {
                        found[key] = true
                        res.add(c)
                    }
                }
            }
        }
    }
    return res
}

var cmp = Fn.new { |x, y|
    var xw = 0
    var yw = 0
    for (i in 0..3) {
        for (j in 0..3) {
            if (x[i] > y[j]) {
                xw = xw + 1
            } else if (y[j] > x[i]) {
                yw = yw + 1
            }
        }
    }
    return (xw - yw).sign
}

var findIntransitive3 = Fn.new { |cs|
    var c = cs.count
    var res = []
    for (i in 0...c) {
        for (j in 0...c) {
            for (k in 0...c) {
                var first = cmp.call(cs[i], cs[j])
                if (first == -1) {
                    var second = cmp.call(cs[j], cs[k])
                    if (second == -1) {
                        var third  = cmp.call(cs[i], cs[k])
                        if (third == 1) res.add([cs[i], cs[j], cs[k]])
                    }
                }
            }
        }
    }
    return res
}

var findIntransitive4 = Fn.new { |cs|
    var c = cs.count
    var res = []
    for (i in 0...c) {
        for (j in 0...c) {
            for (k in 0...c) {
                for (l in 0...c) {
                    var first  = cmp.call(cs[i], cs[j])
                    if (first == -1) {
                        var second = cmp.call(cs[j], cs[k])
                        if (second == -1) {
                            var third  = cmp.call(cs[k], cs[l])
                            if (third == -1) {
                                var fourth = cmp.call(cs[i], cs[l])
                                if (fourth == 1) res.add([cs[i], cs[j], cs[k], cs[l]])
                            }
                        }
                    }
                }
            }
        }
    }
    return res
}

var combs = fourFaceCombs.call()
System.print("Number of eligible 4-faced dice: %(combs.count)")
var it = findIntransitive3.call(combs)
System.print("\n%(it.count) ordered lists of 3 non-transitive dice found, namely:")
System.print(it.join("\n"))
it = findIntransitive4.call(combs)
System.print("\n%(it.count) ordered lists of 4 non-transitive dice found, namely:")
System.print(it.join("\n"))


F nthroot(a, n)
   V result = a
   V x = a / n
   L abs(result - x) > 10e-15
      x = result
      result = (1.0 / n) * (((n - 1) * x) + (a / pow(x, n - 1)))
   R result

print(nthroot(34.0, 5))
print(nthroot(42.0, 10))
print(nthroot(5.0, 2))


*        Nth root - x**(1/n)       - 29/07/2018
NTHROOT  CSECT
         USING  NTHROOT,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
         BAL    R14,ROOTN          call rootn(x,n)
         LE     F0,XN              xn=rootn(x,n)
         LA     R0,6               decimals=6
         BAL    R14,FORMATF        edit xn
         MVC    PG(13),0(R1)       output xn
         XPRNT  PG,L'PG            print buffer
         L      R13,4(0,R13)       restore previous savearea pointer
         RETURN (14,12),RC=0       restore registers from calling sav
ROOTN    MVC    ZN,=E'0'           zn=0  ----------------------------
         MVC    ZN,N               n
         MVI    ZN,X'46'           zn=unnormalize(n)
         LE     F0,ZN              zn
         AE     F0,=E'0'           normalized
         STE    F0,ZN              zn=normalize(n)
         LE     F6,=E'0'           xm=0
         LE     F0,X               x
         DE     F0,ZN              /zn
         STE    F0,XN              xn=x/zn
WHILEA   LE     F0,XN              xn
         SER    F0,F6              xn-xm
         LPER   F0,F0              abs((xn-xm)
         DE     F0,XN              /xn
         CE     F0,EPSILON         while abs((xn-xm)/xn)>epsilon
         BNH    EWHILEA            ~
         LE     F6,XN                xm=xn
         LE     F0,ZN                zn
         SE     F0,=E'1'             zn-1
         MER    F0,F6                f0=(zn-1)*xm
         L      R2,N                 n
         BCTR   R2,0                 n-1
         LE     F2,=E'1'             xm
POW      MER    F2,F6                *xm
         BCT    R2,POW               f2=xm**(n-1)
         LE     F4,X                 x
         DER    F4,F2                x/xm**(n-1)
         AER    F0,F4                (zn-1)*xm+x/xm**(n-1)
         DE     F0,ZN                /zn
         STE    F0,XN                xn=((zn-1)*xm+x/xm**(n-1))/zn
         B      WHILEA             endwhile
EWHILEA  LE     F0,XN              xn
         BR     R14                return ---------------------------
         COPY   FORMATF            format a float
X        DC     E'2'               x  <== input
N        DC     F'2'               n  <== input
EPSILON  DC     E'1E-6'            imprecision
XN       DS     E                  xn :: output
ZN       DS     E                  zn=float(n)
PG       DC     CL80' '            buffer
         REGEQU
         END    NTHROOT


/* ARM assembly AARCH64 Raspberry PI 3B */
/*  program nroot64.s   */
/* link with gcc. Use C function for display float */

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

/*******************************************/
/* Initialized data                        */
/*******************************************/
.data
szFormat1:         .asciz "Root= %+09.15f\n"
.align 4
qNumberA:          .quad 1024
/*******************************************/
/* UnInitialized data                      */
/*******************************************/
.bss
.align 4
/*******************************************/
/*  code section                           */
/*******************************************/
.text
.global main
main:                                   // entry of program

    /* root 10ieme de 1024  */
    ldr x0,qAdriNumberA                 // number address
    ldr d0,[x0]                         // load number in registre d0
    scvtf d0,d0                         // conversion in float
    mov x0,#10                          // N
    bl nthRoot
    ldr x0,qAdrszFormat1                // format
    bl printf                           // call C function !!!
                                        // Attention register dn lost !!!
    /* square root of 2   */
    fmov d0,2                           // conversion 2 in float register d0
    mov x0,#2                           // N
    bl nthRoot
    ldr x0,qAdrszFormat1                // format
                                        // d0 contains résult
    bl printf                           // call C function !!!

100:                                    // standard end of the program
    mov x0, #0                          // return code
    mov x8, #EXIT                       // request to exit program
    svc 0                               // perform the system call

qAdrszFormat1:           .quad szFormat1
qAdriNumberA:            .quad qNumberA

/******************************************************************/
/*     compute  nth root                                          */
/******************************************************************/
/* x0 contains N   */
/* d0 contains the value                 */
/* x0 return result                      */
nthRoot:
    stp x1,lr,[sp,-16]!            // save  registers
    stp x2,x3,[sp,-16]!            // save  registers
    stp d1,d2,[sp,-16]!            // save float registers
    stp d3,d4,[sp,-16]!            // save float registers
    stp d5,d6,[sp,-16]!            // save float registers
    stp d7,d8,[sp,-16]!            // save float registers
    fmov d6,x0                     //
    scvtf d6,d6                    // N conversion in float double précision (64 bits)
    sub x1,x0,#1                   // N - 1
    fmov d8,x1                     //
    scvtf d4,d8                    //conversion in float double précision
    fmov d2,d0                     // a = A
    fdiv d3,d0,d6                  // b = A/n
    adr x2,dfPrec                  // load précision
    ldr d8,[x2]
1:                                 // begin loop
    fmov d2,d3                     // a <- b
    fmul d5,d3,d4                  // (N-1)*b

    fmov d1,1                      // constante 1 -> float
    mov x2,0                       // loop indice
2:                                 // compute pow (n-1)
    fmul d1,d1,d3                  //
    add x2,x2,1
    cmp x2,x1                      // n -1 ?
    blt 2b                         // no -> loop
    fdiv d7,d0,d1                  // A / b pow (n-1)
    fadd d7,d7,d5                  // + (N-1)*b
    fdiv d3,d7,d6                  // / N -> new b
    fsub d1,d3,d2                  // compute gap
    fabs d1,d1                     // absolute value
    fcmp d1,d8                     // compare float maj FPSCR
    bgt 1b                         // if gap > précision -> loop
    fmov d0,d3                     // end return result in d0
100:
    ldp d7,d8,[sp],16              // restaur  2 float registers
    ldp d5,d6,[sp],16              // restaur  2 float registers
    ldp d3,d4,[sp],16              // restaur  2 float registers
    ldp d1,d2,[sp],16              // restaur  2 float registers
    ldp x2,x3,[sp],16              // restaur  2 registers
    ldp x1,lr,[sp],16              // restaur  2 registers
    ret                            // return to address lr x30
dfPrec:        .double 0f1E-10     // précision
/********************************************************/
/*        File Include fonctions                        */
/********************************************************/
/* for this file see task include a file in language AArch64 assembly */
.include "../includeARM64.inc"


INCLUDE "H6:REALMATH.ACT"

PROC NthRoot(REAL POINTER a,n REAL POINTER res)
  REAL n1,eps,one,tmp1,tmp2,tmp3

  ValR("0.0001",eps)
  IntToReal(1,one)
  RealSub(n,one,n1)

  Sqrt(a,res)            ;res=sqrt(a)
  DO
    Power(res,n,tmp1)    ;tmp=res^n
    RealSub(a,tmp1,tmp2) ;tmp2=a-res^n
    RealAbs(tmp2,tmp1)       ;tmp1=abs(a-res^n)
    IF RealGreaterOrEqual(eps,tmp1) THEN
      RETURN
    FI

    Power(res,n1,tmp1)      ;tmp1=res^(n-1)
    RealDiv(a,tmp1,tmp2)    ;tmp2=a/(res^(n-1))
    RealMult(n1,res,tmp1)   ;tmp1=(n-1)*res
    RealAdd(tmp1,tmp2,tmp3) ;tmp3=((n-1)*res + a/(res^(n-1)))
    RealDiv(tmp3,n,res)     ;res=((n-1)*res + a/(res^(n-1)))/n
  OD
RETURN

PROC Test(CHAR ARRAY sa,sn)
  REAL a,n,res

  ValR(sa,a)
  ValR(sn,n)
  PrintR(n) Print(" root of ")
  PrintR(a) Print(" is ")
  NthRoot(a,n,res)
  PrintRE(res)
RETURN

PROC Main()
  Put(125) PutE() ;clear screen
  MathInit()
  Test("2","2")
  Test("81","4")
  Test("1024","10")
  Test("7","0.5")
  Test("12.34","56.78")
RETURN


with Ada.Text_IO;  use Ada.Text_IO;

procedure Test_Nth_Root is
   generic
      type Real is digits <>;
   function Nth_Root (Value : Real; N : Positive) return Real;

   function Nth_Root (Value : Real; N : Positive) return Real is
      type Index is mod 2;
      X : array (Index) of Real := (Value, Value);
      K : Index := 0;
   begin
      loop
         X (K + 1) := ( (Real (N) - 1.0) * X (K) + Value / X (K) ** (N-1) ) / Real (N);
         exit when X (K + 1) >= X (K);
         K := K + 1;
      end loop;
      return X (K + 1);
   end Nth_Root;

   function Long_Nth_Root is new Nth_Root (Long_Float);
begin
   Put_Line ("1024.0 10th  =" & Long_Float'Image (Long_Nth_Root (1024.0, 10)));
   Put_Line ("  27.0 3rd   =" & Long_Float'Image (Long_Nth_Root (27.0, 3)));
   Put_Line ("   2.0 2nd   =" & Long_Float'Image (Long_Nth_Root (2.0, 2)));
   Put_Line ("5642.0 125th =" & Long_Float'Image (Long_Nth_Root (5642.0, 125)));
end Test_Nth_Root;


REAL default p = 0.001;

PROC nth root = (INT n, LONG REAL a, p)LONG REAL:
(
  [2]LONG REAL x := (a, a/n);

  WHILE ABS(x[2] - x[1]) > p DO
    x := (x[2], ((n-1)*x[2] + a/x[2]**(n-1))/n )
  OD;
  x[2]
);

PRIO ROOT = 8;
OP ROOT = (INT n, LONG REAL a)LONG REAL: nth root(n, a, default p);
OP ROOT = (INT n, INT a)LONG REAL: nth root(n, a, default p);

main:
(
  printf(($2(" "gl)$,
         nth root(10, LONG 7131.5 ** 10, default p),
         nth root(5, 34, default p)));
  printf(($2(" "gl)$,
         10 ROOT ( LONG 7131.5 ** 10 ),
         5 ROOT 34))
)


begin
    % nth root algorithm                                              %
    % returns the nth root of A, A must be > 0                        %
    %         the required precision should be specified in precision %
    long real procedure nthRoot( long real value A
                               ; integer   value n
                               ; long real value precision
                               ) ;
        begin
            long real xk, xd;
            integer   n1;
            n1 := n - 1;
            xk := A / n;
            while begin
                xd := ( ( A / ( xk ** n1 ) ) - xk ) / n;
                xk := xk + xd;
                abs( xd ) > precision
            end do begin end;
            xk
        end nthRoot ;
    % test cases %
    r_format := "A"; r_w := 15; r_d := 6; % set output format %
    write( nthRoot( 7131.5 ** 10, 10, 1'-5 ) );
    write( nthRoot(           64,  6, 1'-5 ) );
end.


/* ARM assembly Raspberry PI  */
/*  program nroot.s   */
/* compile with option -mfpu=vfpv3 -mfloat-abi=hard */
/* link with gcc. Use C function for display float */

/* Constantes               */
.equ EXIT,   1                         @ Linux syscall

/* Initialized data */
.data
szFormat1:         .asciz " %+09.15f\n"
.align 4
iNumberA:          .int 1024

/* UnInitialized data */
.bss
.align 4

/*  code section */
.text
.global main
main:                                   @ entry of program
    push {fp,lr}                        @ saves registers

    /* root 10ieme de 1024  */
    ldr r0,iAdriNumberA                 @ number address
    ldr r0,[r0]
    vmov s0,r0                          @
    vcvt.f64.s32 d0, s0                 @conversion in float single précision (32 bits)
    mov r0,#10                          @ N
    bl nthRoot
    ldr r0,iAdrszFormat1                @ format
    vmov r2,r3,d0
    bl printf                           @ call C function !!!
                                        @ Attention register dn lost !!!
    /* square root of 2   */
    vmov.f64 d1,#2.0                    @ conversion 2 in float register d1
    mov r0,#2                           @ N
    bl nthRoot
    ldr r0,iAdrszFormat1                @ format
    vmov r2,r3,d0
    bl printf                           @ call C function !!!

100:                                    @ standard end of the program
    mov r0, #0                          @ return code
    pop {fp,lr}                         @restaur  registers
    mov r7, #EXIT                       @ request to exit program
    swi 0                               @ perform the system call

iAdrszFormat1:           .int szFormat1
iAdriNumberA:            .int iNumberA

/******************************************************************/
/*     compute  nth root                                          */
/******************************************************************/
/* r0 contains N   */
/* d0 contains the value                 */
/* d0 return result                      */
nthRoot:
    push {r1,r2,lr}                    @ save  registers
    vpush {d1-d8}                         @ save float registers
    FMRX    r1,FPSCR                   @ copy FPSCR into r1
    BIC     r1,r1,#0x00370000          @ clears STRIDE and LEN
    FMXR    FPSCR,r1                   @ copy r1 back into FPSCR

    vmov s2,r0                         @
    vcvt.f64.s32 d6, s2                @ N conversion in float double précision (64 bits)
    sub r1,r0,#1                       @ N - 1
    vmov s8,r1                         @
    vcvt.f64.s32 d4, s8                @conversion in float double précision (64 bits)
    vmov.f64 d2,d0                     @ a = A
    vdiv.F64 d3,d0,d6                  @ b = A/n
    adr r2,dfPrec                      @ load précision
    vldr d8,[r2]
1:                                     @ begin loop
    vmov.f64 d2,d3                     @ a <- b
    vmul.f64 d5,d3,d4                  @ (N-1)*b

    vmov.f64 d1,#1.0                   @ constante 1 -> float
    mov r2,#0                          @ loop indice
2:                                     @ compute pow (n-1)
    vmul.f64 d1,d1,d3                  @
    add r2,#1
    cmp r2,r1                          @ n -1 ?
    blt 2b                             @ no -> loop
    vdiv.f64 d7,d0,d1                  @ A / b pow (n-1)
    vadd.f64 d7,d7,d5                  @ + (N-1)*b
    vdiv.f64 d3,d7,d6                  @ / N -> new b
    vsub.f64 d1,d3,d2                  @ compute gap
    vabs.f64 d1,d1                     @ absolute value
    vcmp.f64 d1,d8                     @ compare float maj FPSCR
    fmstat                             @ transfert FPSCR -> APSR
                                       @ or use VMRS APSR_nzcv, FPSCR
    bgt 1b                             @ if gap > précision -> loop
    vmov.f64 d0,d3                     @ end return result in d0

100:
    vpop {d1-d8}                       @ restaur float registers
    pop {r1,r2,lr}                     @ restaur arm registers
    bx lr
dfPrec:            .double 0f1E-10     @ précision


nthRoot: function [a,n][
    N: to :floating n
    result: a
    x: a / N
    while [0.000000000000001 < abs result-x][
        x: result
        result: (1//n) * add (n-1)*x a/pow x n-1
    ]
    return result
]

print nthRoot 34.0 5
print nthRoot 42.0 10
print nthRoot 5.0 2


;AutoIt Version: 3.2.10.0
$A=4913
$n=3
$x=20
ConsoleWrite ($n& " root of "& $A & " is " &nth_root_it($A,$n,$x))
ConsoleWrite ($n& " root of "& $A & " is " &nth_root_rec($A,$n,$x))

;Iterative
Func nth_root_it($A,$n,$x)
   $x0="0"
   While StringCompare(string($x0),string($x))
      ConsoleWrite ($x&@CRLF)
      $x0=$x
      $x=((($n-1)*$x)+($A/$x^($n-1)))/$n
   WEnd
   Return $x
EndFunc

;Recursive
Func nth_root_rec($A,$n,$x)
   ConsoleWrite ($x&@CRLF)
   If $x==((($n-1)*$x)+($A/$x^($n-1)))/$n Then
      Return $x
   EndIf
   Return nth_root_rec($A,$n,((($n-1)*$x)+($A/$x^($n-1)))/$n)
EndFunc


#!/usr/bin/awk -f
BEGIN {
        # test
	print nthroot(8,3)
	print nthroot(16,2)
	print nthroot(16,4)
	print nthroot(125,3)
	print nthroot(3,3)
	print nthroot(3,2)
}

function nthroot(y,n) {
        eps = 1e-15;   # relative accuracy
        x   = 1;
	do {
		d  = ( y / ( x^(n-1) ) - x ) / n ;
		x += d;
		e = eps*x;   # absolute accuracy
	} while ( d < -e  || d > e )

	return x
}


FUNCTION RootX (tBase AS DOUBLE, tExp AS DOUBLE, diffLimit AS DOUBLE) AS DOUBLE
    DIM tmp1 AS DOUBLE, tmp2 AS DOUBLE
    ' Initial guess:
    tmp1 = tBase / tExp
    DO
        tmp2 = tmp1
        ' 1# tells compiler that "1" is a double, not an integer
        tmp1 = (((tExp - 1#) * tmp2) + (tBase / (tmp2 ^ (tExp - 1#)))) / tExp
    LOOP WHILE (ABS(tmp1 - tmp2) > diffLimit)
    RootX = tmp1
END FUNCTION


PROCEDURE nth
   PARAM N : INTEGER; A, P : REAL
   DIM   TEMP0, TEMP1 : REAL
TEMP0 := A
TEMP1 := A/N
WHILE ( abs(TEMP0 - TEMP1) > P) DO
  TEMP0 := TEMP1
  TEMP1 := (( N - 1.0) * TEMP1 + A / TEMP1 ^ (N - 1.0)) / N
ENDWHILE
PRINT "Root            Number          Precision"
PRINT N, A, P
PRINT "The Root is: ";TEMP1
END


function nth_root(n, a)
    precision = 0.0001

    dim x(2)
    x[0] = a
    x[1] = a /n
    while abs(x[1] - x[0]) > precision
        x[0] = x[1]
        x[1] = ((n -1.0) * x[1] +a / x[1]^(n -1.0)) / n
    end while
    return x[1]
end function

print "  n    5643 ^ 1 / n        nth_root ^ n"
print " --------------------------------------"
for n = 3 to 11 step 2
    tmp = nth_root(n, 5643)
    print " "; n; "    "; tmp; chr(9); (tmp ^ n)
next n
print
for n = 25 to 125 step 25
    tmp = nth_root(n, 5643)
    print n; "    "; tmp; chr(9); (tmp ^ n)
next n


      *FLOAT 64
      @% = &D0D
      PRINT "Cube root of 5 is "; FNroot(3, 5, 0)
      PRINT "125th root of 5643 is "; FNroot(125, 5643, 0)
      END

      DEF FNroot(n%, a, d)
      LOCAL x0, x1 : x0 = a / n% : REM Initial guess
      REPEAT
        x1 = ((n% - 1)*x0 + a/x0^(n%-1)) / n%
        SWAP x0, x1
      UNTIL ABS (x0 - x1) <= d
      = x0


/* Take the nth root of 'a' (a positive real number).
 * 'n' must be an integer.
 * Result will have 'd' digits after the decimal point.
 */
define r(a, n, d) {
    auto e, o, x, y, z

    if (n == 0) return(1)
    if (a == 0) return(0)

    o = scale
    scale = d
    e = 1 / 10 ^ d

    if (n < 0) {
        n = -n
        a = 1 / a
    }

    x = 1
    while (1) {
        y = ((n - 1) * x + a / x ^ (n - 1)) / n
        z = x - y
        if (z < 0) z = -z
        if (z < e) break
        x = y
    }
    scale = o
    return(y)
}


_while_ ← {𝔽⍟𝔾∘𝔽_𝕣_𝔾∘𝔽⍟𝔾𝕩}
Root ← √
Root1 ← ⋆⟜÷˜
Root2 ← {
  n 𝕊 a‿prec:
  1⊑{
    p‿x:
    ⟨
      x
      ((p × n - 1) + a ÷ p ⋆ n - 1) ÷ n
    ⟩
  } _while_ {
    p‿x:
    prec ≤ | p - x
  } ⟨a, ⌊a÷n⟩;
  𝕨 𝕊 𝕩: 𝕨 𝕊 𝕩‿1E¯5
}

•Show 3 Root 5
•Show 3 Root1 5
•Show 3 Root2 5
•Show 3 Root2 5‿1E¯16


( ( root
  =   n a d x0 x1 d2 rnd 10-d
    .   ( rnd       { For 'rounding' rational numbers = keep number of digits within bounds. }
        =   N r
          .   !arg:(?N.?r)
            & div$(!N*!r+1/2.1)*!r^-1
        )
      & !arg:(?n,?a,?d)
      & !a*!n^-1:?x0
      & 10^(-1*!d):?10-d
      &   whl
        ' (   ( rnd$(((!n+-1)*!x0+!a*!x0^(1+-1*!n))*!n^-1.10^!d)
              . !x0
              )
            : (?x0.?x1)
          & (!x0+-1*!x1)^2:~<!10-d   { Exit loop when required precision is reached. }
          )
      & flt$(!x0,!d)      { Convert rational number to floating point representation. }
  )
& ( show
  =   N A precision
    .   !arg:(?N,?A,?precision)
      & out$(str$(!A "^(" !N^-1 ")=" root$(!N,!A,!precision)))
  )
& show$(10,1024,20)
& show$(3,27,20)
& show$(2,2,100)
& show$(125,5642,20)
)


#include <stdio.h>
#include <float.h>

double pow_ (double x, int e) {
    int i;
    double r = 1;
    for (i = 0; i < e; i++) {
        r *= x;
    }
    return r;
}

double root (int n, double x) {
    double d, r = 1;
    if (!x) {
        return 0;
    }
    if (n < 1 || (x < 0 && !(n&1))) {
        return 0.0 / 0.0; /* NaN */
    }
    do {
        d = (x / pow_(r, n - 1) - r) / n;
        r += d;
    }
    while (d >= DBL_EPSILON * 10 || d <= -DBL_EPSILON * 10);
    return r;
}

int main () {
    int n = 15;
    double x = pow_(-3.14159, 15);
    printf("root(%d, %g) = %g\n", n, x, root(n, x));
    return 0;
}


static void Main(string[] args)
{
	Console.WriteLine(NthRoot(81,2,.001));
        Console.WriteLine(NthRoot(1000,3,.001));
        Console.ReadLine();
}

public static double NthRoot(double A,int n,  double p)
{
	double _n= (double) n;
	double[] x = new double[2];
	x[0] = A;
	x[1] = A/_n;
	while(Math.Abs(x[0] -x[1] ) > p)
	{
		x[1] = x[0];
		x[0] = (1/_n)*(((_n-1)*x[1]) + (A/Math.Pow(x[1],_n-1)));

	}
	return x[0];
}


double NthRoot(double m_nValue, double index, double guess, double pc)
   {
       double result = guess;
       double result_next;
       do
       {
           result_next = (1.0/index)*((index-1.0)*result+(m_nValue)/(pow(result,(index-1.0))));
           result = result_next;
           pc--;
       }while(pc>1);
       return result;
   };


(ns test-project-intellij.core
  (:gen-class))

;; define abs & power to avoid needing to bring in the clojure Math library
(defn abs [x]
  " Absolute value"
  (if (< x 0) (- x) x))

(defn power [x n]
  " x to power n, where n = 0, 1, 2, ... "
  (apply * (repeat n x)))

(defn calc-delta [A x n]
  " nth rooth algorithm delta calculation "
  (/ (- (/ A (power x (- n 1))) x) n))

(defn nth-root
  " nth root of algorithm: A = numer, n = root"
  ([A n] (nth-root A n 0.5 1.0))  ; Takes only two arguments A, n and calls version which takes A, n, guess-prev, guess-current
  ([A n guess-prev guess-current] ; version take takes in four arguments (A, n, guess-prev, guess-current)
   (if (< (abs (- guess-prev guess-current)) 1e-6)
     guess-current
     (recur A n guess-current (+ guess-current (calc-delta A guess-current n)))))) ; iterate answer using tail recursion


       IDENTIFICATION DIVISION.
       PROGRAM-ID. Nth-Root.
       AUTHOR.  Bill Gunshannon.
       INSTALLATION.
       DATE-WRITTEN.  4 Feb 2020.
      ************************************************************
      ** Program Abstract:
      **   Compute the Nth Root of a positive real number.
      **
      **   Takes values from console.  If Precision is left
      **   blank defaults to 0.001.
      **
      **   Enter 0 for first value to terminate program.
      ************************************************************

       ENVIRONMENT DIVISION.

       INPUT-OUTPUT SECTION.
       FILE-CONTROL.
            SELECT Root-File ASSIGN TO "Root-File"
                 ORGANIZATION IS LINE SEQUENTIAL.

       DATA DIVISION.

       FILE SECTION.

       FD  Root-File
           DATA RECORD IS Parameters.
       01  Parameters.
           05 Root                       PIC 9(5).
           05 Num                        PIC 9(5)V9(5).
           05 Precision                  PIC 9V9(9).

       WORKING-STORAGE SECTION.

       01  TEMP0                         PIC 9(9)V9(9).
       01  TEMP1                         PIC 9(9)V9(9).
       01  RESULTS.
           05  Field1                        PIC ZZZZZ.ZZZZZ.
           05  FILLER                        PIC X(5).
           05  Field2                        PIC ZZZZ9.
           05  FILLER                        PIC X(14).
           05  Field3                        PIC 9.999999999.

       01  HEADER.
           05  FILLER                        PIC X(72)
               VALUE "   Number           Root           Precision.".

       01  Disp-Root                         PIC ZZZZZ.ZZZZZ.

       PROCEDURE DIVISION.

       Main-Program.
           PERFORM FOREVER

              PERFORM Get-Input
              IF Precision = 0.0
                  THEN MOVE 0.001 to Precision
              END-IF

              PERFORM Compute-Root

              MOVE Root TO Field2
              MOVE Num TO Field1
              MOVE Precision TO Field3
              DISPLAY HEADER
              DISPLAY RESULTS
              DISPLAY " "
              MOVE TEMP1 TO Disp-Root
              DISPLAY "The Root is: " Disp-Root
           END-PERFORM.

       Get-Input.
           DISPLAY "Input Base Number: " WITH NO ADVANCING
           ACCEPT Num
           IF Num EQUALS ZERO
              THEN
                   DISPLAY "Good Bye."
                   STOP RUN
           END-IF
           DISPLAY "Input Root: " WITH NO ADVANCING
           ACCEPT Root
           DISPLAY "Input Desired Precision: " WITH NO ADVANCING
           ACCEPT Precision.

       Compute-Root.
          MOVE Root TO TEMP0
          DIVIDE Num BY Root GIVING TEMP1

          PERFORM UNTIL FUNCTION ABS(TEMP0 - TEMP1)
                                    LESS THAN Precision
               MOVE TEMP1 TO TEMP0
               COMPUTE TEMP1 = (( Root - 1.0) * TEMP1 + Num /
                                        TEMP1 ** (Root - 1.0)) / Root
          END-PERFORM.

       END-PROGRAM.


(defun nth-root (n a &optional (epsilon .0001) (guess (1- n)))
  (assert (and (> n 1) (> a 0)))
  (flet ((next (x)
           (/ (+ (* (1- n) x)
                 (/ a (expt x (1- n))))
              n)))
    (do* ((xi guess xi+1)
          (xi+1 (next xi) (next xi)))
         ((< (abs (- xi+1 xi)) epsilon) xi+1))))


import std.stdio, std.math;

real nthroot(in int n, in real A, in real p=0.001) pure nothrow {
    real[2] x = [A, A / n];
    while (abs(x[1] - x[0]) > p)
        x = [x[1], ((n - 1) * x[1] + A / (x[1] ^^ (n-1))) / n];
    return x[1];
}

void main() {
    writeln(nthroot(10, 7131.5 ^^ 10));
    writeln(nthroot(6, 64));
}


USES
   Math;

function NthRoot(A, Precision: Double; n: Integer): Double;
var
   x_p, X: Double;
begin
   x_p := Sqrt(A);
   while Abs(A - Power(x_p, n)) > Precision do
   begin
      x := (1/n) * (((n-1) * x_p) + (A/(Power(x_p, n - 1))));
      x_p := x;
   end;
   Result := x_p;
end;


def nthroot(n, x) {
  require(n > 1 && x > 0)
  def np := n - 1
  def iter(g) { return (np*g + x/g**np) / n }
  var g1 := x
  var g2 := iter(g1)
  while (!(g1 <=> g2)) {
    g1 := iter(g1)
    g2 := iter(iter(g2))
  }
  return g1
}


func power x n . r .
  r = 1
  for i range n
    r *= x
  .
.
func nth_root x n . r .
  r = 2
  repeat
    call power r n - 1 p
    d = (x / p - r) / n
    r += d
    until abs d < 0.0001
  .
.
call power 3.1416 10 x
call nth_root x 10 r
numfmt 0 4
print r


defmodule RC do
  def nth_root(n, x, precision \\ 1.0e-5) do
    f = fn(prev) -> ((n - 1) * prev + x / :math.pow(prev, (n-1))) / n end
    fixed_point(f, x, precision, f.(x))
  end

  defp fixed_point(_, guess, tolerance, next) when abs(guess - next) < tolerance, do: next
  defp fixed_point(f, _, tolerance, next), do: fixed_point(f, next, tolerance, f.(next))
end

Enum.each([{2, 2}, {4, 81}, {10, 1024}, {1/2, 7}], fn {n, x} ->
  IO.puts "#{n} root of #{x} is #{RC.nth_root(n, x)}"
end)


fixed_point(F, Guess, Tolerance) ->
    fixed_point(F, Guess, Tolerance, F(Guess)).
fixed_point(_, Guess, Tolerance, Next) when abs(Guess - Next) < Tolerance ->
    Next;
fixed_point(F, _, Tolerance, Next) ->
    fixed_point(F, Next, Tolerance, F(Next)).


let nthroot n A =
    let rec f x =
        let m = n - 1.
        let x' = (m * x + A/x**m) / n
        match abs(x' - x) with
        | t when t < abs(x * 1e-9) -> x'
        | _ -> f x'
    f (A / double n)

[<EntryPoint>]
let main args =
    if args.Length <> 2 then
        eprintfn "usage: nthroot n A"
        exit 1
    let (b, n) = System.Double.TryParse(args.[0])
    let (b', A) = System.Double.TryParse(args.[1])
    if (not b) || (not b') then
        eprintfn "error: parameter must be a number"
        exit 1
    printf "%A" (nthroot n A)
    0


USING: kernel locals math math.functions prettyprint ;

:: th-root ( a n -- a^1/n )
    a [
        a over n 1 - ^ /f
          over n 1 - *
        + n /f
        swap over 1e-5 ~ not
    ] loop ;

34 5 th-root .   ! 2.024397458499888
34 5 recip ^ .   ! 2.024397458499888


: th-root { F: a F: n -- a^1/n }
  a
  begin
    a fover n 1e f- f** f/
      fover n 1e f- f*
    f+ n f/
    fswap fover 1e-5 f~
  until ;

34e 5e th-root f.   \ 2.02439745849989
34e 5e 1/f f** f.   \ 2.02439745849989


program NthRootTest
  implicit none

  print *, nthroot(10, 7131.5**10)
  print *, nthroot(5, 34.0)

contains

  function nthroot(n, A, p)
    real :: nthroot
    integer, intent(in)        :: n
    real, intent(in)           :: A
    real, intent(in), optional :: p

    real :: rp, x(2)

    if ( A < 0 ) then
       stop "A < 0"       ! we handle only real positive numbers
    elseif ( A == 0 ) then
       nthroot = 0
       return
    end if

    if ( present(p) ) then
       rp = p
    else
       rp = 0.001
    end if

    x(1) = A
    x(2) = A/n   ! starting "guessed" value...

    do while ( abs(x(2) - x(1)) > rp )
       x(1) = x(2)
       x(2) = ((n-1.0)*x(2) + A/(x(2) ** (n-1.0)))/real(n)
    end do

    nthroot = x(2)

  end function nthroot

end program NthRootTest


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

Function nth_root(n As Integer, number As Double) As Double

    Dim As Double a1 = number / n, a2 , a3

    Do
        a3 = Abs(a2 - a1)
        a2 = ((n -1) * a1 + number / a1 ^ (n -1)) / n
        Swap a1, a2
    Loop Until Abs(a2 - a1) = a3

    Return a1

End Function

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

Dim As UInteger n
Dim As Double tmp

Print
Print "   n    5643 ^ 1 / n     nth_root ^ n"
Print " ------------------------------------"
For n = 3 To 11 Step 2
    tmp = nth_root(n, 5643)
    Print Using " ###    ###.########    ####.########"; n; tmp; tmp ^ n
Next

Print
For n = 25 To 125 Step 25
    tmp = nth_root(n, 5643)
    Print Using " ###    ###.########    ####.########"; n; tmp; tmp ^ n
Next

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


window 1

local fn NthRoot( root as long, a as long, precision as double ) as double
  double x0, x1

  x0 = a : x1 = a /root
  while ( abs( x1 - x0 ) > precision )
    x0 = x1
    x1 = ( ( root -1.0 ) * x1 + a / x1 ^ ( root -1.0 ) ) /root
  wend
end fn = x1

print " 125th Root of 5643 Precision .001",,  using "#.###############";  fn NthRoot( 125, 5642, 0.001   )
print " 125th Root of 5643 Precision .001",,  using "#.###############";  fn NthRoot( 125, 5642, 0.001   )
print " 125th Root of 5643 Precision .00001", using "#.###############";  fn NthRoot( 125, 5642, 0.00001 )
print "  Cube Root of   27 Precision .00001", using "#.###############";  fn NthRoot(   3,   27, 0.00001 )
print "Square Root of    2 Precision .00001", using "#.###############";  fn NthRoot(   2,    2, 0.00001 )
print "Square Root of    2 Precision .00001", using "#.###############";  sqr(2)  // Processor floating point calc deviation
print "  10th Root of 1024 Precision .00001", using "#.###############";  fn NthRoot(  10, 1024, 0.00001 )
print "   5th Root of   34 Precision .00001", using "#.###############";  fn NthRoot(   5,   34, 0.00001 )

HandleEvents


func root(a float64, n int) float64 {
    n1 := n - 1
    n1f, rn := float64(n1), 1/float64(n)
    x, x0 := 1., 0.
    for {
        potx, t2 := 1/x, a
        for b := n1; b > 0; b >>= 1 {
            if b&1 == 1 {
                t2 *= potx
            }
            potx *= potx
        }
        x0, x = x, rn*(n1f*x+t2)
        if math.Abs(x-x0)*1e15 < x {
            break
        }
    }
    return x
}


import static Constants.tolerance
import static java.math.RoundingMode.HALF_UP

def root(double base, double n) {
    double xOld = 1
    double xNew = 0
    while (true) {
        xNew = ((n - 1) * xOld + base/(xOld)**(n - 1))/n
    if ((xNew - xOld).abs() < tolerance) { break }
        xOld = xNew
    }
    (xNew as BigDecimal).setScale(7, HALF_UP)
}


WRITE(Messagebox) NthRoot(5, 34)
WRITE(Messagebox) NthRoot(10, 7131.5^10)

FUNCTION NthRoot(n, A)
   REAL :: prec = 0.001

   IF( (n > 0) * (A > 0) ) THEN
       NthRoot = A / n
       DO i = 1, 1/prec
         x = ((n-1)*NthRoot + A/(NthRoot^(n-1))) / n
         IF( ABS(x - NthRoot) <= prec ) THEN
             RETURN
         ENDIF
         NthRoot = x
       ENDDO
   ENDIF

   WRITE(Messagebox, Name) 'Cannot solve problem for:', prec, n, A
END


procedure main()
   showroot(125,3)
   showroot(27,3)
   showroot(1024,10)
   showroot(39.0625,4)
   showroot(7131.5^10,10)
end

procedure showroot(a,n)
   printf("%i-th root of %i = %i\n",n,a,root(a,n))
end

procedure root(a,n,p) #: finds the n-th root of the number a to precision p
   if n < 0 | type(n) !== "integer" then runerr(101,n)
   if a < 0 then runerr(205,a)
   /p := 1e-14                  # precision
   xn := a / real(n)            # initial guess
   while abs(a - xn^n) > p do
      xn := ((n - 1) * (xi := xn) + a / (xi ^ (n-1))) / real(n)
   return xn
end

link printf


public static double nthroot(int n, double A) {
	return nthroot(n, A, .001);
}
public static double nthroot(int n, double A, double p) {
	if(A < 0) {
		System.err.println("A < 0");// we handle only real positive numbers
		return -1;
	} else if(A == 0) {
		return 0;
	}
	double x_prev = A;
	double x = A / n;  // starting "guessed" value...
	while(Math.abs(x - x_prev) > p) {
		x_prev = x;
		x = ((n - 1.0) * x + A / Math.pow(x, n - 1.0)) / n;
	}
	return x;
}


function nthRoot(num, nArg, precArg) {
  var n = nArg || 2;
  var prec = precArg || 12;

  var x = 1; // Initial guess.
  for (var i=0; i<prec; i++) {
    x = 1/n * ((n-1)*x + (num / Math.pow(x, n-1)));
  }

  return x;
}


# An iterative algorithm for finding: self ^ (1/n) to the given
# absolute precision if "precision" > 0, or to within the precision
# allowed by IEEE 754 64-bit numbers.

# The following implementation handles underflow caused by poor estimates.
def iterative_nth_root(n; precision):
  def abs: if . < 0 then -. else . end;
  def sq: .*.;
  def pow(p): . as $in | reduce range(0;p) as $i (1; . * $in);
    def _iterate: # state: [A, x1, x2, prevdelta]
      .[0] as $A | .[1] as $x1 | .[2] as $x2 | .[3] as $prevdelta
      | ( $x2 | pow(n-1)) as $power
      | if $power <= 2.155094094640383e-309
        then  [$A, $x1, ($x1 + $x2)/2, n] | _iterate
	else (((n-1)*$x2 + ($A/$power))/n) as $x1
	| (($x1 - $x2)|abs) as $delta
        | if (precision == 0 and $delta == $prevdelta and $delta < 1e-15)
             or (precision > 0 and $delta <= precision) or $delta == 0 then $x1
          else [$A, $x2, $x1, $delta] | _iterate
          end
        end
    ;
    if n == 1 then .
    elif . == 0 then 0
    elif . < 0 then error("iterative_nth_root: input \(.) < 0")
    elif n != (n|floor) then error("iterative_nth_root: argument \(n) is not an integer")
    elif n == 0 then error("iterative_nth_root(0): domain error")
    elif n < 0 then 1/iterative_nth_root(-n; precision)
    else [., ., (./n), n, 0]  | _iterate
    end
;


function nthroot(n::Integer, r::Real)
    r < 0 || n == 0 && throw(DomainError())
    n < 0 && return 1 / nthroot(-n, r)
    r > 0 || return 0
    x = r / n
    prevdx = r
    while true
        y = x ^ (n - 1)
        dx = (r - y * x) / (n * y)
        abs(dx) ≥ abs(prevdx) && return x
        x += dx
        prevdx = dx
    end
end

@show nthroot.(-5:2:5, 5.0)
@show nthroot.(-5:2:5, 5.0) - 5.0 .^ (1 ./ (-5:2:5))


// version 1.0.6

fun nthRoot(x: Double, n: Int): Double {
    if (n < 2) throw IllegalArgumentException("n must be more than 1")
    if (x <= 0.0) throw IllegalArgumentException("x must be positive")
    val np = n - 1
    fun iter(g: Double) = (np * g + x / Math.pow(g, np.toDouble())) / n
    var g1 = x
    var g2 = iter(g1)
    while (g1 != g2) {
        g1 = iter(g1)
        g2 = iter(iter(g2))
    }
    return g1
}

fun main(args: Array<String>) {
   val numbers = arrayOf(1728.0 to 3, 1024.0 to 10, 2.0 to 2)
   for (number in numbers)
       println("${number.first} ^ 1/${number.second}\t = ${nthRoot(number.first, number.second)}")
}


{def root
  {def good-enough? {lambda {next guess tol}
    {< {abs {- next guess}} tol} }}
  {def improve {lambda {guess num deg}
    {/ {+ {* {- deg 1} guess}
             {/ num {pow guess {- deg 1}}}} deg} }}
  {def *root {lambda {guess num deg tol}
    {let { {guess guess} {num num} {deg deg} {tol tol}
           {next {improve guess num deg}}
         } {if {good-enough? next guess tol}
            then guess
            else {*root next num deg tol}} }}}
 {lambda {num deg tol}
  {*root 1.0 num deg tol} }}
-> root

{root {pow 2 10} 10 0.1}
-> 2.0473293223683866
{root {pow 2 10} 10 0.01}
-> 2.004632048354822
{root {pow 2 10} 10 0.001}
-> 2.000047868581671


writeln "operator"
writeln( (7131.5 ^ 10) ^/ 10 )
writeln 64 ^/ 6
writeln()

# To make the example from the D language work, we set a low maximum for the number of digits after a decimal point in division.
mode divMaxScale = 7

val .nthroot = f(.n, .A, .p) {
    var .x = [.A, .A / .n]
    while abs(.x[2]-.x[1]) > .p {
        .x = [.x[2], ((.n-1) x .x[2] + .A / (.x[2] ^ (.n-1))) / .n]
    }
    simplify .x[2]
}

writeln "calculation"
writeln .nthroot(10, 7131.5 ^ 10, 0.001)
writeln .nthroot(6, 64, 0.001)


on nthRoot (x, root)
  return power(x, 1.0/root)
end


to about :a :b
  output and [:a - :b < 1e-5] [:a - :b > -1e-5]
end

to root :n :a [:guess :a]
  localmake "next ((:n-1) * :guess + :a / power :guess (:n-1)) / n
  if about :guess :next [output :next]
  output (root :n :a :next)
end

show root 5 34   ; 2.02439745849989


function nroot(root, num)
  return num^(1/root)
end


Flush empty stack
Over 2 copy 2nd as new top (so 2nd now is 3rd)
Over 2,2 repeat Over 2 two times.
Shift 2 send top to 2nd, and 2nd to top (1st) (there is a SHFITBACK to revesre action)
Drop drop top
Number get top if is number, else raise error
Read, read a variable form top.
Functions parameters works with a read too
     Function Root {
             Read a, n%, d as double=1.e-4
      ......
      }
because we can send any type and number if function, interpreter can make conversions if we declare that,
or if it not possible (no conversion done to a numeric variable if a string is in top of stack) we get an error.
Also if we send less values, and we didn't initialize variable before, we get error too.
Here we need to flush stack for other parameters if from an error anyone put more arguments.
(interpreter never count before call a user function, except for calling events by using event object,
so there there is a signature to follow)

n% is double inside.


function answer = nthRoot(number,root)

    format long

    answer = number / root;
    guess = number;

    while not(guess == answer)
       guess = answer;
       answer = (1/root)*( ((root - 1)*guess) + ( number/(guess^(root - 1)) ) );
    end

end


nth_root(a, n) := block(
   [x, y, d, p: fpprec],
   fpprec: p + 10,
   x: bfloat(a),
   eps: 10.0b0^-p,
   y: do (
      d: bfloat((a / x^(n - 1) - x) / n),
      if abs(d) < eps * x then return(x),
      x: x + d
   ),
   fpprec: p,
   bfloat(y)
)$


vardef mnthroot(expr n, A) =
  x0 := A / n;
  m := n - 1;
  forever:
    x1 := (m*x0 + A/(x0 ** m)) / n;
    exitif abs(x1 - x0) < abs(x0 * 0.0001);
    x0 := x1;
  endfor;
  x1
enddef;

primarydef n nthroot A = mnthroot(n, A) enddef;

show 5 nthroot 34;  % 2.0244
show 0.5 nthroot 7; % 49.00528

bye


/*NetRexx program to calculate the  Nth root of  X,  with  DIGS  accuracy. */
class nth_root

  method main(args=String[]) static
    if args.length < 2 then
      do
	say "at least 2 arguments expected"
	exit
      end
    x = args[0]
    root = args[1]
    if args.length > 2 then digs = args[2]

    if root=='' then root=2
    if digs = null, digs = '' then digs=20
    numeric digits digs
    say '     x	= ' x
    say '  root	= ' root
    say 'digits	= ' digs
    say 'answer	= ' root(x,root,digs)

  method root(x,r,digs) static --procedure; parse arg x,R 1 oldR  /*assign 2nd arg-->r and rOrig.  */
    /*this subroutine will use the   */
    /*digits from the calling prog.  */
    /*The default digits is  9.      */
    R = r
    oldR = r
    if r=0 then do
      say
      say '*** error! ***'
      say "a root of zero can't be specified."
      say
      return '[n/a]'
    end

    R=R.abs()                              /*use absolute value of root.    */

    if x<0 & (R//2==0) then do
      say
      say '*** error! ***'
      say "an even root can't be calculated for a" -
      'negative number,'
      say 'the result would be complex.'
      say
      return '[n/a]'
    end

    if x=0 | r=1 then return x/1           /*handle couple of special cases.*/
    Rm1=R-1                                /*just a fast version of  ROOT-1 */
    oldDigs=digs                           /*get the current number of digs.*/
    dm=oldDigs+5                           /*we need a little guard room.   */
    ax=x.abs()                             /*the absolute value of  X.      */
    g=(ax+1)/r**r                          /*take a good stab at 1st guess. */
 --   numeric fuzz 3                         /*fuzz digits for higher roots.  */
    d=5                                    /*start with only five digits.   */
    /*each calc doubles precision.   */

    loop forever

      d=d+d
      if d>dm then d = dm                        /*double the digits, but not>DM. */
      numeric digits d                     /*tell REXX to use   D   digits. */
      old=0                                /*assume some kind of old guess. */

      loop forever
	_=(Rm1*g**R+ax)/R/g**rm1           /*this is the nitty-gritty stuff.*/
	if _=g | _=old then leave          /*computed close to this before? */
	old=g                              /*now, keep calculation for OLD. */
	g=_                                /*set calculation to guesstimate.*/
      end

      if d==dm then leave                  /*found the root for DM digits ? */
    end

    _=g*x.sign()                           /*correct the sign (maybe).      */
    if oldR<0 then return _=1/_            /*root < 0 ?    Reciprocal it is.*/
    numeric digits oldDigs                 /*re-instate the original digits.*/
    return _/1                             /*normalize the number to digs.  */


(define (nth-root n a)
  (let ((x1 a)
	(x2 (div a n)))
    (until (= x1 x2)
      (setq x1 x2
	    x2 (div
		(add
		 (mul x1 (- n 1))
		 (div a (pow x1 (- n 1))))
		n)))
    x2))


import math

proc nthRoot(a: float; n: int): float =
  var n = float(n)
  result = a
  var x = a / n
  while abs(result-x) > 1e-15:
    x = result
    result = (1/n) * (((n-1)*x) + (a / pow(x, n-1)))

echo nthRoot(34.0, 5)
echo nthRoot(42.0, 10)
echo nthRoot(5.0, 2)


class NthRoot {
  function : Main(args : String[]) ~ Nil {
    NthRoot(5, 34, .001)->PrintLine();
  }

  function : NthRoot(n : Int, A: Float, p : Float) ~ Float {
    x := Float->New[2];
    x[0] := A;
    x[1] := A / n;

    while((x[1] - x[0])->Abs() > p) {
      x[0] := x[1];
      x[1] := ((n - 1.0) * x[1] + A / x[1]->Power(n - 1.0)) / n;
    };

    return x[1];
  }
}


let nthroot ~n ~a ?(tol=0.001) () =
   let nf = float n in let nf1 = nf -. 1.0 in
   let rec iter x =
      let x' = (nf1 *. x +. a /. (x ** nf1)) /. nf in
      if tol > abs_float (x -. x') then x' else iter x' in
   iter 1.0
;;

let () =
  Printf.printf "%g\n" (nthroot 10 (7131.5 ** 10.0) ());
  Printf.printf "%g\n" (nthroot 5 34.0 ());
;;


Float method: nthroot(n)
   1.0 doWhile: [ self over n 1 - pow / over - n / tuck + swap 0.0 <> ] ;


declare
  fun {NthRoot NInt A}
     N = {Int.toFloat NInt}

     fun {Next X}
        ( (N-1.0)*X + A / {Pow X N-1.0} ) / N
     end
  in
     {Until Value.'==' Next A/N}
  end

  fun {Until P F X}
     case {F X}
     of NX andthen {P NX X} then X
     [] NX then {Until P F NX}
     end
  end
in
  {Show {NthRoot 2 2.0}}


with javascript_semantics
function pow_(atom x, integer e)
    atom r = 1
    for i=1 to e do
        r *= x
    end for
    return r
end function

function nth_root(atom y, n)
    atom eps = 1e-15,   -- relative accuracy
         x = 1
    while 1 do
--      atom d = ( y / power(x,n-1) - x ) / n
        atom d = ( y / pow_(x,n-1) - x ) / n
        x += d
        atom e = eps*x   -- absolute accuracy
        if d > -e and d < e then exit end if
    end while
    return x
end function

procedure test(sequence yn)
    atom {y,n} = yn
    printf(1,"nth_root(%d,%d) = %.10g, builtin = %.10g\n",{y,n,nth_root(y,n),power(y,1/n)})
end procedure
papply({{1024,10},{27,3},{2,2},{5642,125},{4913,3},{8,3},{16,2},{16,4},{125,3},{1000000000,3},{1000000000,9}},test)


def nthroot
	var n var y
	1e-15 var eps		/# relative accuracy #/
	1 var x
	true
	while
		y x n 1 - power / x - n / var d
		x d + var x
		eps x * var e	/# absolute accuracy #/
		d 0 e - < d e > or
	endwhile
	x
enddef

def printList
	len for get print endfor
enddef

10 1024 3 27 2 2 125 5642 4 16 stklen tolist

len 1 swap 2 3 tolist
for
	var i
	i get swap i 1 + get rot var e var b
	"The " e "th root of " b " is "	b 1 e / power " (" b e nthroot ")" 9 tolist
	printList drop nl
endfor


(load "@lib/math.l")

(de nthRoot (N A)
   (let (X1 A  X2 (*/ A N))
      (until (= X1 X2)
         (setq
            X1 X2
            X2 (*/
               (+
                  (* X1 (dec N))
                  (*/ A 1.0 (pow X1 (* (dec N) 1.0))) )
               N ) ) )
      X2 ) )

(prinl (format (nthRoot 2  2.0) *Scl))
(prinl (format (nthRoot 3 12.3) *Scl))
(prinl (format (nthRoot 4 45.6) *Scl))


/* Finds the N-th root of the number A */
root: procedure (A, N) returns (float);
   declare A float, N fixed binary;
   declare (xi, xip1) float;

   xi = 1; /* An initial guess */
   do forever;
      xip1 = ((n-1)*xi + A/xi**(n-1) ) / n;
      if abs(xip1-xi) < 1e-5 then leave;
      xi = xip1;
   end;
   return (xi);
end root;


#NoTeS: This sample code does not validate inputs
#	Thus, if there are errors the 'scary' red-text
#	error messages will appear.
#
#	This code will not work properly in floating point values of n,
#	and negative values of A.
#
#	Supports negative values of n by reciprocating the root.

$epsilon=1E-10		#Sample Epsilon (Precision)

function power($x,$e){	#As I said in the comment
	$ret=1
	for($i=1;$i -le $e;$i++){
		$ret*=$x
	}
	return $ret
}
function root($y,$n){					#The main Function
	if (0+$n -lt 0){$tmp=-$n} else {$tmp=$n}	#This checks if n is negative.
	$ans=1

	do{
		$d = ($y/(power $ans ($tmp-1)) - $ans)/$tmp
		$ans+=$d
	} while ($d -lt -$epsilon -or $d -gt $epsilon)

	if (0+$n -lt 0){return 1/$ans} else {return $ans}
}

#Sample Inputs
root 625 2
root 2401 4
root 2 -2
root 1.23456789E-20 34
root 9.87654321E20 10	#Quite slow here, I admit...

((root 5 2)+1)/2	#Extra: Computes the golden ratio
((root 5 2)-1)/2


iroot(_, 0, 0) :- !.
iroot(M, N, R) :-
    M > 1,
    (N > 0 ->
        irootpos(M, N, R)
    ;
        N /\ 1 =:= 1,
        NegN is -N, irootpos(M, NegN, R0), R is -R0).

irootpos(N, A, R) :-
    X0 is 1 << (msb(A) div N),  % initial guess is 2^(log2(A) / N)
    newton(N, A, X0, X1),
    iroot_loop(A, X1, N, A, R).

iroot_loop(X1, X2, _, _, X1) :- X1 =< X2, !.
iroot_loop(_, X1, N, A, R) :-
    newton(N, A, X1, X2),
    iroot_loop(X1, X2, N, A, R).

newton(2, A, X0, X1) :- X1 is (X0 + A div X0) >> 1, !.  % fast special case
newton(N, A, X0, X1) :- X1 is ((N - 1)*X0 + A div X0**(N - 1)) div N.


#Def_p=0.001

Procedure.d Nth_root(n.i, A.d, p.d=#Def_p)
  Protected Dim x.d(1)
  x(0)=A: x(1)=A/n
  While Abs(x(1)-x(0))>p
    x(0)=x(1)
    x(1)=((n-1.0)*x(1)+A/Pow(x(1),n-1.0))/n
  Wend
  ProcedureReturn x(1)
EndProcedure

;//////////////////////////////
Debug "125'th root of 5642 is"
Debug Pow(5642,1/125)
Debug "First estimate is:"
Debug Nth_root(125,5642)
Debug "And better:"
Debug Nth_root(125,5642,0.00001)


from decimal import Decimal, getcontext

def nthroot (n, A, precision):
    getcontext().prec = precision

    n = Decimal(n)
    x_0 = A / n #step 1: make a while guess.
    x_1 = 1     #need it to exist before step 2
    while True:
        #step 2:
        x_0, x_1 = x_1, (1 / n)*((n - 1)*x_0 + (A / (x_0 ** (n - 1))))
        if x_0 == x_1:
            return x_1


nthroot <- function(A, n, tol=sqrt(.Machine$double.eps))
{
   ifelse(A < 1, x0 <- A * n, x0 <- A / n)
   repeat
   {
      x1 <- ((n-1)*x0 + A / x0^(n-1))/n
      if(abs(x1 - x0) > tol) x0 <- x1 else break
   }
   x1
}
nthroot(7131.5^10, 10)   # 7131.5
nthroot(7, 0.5)          # 49


#lang racket

(define (nth-root number root (tolerance 0.001))
  (define (acceptable? next current)
    (< (abs (- next current)) tolerance))

  (define (improve current)
    (/ (+ (* (- root 1) current) (/ number (expt current (- root 1)))) root))

  (define (loop current)
    (define next-guess (improve current))
    (if (acceptable? next-guess current)
        next-guess
        (loop next-guess)))
  (loop 1.0))


program nth
#
integer root
real    number, precision
real    temp0, temp1

1 format('Enter the base number: ')
2 format('Enter the desired root: ')
3 format('Enter the desired precision: ')
4 format(F12.6)
5 format(I6)
write(6,1)
read(5,4)number
write(6,2)
read(5,5)root
write(6,3)
read(5,4)precision

temp0 = number
temp1 = number/root

while ( abs(temp0 - temp1) > precision )
   {
      temp0 = temp1
      temp1 = ((root - 1.0) * temp1 + number / temp1 ** (root - 1.0)) / root
   }

6 format('  number      root    precision')
write(6,6)
7 format(f12.6,i6,f12.6)
write (6,7)number,root,precision
8 format('The root is: ',F12.6)
write (6,8)temp1

end


/*REXX program calculates the  Nth root  of  X,  with  DIGS  (decimal digits) accuracy. */
parse arg x root digs .                          /*obtain optional arguments from the CL*/
if    x=='' |    x==","   then    x= 2           /*Not specified?  Then use the default.*/
if root=='' | root==","   then root= 2           /* "       "        "   "   "      "   */
if digs=='' | digs==","   then digs=65           /* "       "        "   "   "      "   */
numeric digits digs                              /*set the  decimal digits  to   DIGS.  */
say '       x = '    x                           /*echo the value of   X.               */
say '    root = '    root                        /*  "   "    "    "   ROOT.            */
say '  digits = '    digs                        /*  "   "    "    "   DIGS.            */
say '  answer = '    root(x, root)               /*show the value of   ANSWER.          */
exit                                             /*stick a fork in it,  we're all done. */
/*──────────────────────────────────────────────────────────────────────────────────────*/
root: procedure;  parse arg x 1 Ox, r 1 Or             /*arg1 ──► x & Ox, 2nd ──► r & Or*/
      if r==''  then r=2                               /*Was root specified?  Assume √. */
      if r=0    then return '[n/a]'                    /*oops-ay!  Can't do zeroth root.*/
      complex= x<0 & R//2==0                           /*will the result be complex?    */
      oDigs=digits()                                   /*get the current number of digs.*/
      if x=0 | r=1  then return x/1                    /*handle couple of special cases.*/
      dm=oDigs+5                                       /*we need a little guard room.   */
      r=abs(r);   x=abs(x)                             /*the absolute values of R and X.*/
      rm=r-1                                           /*just a fast version of  ROOT -1*/
      numeric form                                     /*take a good guess at the root─┐*/
      parse value format(x,2,1,,0) 'E0' with ? 'E' _ . /* ◄────────────────────────────┘*/
      g= (? / r'E'_ % r)  +  (x>1)                     /*kinda uses a crude "logarithm".*/
      d=5                                              /*start with five decimal digits.*/
           do until d==dm;   d=min(d+d,dm)             /*each time,  precision doubles. */
           numeric digits d                            /*tell REXX to use   D   digits. */
           old=-1                                      /*assume some kind of old guess. */
                  do until old=g;   old=g              /*where da rubber meets da road─┐*/
                  g=format((rm*g**r+x)/r/g**rm,, d-2)  /* ◄────── the root computation─┘*/
                  end   /*until old=g*/                /*maybe until the cows come home.*/
           end          /*until d==dm*/                /*and wait for more cows to come.*/

      if g=0        then return 0                      /*in case the jillionth root = 0.*/
      if Or<0       then g=1/g                         /*root < 0 ?   Reciprocal it is! */
      if \complex   then g=g*sign(Ox)                  /*adjust the sign  (maybe).      */
      numeric digits oDigs                             /*reinstate the original digits. */
      return (g/1)  ||  left('j', complex)             /*normalize # to digs, append j ?*/


decimals(12)
see "cube root of 5 is : " + root(3, 5, 0) + nl

func root n, a, d
y = 0 x = a / n
while fabs (x - y) > d
      y = ((n - 1)*x + a/pow(x,(n-1))) / n
      temp = x
      x = y
      y = temp
end
return x


def nthroot(n, a, precision = 1e-5)
  x = Float(a)
  begin
    prev = x
    x = ((n - 1) * prev + a / (prev ** (n - 1))) / n
  end while (prev - x).abs > precision
  x
end

p nthroot(5,34)  # => 2.02439745849989


// 20210212 Rust programming solution

fn nthRoot(n: f64, A: f64) -> f64 {

   let      p  =  1e-9_f64 ;
   let mut x0  =     A / n ;

   loop {
      let mut x1 = ( (n-1.0) * x0 + A / f64::powf(x0, n-1.0) ) / n;
      if (x1-x0).abs() < (x0*p).abs() { return x1 };
      x0 = x1
   }
}

fn main() {
   println!("{}", nthRoot(3. , 8. ));
}


class MATH is
  nthroot(n:INT, a:FLT):FLT
    pre n > 0
  is
    x0 ::= a / n.flt;
    m  ::= n - 1;
    loop
      x1 ::= (m.flt * x0 + a/(x0^(m.flt))) / n.flt;
      if (x1 - x0).abs < (x0 * 1.0e-9).abs then
        return x1;
      end;
      x0 := x1;
    end;
  end;

end;


def nroot(n: Int, a: Double): Double = {
  @tailrec
  def rec(x0: Double) : Double = {
    val x1 = ((n - 1) * x0 + a/math.pow(x0, n-1))/n
    if (x0 <= x1) x0 else rec(x1)
  }

  rec(a)
}


(define (root number degree tolerance)
  (define (good-enough? next guess)
    (< (abs (- next guess)) tolerance))
  (define (improve guess)
    (/ (+ (* (- degree 1) guess) (/ number (expt guess (- degree 1)))) degree))
  (define (*root guess)
    (let ((next (improve guess)))
      (if (good-enough? next guess)
          guess
          (*root next))))
  (*root 1.0))

(display (root (expt 2 10) 10 0.1))
(newline)
(display (root (expt 2 10) 10 0.01))
(newline)
(display (root (expt 2 10) 10 0.001))
(newline)


const func float: nthRoot (in integer: n, in float: a) is func
  result
    var float: x1 is 0.0;
  local
    var float: x0 is 0.0;
  begin
    x0 := a;
    x1 := a / flt(n);
    while abs(x1 - x0) >= abs(x0 * 1.0E-9) do
      x0 := x1;
      x1 := (flt(pred(n)) * x0 + a / x0 ** pred(n)) / flt(n);
    end while;
  end func;


Number extend [
    nthRoot: n [
	|x0 m x1|
	x0 := (self / n) asFloatD.
	m := n - 1.
	[true] whileTrue: [
	    x1 := ( (m * x0) + (self/(x0 raisedTo: m))) / n.
	    ((x1 - x0) abs) < ((x0 * 1e-9) abs)
		ifTrue: [ ^ x1 ].
	    x0 := x1
	]
    ]
].


extension FloatingPoint where Self: ExpressibleByFloatLiteral {
  @inlinable
  public func power(_ e: Int) -> Self {
    var res = Self(1)

    for _ in 0..<e {
      res *= self
    }

    return res
  }

  @inlinable
  public func root(n: Int, epsilon: Self = 2.220446049250313e-16) -> Self {
    var d = Self(0)
    var res = Self(1)

    guard self != 0 else {
      return 0
    }

    guard n >= 1 else {
      return .nan
    }

    repeat {
      d = (self / res.power(n - 1) - res) / Self(n)
      res += d
    } while d >= epsilon * 10 || d <= -epsilon * 10

    return res
  }
}

print(81.root(n: 4))
print(13.root(n: 5))


proc nthroot {n A} {
    expr {pow($A, 1.0/$n)}
}


FUNCTION Nroot (n, a)
    LET precision = .00001

    LET x1 = a
    LET x2 = a / n
    DO WHILE ABS(x2 - x1) > precision
       LET x1 = x2
       LET x2 = ((n - 1) * x2 + a / x2 ^ (n - 1)) / n
    LOOP
    LET Nroot = x2
END FUNCTION

PRINT "   n    5643 ^ 1 / n     nth_root ^ n"
PRINT " ------------------------------------"
FOR n = 3 TO 11 STEP 2
    LET tmp = Nroot(n, 5643)
    PRINT USING "####": n;
    PRINT "    ";
    PRINT USING "###.########": tmp;
    PRINT "    ";
    PRINT USING "####.########": (tmp ^ n)
NEXT n
PRINT
FOR n = 25 TO 125 STEP 25
    LET tmp = Nroot(n, 5643)
    PRINT USING "####": n;
    PRINT "    ";
    PRINT USING "###.########": tmp;
    PRINT "    ";
    PRINT USING "####.########": (tmp ^ n)
NEXT n
END


#import nat
#import flo

nthroot =

-+
   ("n","n-1"). "A". ("x". div\"n" plus/times("n-1","x") div("A",pow("x","n-1")))^== 1.,
   float^~/~& predecessor+-


Private Function nth_root(y As Double, n As Double)
    Dim eps As Double: eps = 0.00000000000001 '-- relative accuracy
    Dim x As Variant: x = 1
    Do While True
        d = (y / x ^ (n - 1) - x) / n
        x = x + d
        e = eps * x '-- absolute accuracy
        If d > -e And d < e Then
            Exit Do
        End If
    Loop
    Debug.Print y; n; x; y ^ (1 / n)
End Function
Public Sub main()
    nth_root 1024, 10
    nth_root 27, 3
    nth_root 2, 2
    nth_root 5642, 125
    nth_root 7, 0.5
    nth_root 4913, 3
    nth_root 8, 3
    nth_root 16, 2
    nth_root 16, 4
    nth_root 125, 3
    nth_root 1000000000, 3
    nth_root 1000000000, 9
End Sub


var nthRoot = Fn.new { |x, n|
    if (n < 2) Fiber.abort("n must be more than 1")
    if (x <= 0) Fiber.abort("x must be positive")
    var np = n - 1
    var iter = Fn.new { |g| (np*g + x/g.pow(np))/n }
    var g1 = x
    var g2 = iter.call(g1)
    while (g1 != g2) {
        g1 = iter.call(g1)
        g2 = iter.call(iter.call(g2))
    }
    return g1
}

var trios = [ [1728, 3, 2], [1024, 10, 1], [2, 2, 5] ]
for (trio in trios) {
    System.print("%(trio[0]) ^ 1/%(trio[1])%(" "*trio[2]) = %(nthRoot.call(trio[0], trio[1]))")
}


func nthRoot(x,a){
	send x^(1/a);
}{a=2};
log(nthRoot(8,3));


include c:\cxpl\stdlib;

func real NRoot(A, N);  \Return the Nth root of A
real A, N;
real X, X0, Y;
int  I;
[X:= 1.0;               \initial guess
repeat  X0:= X;
        Y:= 1.0;
        for I:= 1 to fix(N)-1 do Y:= Y*X0;
        X:= ((N-1.0)*X0 + A/Y) / N;
until   abs(X-X0) < 1.0E-15;            \(until X=X0 doesn't always work)
return X;
];

[Format(5, 15);
RlOut(0, NRoot( 2., 2.));  CrLf(0);
RlOut(0, Power( 2., 0.5)); CrLf(0);     \for comparison
RlOut(0, NRoot(27., 3.));  CrLf(0);
RlOut(0, NRoot(1024.,10.)); CrLf(0);
]


data 10, 1024, 3, 27, 2, 2, 125, 5642, 4, 16, 0, 0

do
    read e, b
    if e = 0 break
    print "The ", e, "th root of ", b, " is ", b^(1/e), " (", nthroot(b, e), ")"
loop

sub nthroot(y, n)
    local eps, x, d, e

    eps = 1e-15     // relative accuracy
    x   = 1
    repeat
        d  = ( y / ( x^(n-1) ) - x ) / n
        x = x + d
        e = eps * x // absolute accuracy

    until(not(d < -e or d > e ))

    return x
end sub


fcn nthroot(nth,a,precision=1.0e-5){
   x:=prev:=a=a.toFloat(); n1:=nth-1;
   do{
      prev=x;
      x=( prev*n1 + a/prev.pow(n1) ) / nth;
   }
   while( not prev.closeTo(x,precision) );
   x
}

nthroot(5,34) : "%.20f".fmt(_).println()  # => 2.02439745849988828041


rawio:	equ	6
	org	100h
	;;;	Initialize RNG from keypresses
	lxi	d,keys
	call	puts
	mvi	b,4	; 4*4 = 16 bytes
rndini:	mvi	c,4
	lxi	h,rnddat
rndin2:	push	b
	push 	h
rndkey:	call	keyin	; Get key
	ana	a
	jz	rndkey
	pop	h
	pop 	b
	xra	m	; XOR into random data
	mov	m,a
	inx	h
	dcr	c
	jnz	rndin2
	dcr	b
	jnz 	rndini
	lxi	d,done
	call	puts
	;;;	Create and shuffle array of numbers
	mvi	a,'1'	; Start at 1
	mvi	b,9	; 9 items
	lxi	h,list
mklst:	mov	m,a	; Store item
	inr	a	; Increment item
	inx	h	; Increment pointer
	dcr	b	; One fewer list
	jnz	mklst
	mov	m,b	; Zero-terminate the list
	lxi	d,list+8
shuf:	call	rande	; Shuffle the list. E = high, L = low
	mov	l,a
	ldax	d	; Load current number
	mov	b,m	; Load number to swap with
	mov	m,a	; Store first number
	mov	a,b	; Store second number
	stax	d
	dcr	e	; Move pointer back
	jnz	shuf	; Keep going until list is shuffled
	lxi	h,0	; Keep score on stack
	push	h
	;;;	Game loop
game:	lxi	d,list	; Print current state
	call	puts
	lxi	d,list
	ldax	d
check:	mov	b,a	; Check if list is sorted (done)
	inx	d
	ldax	d
	ana	a	; Reached end of list?
	jz	win	; Then the list is in order
	cmp	b	; Larger than previous?
	jnc	check	; Then keep going
	lxi	d,prompt
	call	puts	; Ask for a number
	call	getnum
	mov	b,a 	; B = high number
	dcr	b
	mvi	c,0	; C = low number
	mvi	h,listhi
swap:	mov	l,c	; Load high number in D
	mov	d,m
	mov	l,b	; Load high number in E
	mov	e,m
	mov	m,d	; Store low number in high place
	mov	l,c
	mov	m,e	; Store high number in low place
	dcr	b	; Decrement high index
	inr	c	; Increment low index
	mov	a,c	; Low < high?
	cmp	b
	jc	swap	; Then keep swapping
	lxi	d,nl	; Print newline
	call	puts
	pop	h	; Increment score
	inx 	h
	push 	h
	jmp	game
win:	lxi	d,winmsg
	call	puts	; Print win message
	lxi	h,score
	xthl		; Retrieve score and push score output buffer
	lxi	b,-10	; Divisor
digit:	lxi	d,-1	; Quotient
dgdiv:	inx	d	; Find digit
	dad	b
	jc	dgdiv
	mvi	a,'0'+10
	add	l	; Store digit
	pop	h	; Get pointer
	dcx 	h	; Decrement pointer
	mov	m,a	; Write digit to memory
	push	h	; Store pointer
	xchg		; Continue with quotient
	mov	a,h	; Done yet?
	ora	l
	jnz	digit	; If not keep going
	pop	d	; Retrieve pointer
	;;;	Print 0-terminated string
puts:	ldax	d	; Get character
	ana	a	; Is it zero?
	rz		; Then stop
	inx	d	; Otherwise, increment buffer pointer
	push	d	; Save buffer pointer
	mov	e,a	; Print character
	call	io
	pop	d	; Restore buffer pointer
	jmp 	puts	; Next character
	;;;	Read 1-9 key
gnerr:	mvi	e,7
	call	io
getnum:	call	keyin
	ana	a
	jz	getnum	; If no key, wait for one
	cpi	'1'
	jc	gnerr	; Not valid - beep and try again
	cpi	'9'+1
	jnc	gnerr
	push	psw	; Valid - echo
	mov	e,a
	call	io
	pop	psw
	sui	'0'
	ret
keyin:	mvi	e,0FFh	; Read key
io:	mvi	c,rawio	; CP/M raw I/O call
	jmp	5
	;;; 	Random number up to E
rande:	call	rand
	ani	15
	cmp	e
	jnc	rande
	ret
	;;;	RNG
rand:	push	h! lxi h,rnddat! inr m! mov a,m! inx h! xra m! inx h! xra m
	mov	m,a! inx h! add m! mov m,a! rar! dcx h! xra m! dcx h! add m
	mov	m,a! pop h
	ret
prompt:	db	9,' - Reverse how many? ',0
keys:	db	'Please press some keys to seed the RNG...',0
done:	db	'done.'
nl:	db	13,10,0
winmsg:	db	13,10,'You win! Score = ',0
	db	'*****'
score:	db	13,10,0
listhi:	equ	$/256+1
list:	equ	listhi*256
rnddat:	equ	list+16


V data = Array(‘139275486’)
V trials = 0

L data != sorted(data)
   trials++
   V flip = Int(input(‘###2: LIST: '#.' Flip how many?: ’.format(trials, data.join(‘ ’))))
   data.reverse_range(0 .< flip)

print("\nYou took #. attempts to put the digits in order!".format(trials))


PROC KnuthShuffle(BYTE ARRAY tab BYTE size)
  BYTE i,j,tmp

  i=size-1
  WHILE i>0
  DO
    j=Rand(i+1)
    tmp=tab(i)
    tab(i)=tab(j)
    tab(j)=tmp
    i==-1
  OD
RETURN

BYTE FUNC IsSorted(BYTE ARRAY tab BYTE size)
  BYTE i

  FOR i=0 TO size-2
  DO
    IF tab(i)>tab(i+1) THEN
      RETURN (0)
    FI
  OD
RETURN (1)

PROC Swap(BYTE ARRAY tab BYTE size,count)
  BYTE i,j,tmp

  i=0 j=count-1
  WHILE i<j
  DO
    tmp=tab(i)
    tab(i)=tab(j)
    tab(j)=tmp
    i==+1 j==-1
  OD
RETURN

PROC Main()
  DEFINE SIZE="9"
  BYTE ARRAY a(SIZE)
  BYTE i,j,n,tmp
  BYTE LMARGIN=$52,oldLMARGIN

  oldLMARGIN=LMARGIN
  LMARGIN=0 ;remove left margin on the screen
  Put(125) PutE() ;clear the screen

  FOR i=0 TO SIZE-1
  DO
    a(i)=i+1
  OD
  KnuthShuffle(a,SIZE)

  i=0
  DO
    PrintF("%B: ",i)
    FOR j=0 TO SIZE-1
    DO
      PrintB(a(j))
    OD
    IF IsSorted(a,SIZE) THEN
      EXIT
    FI
    PrintF(" How many to flip (2-%B)? ",SIZE)
    n=InputB()
    IF n>=2 AND n<=SIZE THEN
      Swap(a,SIZE,n)
      i==+1
    FI
  OD

  PrintF("%E%EYou solved it in %B moves!",i)

  LMARGIN=oldLMARGIN ;restore left margin on the screen
RETURN


with Ada.Text_Io; use Ada.Text_Io;
with Ada.Integer_Text_Io; use Ada.Integer_Text_Io;
with Ada.Numerics.Discrete_Random;

procedure NumberReverse is

   subtype RandRange is Integer range 1..9;
   type NumArrayType is array (Integer range 1..9) of Integer;

   package RandNumbers is new Ada.Numerics.Discrete_Random(RandRange);
   use RandNumbers;

   G : Generator;

   procedure FillArray (A : in out NumArrayType) is
      Temp : RandRange;
   begin
      A := (others => 0);
      for I in 1..9 loop
         Temp := Random(G);
         while A(Temp) /= 0 loop
            Temp := Random(G);
         end loop;
         A(Temp) := I;
      end loop;
   end FillArray;

   procedure Put(A : in NumArrayType) is
   begin
      for I in 1..9 loop
         Put(A(I), 0);
         Put(" ");
      end loop;
   end Put;

   procedure Prompt (Index : out Integer) is
   begin
      New_Line;
      Put("How many numbers would you like to reverse: ");
      Get(Index);
   end Prompt;

   procedure ReverseArray(Arr : in out NumArrayType;
                          Index : in Integer) is
      Temp : RandRange;
   begin
      for I in 1..Index/2 loop
         Temp := Arr(I);
         Arr(I) := Arr(Index + 1 - I);
         Arr(Index + 1 - I) := Temp;
      end loop;
   end ReverseArray;

   Sorted : constant NumArrayType := (1,2,3,4,5,6,7,8,9);
   Arr    : NumArrayType;
   Index  : Integer;
   Count  : Integer := 0;
begin
   Reset(G);
   loop
      FillArray(Arr);
      exit when Sorted /= Arr;
   end loop;
   loop
      Put(Arr);
      Prompt(Index);
      Count := Count + 1;
      ReverseArray(Arr, Index);
      exit when Sorted = Arr;
   end loop;
   Put(Arr);
   New_Line;
   Put("Congratulations! You win. It took " &
         Integer'Image(Count) & " tries.");
end NumberReverse;


∇numrev;list;in;swaps
    list←{9?9}⍣{⍺≢⍳9}⊢⍬
    swaps←0
read:
    swaps+←1
    in←{⍞←⍵⋄(≢⍵)↓⍞}(⍕list),': swap how many? '
    list←⌽@(⍳⍎in)⊢list
    →(list≢⍳9)/read
    ⎕←(⍕list),': Congratulations!'
    ⎕←'Swaps:',swaps
∇


arr: 1..9

while [arr = sort arr]->
    arr: shuffle arr

score: 0
while [arr <> sort arr][
    prints [arr "-- "]
    digits: to :integer strip input "How many digits to reverse? "
    arr: (reverse slice arr 0 digits-1) ++ slice arr digits (size arr)-1
    score: score + 1
]

print ["Your score:" score]


print '# Number reversal game'

var data, trials = list(1..9), 0

while data == sort data:
    random.shuffle data

while data != sort data:
    trials += 1
    flip = int input '#${trials}: LIST: ${join data} Flip how many?: '
    data[:flip] = reverse data[:flip]

print '\nYou took ${trials} attempts to put digits in order!'


; Submitted by MasterFocus --- http://tiny.cc/iTunis

ScrambledList := CorrectList := "1 2 3 4 5 6 7 8 9" ; Declare two identical correct sequences
While ( ScrambledList = CorrectList )
  Sort, ScrambledList, Random D%A_Space% ; Shuffle one of them inside a While-loop to ensure it's shuffled

Attempts := 0
While ( ScrambledList <> CorrectList ) ; Repeat until the sequence is correct
{
  InputBox, EnteredNumber, Number Reversal Game, Attempts so far: %Attempts%`n`nCurrent sequence: %ScrambledList%`n`nHow many numbers (from the left) should be flipped?, , 400, 200
  If ErrorLevel
    ExitApp ; Exit if user presses ESC or Cancel
  If EnteredNumber is not integer
    Continue ; Discard attempt if entered number is not an integer
  If ( EnteredNumber <= 1 )
    Continue ; Discard attempt if entered number is <= 1
  Attempts++ ; Increase the number of attempts
  ; Reverse the first part of the string and add the second part
  ; The entered number is multiplied by 2 to deal with the spaces
  ScrambledList := Reverse(SubStr(ScrambledList,1,(EnteredNumber*2)-1)) SubStr(ScrambledList,EnteredNumber*2)
}

MsgBox, You took %Attempts% attempts to get the correct sequence. ; Final message

Return

;-------------------

Reverse(Str) ; Auxiliar function (flips a string)
{
  Loop, Parse, Str
    Out := A_LoopField Out
  Return Out
}


BEGIN {
	print "\nWelcome to the number reversal game!\n"

	print "You must put the numbers in order from 1 to 9."
	print "Your only moves are to reverse groups of numbers"
	print "on the left side of the list."

	newgame()
	prompt()
}

# start a new game
function newgame(  i, j, t) {
	# score = number of moves
	score = 0

	# list = list of numbers
	split("123456789", list, "")
	do {
		# Knuth shuffle
		for (i = 9; i > 1; i--) {
			j = int(i * rand()) + 1
			t = list[i]
			list[i] = list[j]
			list[j] = t
		}
	} while (win())
}

# numbers in order?
function win(  i) {
	# check if list[1] == 1, list[2] == 2, ...
	for (i = 1; i <= 9; i++) if (list[i] != i) return 0
	return 1
}

# user prompt
function prompt(  i) {
	printf "\nYour list: "
	for (i = 1; i < 9; i++) printf "%d, ", list[i]
	printf "%d\n", list[9]

	if (win()) {
		print "YOU WIN!"
		printf "Your score is %d moves.\n", score
		printf "Would you like to play again (y/n)? "
		again = 1
	} else {
		printf "How many numbers to reverse? "
	}
}

# user input in $1
{
	if (again) {
		again = 0
		if (tolower(substr($1, 1, 1)) == "y")
			newgame()
		else
			exit
	} else {
		score += 1
		reverse($1)
	}
	prompt()
}

function reverse(right,  left, t) {
	left = 1
	while (right > left) {
		t = list[left]
		list[left] = list[right]
		list[right] = t
		left++
		right--
	}
}

END { print "\n\nBye!" }


PRINT "Given a jumbled list of the numbers 1 to 9,"
PRINT "you must select how many digits from the left to reverse."
PRINT "Your goal is to get the digits in order with 1 on the left and 9 on the right."

RANDOMIZE TIMER

DIM nums(1 TO 9) AS INTEGER
DIM L0 AS INTEGER, n AS INTEGER, flp AS INTEGER, tries AS INTEGER, again AS INTEGER

'initial values
FOR L0 = 1 TO 9
    nums(L0) = L0
NEXT

DO  'shuffle
    FOR L0 = 9 TO 2 STEP -1
        n = INT(RND * (L0)) + 1
        IF n <> L0 THEN SWAP nums(n), nums(L0)
    NEXT
    FOR L0 = 1 TO 8 'make sure it's not in order
        IF nums(L0) > nums(L0 + 1) THEN EXIT DO
    NEXT
LOOP

again = -1
DO
    IF tries < 10 THEN PRINT " ";
    PRINT tries; ":";
    FOR L0 = 1 TO 9
        PRINT nums(L0);
    NEXT

    IF NOT again THEN EXIT DO

    INPUT " -- How many numbers should be flipped"; flp
    IF flp < 0 THEN flp = 0
    IF flp > 9 THEN flp = 0

    FOR L0 = 1 TO (flp \ 2)
        SWAP nums(L0), nums(flp - L0 + 1)
    NEXT

    again = 0
    'check for order
    FOR L0 = 1 TO 8
        IF nums(L0) > nums(L0 + 1) THEN
            again = -1
            EXIT FOR
        END IF
    NEXT

    IF flp > 0 THEN tries = tries + 1
LOOP

PRINT : PRINT "You took "; LTRIM$(RTRIM$(STR$(tries))); " tries to put the digits in order."


print "Dada una lista aleatoria de numeros del 1 al 9,"
print "indica cuantos digitos de la izquierda voltear."
print " El objetivo es obtener los digitos en orden "
print " con el 1 a la izquierda y el 9 a la derecha." + chr(10)

dim nums(10)
dim a(10)
intentos = 0: denuevo = true: colum = 6

#valores iniciales
for i = 1 to 9
	nums[i] = i
next i

do  #barajamos
	for i = 9 to 2 step -1
		n = int(rand * i) + 1
		if n <> i then
			a[i] = nums[i]
			nums[i] = nums[n]
			nums[n] = a[i]
		end if
	next i
	for i = 1 to 8 #nos aseguramos que no estén en orden
		if nums[i] > nums[i + 1] then exit do
	next i
until false

do
	if intentos < 10 then print " ";
	print intentos; ": ";
	for i = 1 to 9
		print nums[i];" ";
	next i

	if not denuevo then exit do

	input "  -- Cuantos volteamos ", volteo
	if volteo < 0 or volteo > 9 then volteo = 0

	for i = 1 to (volteo \ 2)
		a[i] = nums[volteo - i + 1]
		nums[volteo - i + 1] = nums[i]
		nums[i] = a[i]
	next i

	denuevo = false
	#comprobamos el orden
	for i = 1 to 8
		if nums[i] > nums[i + 1] then
			denuevo = true
			exit for
		end if
	next i

	if volteo > 0 then intentos += 1
until false
print chr(10) + chr(10) + "   Necesitaste "; intentos; " intentos."
end


::
::Number Reversal Game Task from Rosetta Code Wiki
::Batch File Implementation
::
::Please do not open this from command prompt.
::Directly Open the Batch File to play...
::

@echo off
setlocal enabledelayedexpansion
title Number Reversal Game

:begin
set score=0

::The ascending list of 9 digits
set list=123456789

::Generating a random set of 9 digits...
set cyc=9
:gen
set /a tmp1=%random%%%%cyc%
set n%cyc%=!list:~%tmp1%,1!
set tmp2=!n%cyc%!
set list=!list:%tmp2%=!
if not %cyc%==2 (
	set /a cyc-=1
	goto :gen
)
set /a n1=%list%

::Display the Game
cls
echo.
echo ***Number Reversal Game***
:loopgame
echo.
echo Current arrangement: %n1%%n2%%n3%%n4%%n5%%n6%%n7%%n8%%n9%
set /p move=How many digits from the left should I reverse?

::Reverse digits according to the player's input
::NOTE: The next command uses the fact that in Batch File,
::The output for the division operation is only the integer part of the quotient.
set /a lim=(%move%+1)/2

set cyc2=1
:reverse
set /a tmp4=%move%-%cyc2%+1
set tmp5=!n%cyc2%!
set n%cyc2%=!n%tmp4%!
set n%tmp4%=%tmp5%
if not %cyc2%==%lim% (
	set /a cyc2+=1
	goto :reverse
)

::Increment the number of moves took by the player
set /a score+=1

::IF already won...
if %n1%%n2%%n3%%n4%%n5%%n6%%n7%%n8%%n9%==123456789 (
	echo.
	echo Set: %n1%%n2%%n3%%n4%%n5%%n6%%n7%%n8%%n9% DONE^^!
	echo You took %score% moves to arrange the numbers in ascending order.
	pause>nul
	exit
) else (
goto :loopgame
)


      DIM list%(8), done%(8), test%(8)
      list%() = 1, 2, 3, 4, 5, 6, 7, 8, 9
      done%() = list%()

      REM Shuffle:
      REPEAT
        FOR i% = 9 TO 2 STEP -1
          SWAP list%(i%-1), list%(RND(i%)-1)
        NEXT
        test%() = list%() - done%()
      UNTIL MOD(test%()) <> 0

      REM Run the game:
      tries% = 0
      REPEAT
        tries% += 1
        FOR i% = 0 TO 8 : PRINT ; list%(i%) " " ; : NEXT
        INPUT ": Reverse how many", n%
        PROCreverse(list%(), n%)
        test%() = list%() - done%()
      UNTIL MOD(test%()) = 0
      PRINT "You took " ; tries% " attempts."
      END

      DEF PROCreverse(a%(), n%)
      IF n% < 2 ENDPROC
      LOCAL i%
      n% -= 1
      FOR i% = 0 TO n% DIV 2
        SWAP a%(i%), a%(n%-i%)
      NEXT
      ENDPROC


sorted = 1.to 9
length = sorted.length
numbers = sorted.shuffle

#Make certain numbers are shuffled
true? numbers == sorted
  { while { sorted == numbers.shuffle! } }

turns = 0

while { numbers != sorted } {
  print "#{numbers} - How many to reverse? "
  num  = g.to_i
  numbers = numbers[0, num - 1].reverse + numbers[num, length]
  turns = turns + 1
}

p numbers
p "It took #{turns} turns to sort numbers."


void number_reversal_game()
{
    printf("Number Reversal Game. Type a number to flip the first n numbers.");
    printf("Win by sorting the numbers in ascending order.\n");
    printf("Anything besides numbers are ignored.\n");
    printf("\t  |1__2__3__4__5__6__7__8__9|\n");
    int list[9] = {1,2,3,4,5,6,7,8,9};
    shuffle_list(list,9);

    int tries=0;
    unsigned int i;
    int input;

    while(!check_array(list, 9))
    {
        ((tries<10) ? printf("Round %d :  ", tries) : printf("Round %d : ", tries));
        for(i=0;i<9;i++)printf("%d  ",list[i]);
        printf("  Gimme that number:");
        while(1)
        {
            //Just keep asking for proper input
            scanf("%d", &input);
            if(input>1&&input<10)
                break;

            printf("\n%d - Please enter a number between 2 and 9:", (int)input);
        }
        tries++;
        do_flip(list, 9, input);
    }
    printf("Hurray! You solved it in %d moves!\n", tries);
}


using System;
using System.Linq;

class Program
{
    static void Main(string[] args)
    {
        var r = new Random();

        var tries = 1;
        var sorted = Enumerable.Range(1, 9).ToList();
        var values = sorted.OrderBy(x => r.Next(-1, 1)).ToList();

        while (Enumerable.SequenceEqual(sorted, values)) {
            values = sorted.OrderBy(x => r.Next(-1, 1)).ToList();
        }

        //values = "1 3 9 2 7 5 4 8 6".Split().Select(x => int.Parse(x)).ToList();

        while (!Enumerable.SequenceEqual(sorted, values))
        {
            Console.Write("# {0}: LIST: {1} - Flip how many? ", tries, String.Join(" ", values));

            values.Reverse(0, int.Parse(Console.ReadLine()));
            tries += 1;
        }

        Console.WriteLine("\nYou took {0} attempts to put the digits in order!", tries - 1);
        Console.ReadLine();
    }
}


void number_reversal_game()
{
	cout << "Number Reversal Game. Type a number to flip the first n numbers.";
	cout << "You win by sorting the numbers in ascending order.";
	cout << "Anything besides numbers are ignored.\n";
	cout << "\t  |1__2__3__4__5__6__7__8__9|\n";
	int list[9] = {1,2,3,4,5,6,7,8,9};
        do
        {
	  shuffle_list(list,9);
        } while(check_array(list, 9));

	int tries=0;
	unsigned int i;
	int input;

	while(!check_array(list, 9))
	{
		cout << "Round " << tries << ((tries<10) ? " :  " : " : ");
		for(i=0;i<9;i++)cout << list[i] << "  ";
		cout << "  Gimme that number:";
		while(1)
		{
			cin >> input;
			if(input>1&&input<10)
				break;

			cout << "\nPlease enter a number between 2 and 9:";
		}
		tries++;
		do_flip(list, 9, input);
	}
	cout << "Hurray! You solved it in %d moves!\n";
}


(defn flip-at [n coll]
  (let [[x y] (split-at n coll)]
    (concat (reverse x) y )))

(def sorted '(1 2 3 4 5 6 7 8 9))  ; i.e. (range 1 10)
(def unsorted? #(not= % sorted))

(loop [unsorted (first (filter unsorted? (iterate shuffle sorted))), steps 0]
  (if (= unsorted sorted)
    (printf "Done! That took you %d steps%n" steps)
    (do
      (println unsorted)
      (printf "Reverse how many? ")
      (flush)
      (let [flipcount (read)]
        (recur (flip-at flipcount unsorted), (inc steps))))))