import java.math.BigInteger
import kotlin.math.sqrt

class BIRef(var value: BigInteger) {
    operator fun minus(b: BIRef): BIRef {
        return BIRef(value - b.value)
    }

    operator fun times(b: BIRef): BIRef {
        return BIRef(value * b.value)
    }

    override fun equals(other: Any?): Boolean {
        if (this === other) return true
        if (javaClass != other?.javaClass) return false

        other as BIRef

        if (value != other.value) return false

        return true
    }

    override fun hashCode(): Int {
        return value.hashCode()
    }

    override fun toString(): String {
        return value.toString()
    }
}

fun f(a: BIRef, b: BIRef, c: Int) {
    val t = a.value
    a.value = b.value
    b.value = b.value * BigInteger.valueOf(c.toLong()) + t
}

fun solvePell(n: Int, a: BIRef, b: BIRef) {
    val x = sqrt(n.toDouble()).toInt()
    var y = x
    var z = 1
    var r = x shl 1
    val e1 = BIRef(BigInteger.ONE)
    val e2 = BIRef(BigInteger.ZERO)
    val f1 = BIRef(BigInteger.ZERO)
    val f2 = BIRef(BigInteger.ONE)
    while (true) {
        y = r * z - y
        z = (n - y * y) / z
        r = (x + y) / z
        f(e1, e2, r)
        f(f1, f2, r)
        a.value = f2.value
        b.value = e2.value
        f(b, a, x)
        if (a * a - BIRef(n.toBigInteger()) * b * b == BIRef(BigInteger.ONE)) {
            return
        }
    }
}

fun main() {
    val x = BIRef(BigInteger.ZERO)
    val y = BIRef(BigInteger.ZERO)
    intArrayOf(61, 109, 181, 277).forEach {
        solvePell(it, x, y)
        println("x^2 - %3d * y^2 = 1 for x = %,27d and y = %,25d".format(it, x.value, y.value))
    }
}


func pentagram(dim=200, sides=5) {
    var pentagram = <<-EOT
    <?xml version="1.0" standalone="no" ?>
    <!DOCTYPE svg PUBLIC "-//W3C//DTD SVG 1.0//EN"
    "http://www.w3.org/TR/2001/PR-SVG-20010719/DTD/svg10.dtd">
    <svg height="#{dim*2}" width="#{dim*2}" style="" xmlns="http://www.w3.org/2000/svg">
    <rect height="100%" width="100%" style="fill:black;" />
    EOT

    func cis(x) {
        cos(x) + sin(x).i
    }

    func pline(q) {
        <<-EOT
        <polyline points="#{[q..., q[0], q[1]].map{|n| '%0.3f' % n }.join(' ')}"
        style="fill:blue; stroke:white; stroke-width:3;"
        transform="translate(#{dim}, #{dim}) rotate(-18)" />
        EOT
    }

    var v = sides.range.map {|k| 0.9 * dim * cis(k * Num.tau / sides) }
    pentagram += pline([v[range(0, v.end, 2)], v[range(1, v.end, 2)]].map{.reals})
    pentagram += '</svg>'

    return pentagram
}

say pentagram()


mx,my = #.scrsize()
xc = mx/2
yc = my/2
mr = #.min(mx,my)/3
#.angle(#.degrees)
#.drawcolor(1,0,0)
#.drawsize(10)
> r, mr..0,-1
  #.drawline(xc,yc-r,xc,yc-r)
  > a, 54..630,144
    #.drawline(r*#.cos(a)+xc,r*#.sin(a)+yc)
  <
  #.drawcolor(1,1,0)
  #.drawsize(1)
<


package require Tk 8.6   	;# lmap is new in Tcl/Tk 8.6

set pi [expr 4*atan(1)]

pack [canvas .c] -expand yes -fill both     ;# create the canvas

update          ;# draw everything so the dimensions are accurate

set w [winfo width .c]          ;# calculate appropriate dimensions
set h [winfo height .c]
set r [expr {min($w,$h) * 0.45}]

set points [lmap n {0 1 2 3 4 5} {
    set n [expr {$n * 2}]
    set y [expr {sin($pi * 2 * $n / 5) * $r + $h / 2}]
    set x [expr {cos($pi * 2 * $n / 5) * $r + $w / 2}]
    list $x $y
}]
set points [concat {*}$points]  ;# flatten the list

puts [.c create line $points]

;# a fun reader exercise is to make the shape respond to mouse events,
;# or animate it!


FindInstance[x^2 - 61 y^2 == 1, {x, y}, PositiveIntegers]
FindInstance[x^2 - 109 y^2 == 1, {x, y}, PositiveIntegers]
FindInstance[x^2 - 181 y^2 == 1, {x, y}, PositiveIntegers]
FindInstance[x^2 - 277 y^2 == 1, {x, y}, PositiveIntegers]


import math, strformat
import bignum

func solvePell(n: int): (Int, Int) =
  let x = newInt(sqrt(n.toFloat).int)
  var (y, z, r) = (x, newInt(1), x shl 1)
  var (e1, e2) = (newInt(1), newInt(0))
  var (f1, f2) = (newInt(0), newInt(1))

  while true:
    y = r * z - y
    z = (n - y * y) div z
    r = (x + y) div z

    (e1, e2) = (e2, e1 + e2 * r)
    (f1, f2) = (f2, f1 + f2 * r)

    let (a, b) = (f2 * x + e2, f2)
    if a * a - n * b * b == 1:
      return (a, b)

for n in [61, 109, 181, 277]:
  let (x, y) = solvePell(n)
  echo &"x² - {n:3} * y² = 1 for (x, y) = ({x:>21}, {y:>19})"


program Pell_console;
uses SysUtils,
     uIntX; // uIntX is a unit in the library IntXLib4Pascal.
            // uIntX.TIntX is an arbitrarily large integer.

// For the given n: if there are non-trivial solutions of x^2 - n*y^2 = 1
//   in non-negative integers (x,y), return the smallest.
// Else return the trivial solution (x,y) = (1,0).
procedure SolvePell( n : integer; out x, y : uIntX.TIntX);
var
  m, a, c, d : integer;
  p, q, p_next, q_next, p_prev, q_prev : uIntX.TIntX;
  evenNrSteps : boolean;
begin
  if (n >= 0) then m := Trunc( Sqrt( 1.0*n + 0.5)) // or use Rosetta Code Isqrt
              else m := 0;
  if n <= m*m then begin    // if n is not a positive non-square
    x := 1;  y := 0;  exit; // return a trivial solution
  end;
  c := m;  d := 1;
  p := 1;  q := 0;
  p_prev := 0;  q_prev := 1;
  a := m;
  evenNrSteps := true;
  repeat
    // Get the next convergent p/q in the continued fraction for sqrt(n)
    p_next := a*p + p_prev;
    q_next := a*q + q_prev;
    p_prev := p;  p := p_next;
    q_prev := q;  q := q_next;
    // Get the next term a in the continued fraction for sqrt(n)
    Assert((n - c*c) mod d = 0); // optional sanity check
    d := (n - c*c) div d;
    a := (m + c) div d;
    c := a*d - c;
    evenNrSteps := not evenNrSteps;
  until (c = m) and (d = 1);
{
  If the first return to (c,d) = (m,1) occurs after an even number of steps,
    then p^2 - n*q^2 = 1, and there is no solution to x^2 - n*y^2 = -1.
  Else p^2 - n*q^2 = -1, and to get a solution to x^2 - n*y^2 = 1 we can
    either continue until we return to (c,d) = (m,1) for the second time,
    or use the short cut below.
}
  if evenNrSteps then begin
    x := p;  y := q;
  end
  else begin
    x := 2*p*p + 1;  y := 2*p*q
  end;
end;

// For the given n: show the Pell solution on the console.
procedure ShowPellSolution( n : integer);
var
  x, y : uIntX.TIntX;
  lineOut : string;
begin
  SolvePell( n, x, y);
  lineOut := SysUtils.Format( 'n = %d --> (', [n]);
  lineOut := lineOut + x.ToString + ', ' + y.ToString + ')';
  WriteLn( lineOut);
end;

// Main routine
begin
    ShowPellSolution( 61);
    ShowPellSolution( 109);
    ShowPellSolution( 181);
    ShowPellSolution( 277);
end.


Sub pentagram()
    With ActiveSheet.Shapes.AddShape(msoShape5pointStar, 10, 10, 400, 400)
        .Fill.ForeColor.RGB = RGB(255, 0, 0)
        .Line.Weight = 3
        .Line.ForeColor.RGB = RGB(0, 0, 255)
    End With
End Sub


import "graphics" for Canvas, Color, Point
import "dome" for Window

class Game {
    static init() {
        Window.title = "Pentagram"
        var width = 640
        var height = 640
        Window.resize(width, height)
        Canvas.resize(width, height)
        Canvas.cls(Color.white)
        var col = Color.hex("#6495ed") // cornflower blue
        for (i in 1..240) pentagram(320, 320, i, col)
        for (i in 241..250) pentagram(320, 320, i, Color.black)
    }

    static update() {}

    static draw(alpha) {}

    static pentagram(x, y, r, col) {
        var points = List.filled(5, null)
        for (i in 0..4) {
            var angle = 2*Num.pi*i/5 - Num.pi/2
            points[i] = Point.new(x + r*angle.cos, y + r*angle.sin)
        }
        var prev = points[0]
        for (i in 1..5) {
            var index = (i * 2) % 5
            var curr = points[index]
            Canvas.line(prev.x, prev.y, curr.x, curr.y, col)
            prev = curr
        }
    }
}


with javascript_semantics

include mpfr.e

procedure fun(mpz a,b,t, integer c)
-- {a,b} = {b,c*b+a}  (and t gets trashed)
    mpz_set(t,a)
    mpz_set(a,b)
    mpz_mul_si(b,b,c)
    mpz_add(b,b,t)
end procedure

function SolvePell(integer n)
integer x = floor(sqrt(n)), y = x, z = 1, r = x*2
mpz e1 = mpz_init(1), e2 = mpz_init(),
    f1 = mpz_init(),  f2 = mpz_init(1),
    t = mpz_init(0),   u = mpz_init(),
    a = mpz_init(1),   b = mpz_init(0)
    if x*x!=n then
        while mpz_cmp_si(t,1)!=0 do
            y = r*z - y
            z = floor((n-y*y)/z)
            r = floor((x+y)/z)
            fun(e1,e2,t,r)          -- {e1,e2} = {e2,r*e2+e1}
            fun(f1,f2,t,r)          -- {f1,f2} = {f2,r*r2+f1}
            mpz_set(a,f2)
            mpz_set(b,e2)
            fun(b,a,t,x)            -- {b,a} = {f2,x*f2+e2}
            mpz_mul(t,a,a)
            mpz_mul_si(u,b,n)
            mpz_mul(u,u,b)
            mpz_sub(t,t,u)          -- t = a^2-n*b^2
        end while
    end if
    return {a, b}
end function

function split_into_chunks(string x, integer one, rest)
    sequence res = {x[1..one]}
    x = x[one+1..$]
    integer l = length(x)
    while l do
        integer k = min(l,rest)
        res = append(res,x[1..k])
        x = x[k+1..$]
        l -= k
    end while
    return join(res,"\n"&repeat(' ',29))&"\n"&repeat(' ',17)
end function

sequence ns = {4, 61, 109, 181, 277, 8941}
for i=1 to length(ns) do
    integer n = ns[i]
    mpz {x, y} = SolvePell(n)
    string xs = mpz_get_str(x,comma_fill:=true),
           ys = mpz_get_str(y,comma_fill:=true)
    if length(xs)>97 then
        xs = split_into_chunks(xs,98,96)
        ys = split_into_chunks(ys,99,96)
    end if
    printf(1,"x^2 - %3d*y^2 = 1 for x = %27s and y = %25s\n", {n, xs, ys})
end for


proc    FillArea(X, Y, C0, C);  \Replace area colored C0 with color C
int     X, Y,   \starting coordinate for flood fill algorithm
        C0, C;  \initial color, and color to replace it with
def     S=8000; \size of queue (must be an even number)
int     Q(S),   \queue (FIFO)
        F, E;   \fill and empty indexes

        proc    EnQ(X, Y);      \Enqueue coordinate
        int     X, Y;
        [Q(F):= X;
        F:= F+1;
        Q(F):= Y;
        F:= F+1;
        if F >= S then F:= 0;
        ];      \EnQ

        proc    DeQ;            \Dequeue coordinate
        [X:= Q(E);
        E:= E+1;
        Y:= Q(E);
        E:= E+1;
        if E >= S then E:= 0;
        ];      \DeQ

[if C0 = C then return;
F:= 0;  E:= 0;
EnQ(X, Y);
while E # F do
        [DeQ;
        if ReadPix(X, Y) = C0 then
                [Point(X, Y, C);
                EnQ(X+1, Y);    \enqueue adjacent pixels
                EnQ(X-1, Y);
                EnQ(X, Y+1);
                EnQ(X, Y-1);
                ];
        ];
];      \FillArea

def     Size = 200.;
def     Pi = 3.141592654;
def     Deg144 = 4.*Pi/5.;
int     X, Y, N;
[SetVid($12);           \set 640x480x4 VGA graphics
for Y:= 0 to 480-1 do   \fill screen
        [Move(0, Y);  Line(640-1, Y, $F\white\)];
for N:= 0 to 5 do       \draw pentagram
        [X:= fix(Size*Sin(float(N)*Deg144));
         Y:= fix(Size*Cos(float(N)*Deg144));
         if N = 0 then Move(X+320, 240-Y)
                  else Line(X+320, 240-Y, 4\red\);
        ];
FillArea(0, 0, $F, 1);  \replace white (F) with blue (1)
]


const DIM=200, SIDES=5, A=360/SIDES, R=DIM.toFloat();
vs:=[0.0..360-A,A].apply("toRad");  // angles of vertices
#<<<
0'|<?xml version="1.0" standalone="no" ?>
<!DOCTYPE svg PUBLIC "-//W3C//DTD SVG 1.0//EN"
"http://www.w3.org/TR/2001/PR-SVG-20010719/DTD/svg10.dtd">
<svg height="%d" width="%d" style="" xmlns="http://www.w3.org/2000/svg">
<rect height="100%" width="100%" style="fill:bisque;" />|
#<<<
.fmt(DIM*2, DIM*2).println();

var vertices=vs.pump(List,fcn(a){ R.toRectangular(a) }); //( (x,y), (x,y)...
SIDES.pump(String,pline).println();  // the line pairs that draw the pentagram

fcn pline(n){ a:=(n + 2)%SIDES; // (n,a) are the endpoints of the right leg
   pts:=String("\"", ("% 0.3f,% 0.3f "*2), "\" "); // two points
   vs:='wrap(){ T(n,a).pump(List,vertices.get).flatten() }; //(x,y, x,y)
   String(
     (0'|<polyline points=| + pts).fmt(vs().xplode()),
      0'|style="fill:seashell; stroke:blue; stroke-width:3;" |,
      0'|transform="translate(%d,%d) rotate(-18)"|.fmt(DIM,DIM),
      " />\n"
   );
}
println("</svg>");


% Find the square root as a continued fraction

cf_sqrt(N, Sz, [A0, Frac]) :-
    A0 is floor(sqrt(N)),
    (A0*A0 =:= N ->
        Sz = 0, Frac = []
    ;
        cf_sqrt(N, A0, A0, 0, 1, 0, [], Sz, Frac)).

cf_sqrt(N, A, A0, M0, D0, Sz0, L, Sz, R) :-
    M1 is D0*A0 - M0,
    D1 is (N - M1*M1) div D0,
    A1 is (A + M1) div D1,
    (A1 =:= 2*A ->
        succ(Sz0, Sz), revtl([A1|L], R, R)
    ;
        succ(Sz0, Sz1), cf_sqrt(N, A, A1, M1, D1, Sz1, [A1|L], Sz, R)).

revtl([], Z, Z).
revtl([A|As], Bs, Z) :- revtl(As, [A|Bs], Z).

% evaluate an infinite continued fraction as a lazy list of convergents.
%
convergents([A0, As], Lz) :-
    lazy_list(next_convergent, eval_state(1, 0, A0, 1, As), Lz).

next_convergent(eval_state(P0, Q0, P1, Q1, [Term|Ts]), eval_state(P1, Q1, P2, Q2, Ts), R) :-
    P2 is Term*P1 + P0,
    Q2 is Term*Q1 + Q0,
    R is P1 rdiv Q1.

% solve Pell's equation
%
pell(N, X, Y) :-
    cf_sqrt(N, _, D), convergents(D, Rs),
    once((member(R, Rs), ratio(R, P, Q), P*P - N*Q*Q =:= 1)),
    pell_seq(N, P, Q, X, Y).

ratio(N, N, 1) :- integer(N).
ratio(P rdiv Q, P, Q).

pell_seq(_, X, Y, X, Y).
pell_seq(N, X0, Y0, X2, Y2) :-
    pell_seq(N, X0, Y0, X1, Y1),
    X2 is X0*X1 + N*Y0*Y1,
    Y2 is X0*Y1 + Y0*X1.


import math

def solvePell(n):
    x = int(math.sqrt(n))
    y, z, r = x, 1, x << 1
    e1, e2 = 1, 0
    f1, f2 = 0, 1
    while True:
        y = r * z - y
        z = (n - y * y) // z
        r = (x + y) // z

        e1, e2 = e2, e1 + e2 * r
        f1, f2 = f2, f1 + f2 * r

        a, b = f2 * x + e2, f2
        if a * a - n * b * b == 1:
            return a, b

for n in [61, 109, 181, 277]:
    x, y = solvePell(n)
    print("x^2 - %3d * y^2 = 1 for x = %27d and y = %25d" % (n, x, y))


/*REXX program to solve Pell's equation for the smallest solution of positive integers. */
numeric digits 2200                              /*ensure enough decimal digs for answer*/
parse arg $                                      /*obtain optional arguments from the CL*/
if $=='' | $==","  then $= 61 109 181 277        /*Not specified?  Then use the defaults*/
d= 28                                            /*used for aligning the output numbers.*/
       do j=1  for words($);    #= word($, j)    /*process all the numbers in the list. */
       parse value   pells(#)   with   x  y      /*extract the two values of  X  and  Y.*/
       cx= comma(x);       Lcx= length(cx);           cy=  comma(y);       Lcy= length(cy)
       say 'x^2 -'right(#, max(4, length(#)))    "* y^2 == 1" ,
                    ' when x='right(cx, max(d, Lcx))     "  and y="right(cy, max(d, Lcy))
       end   /*j*/
exit 0                                           /*stick a fork in it,  we're all done. */
/*──────────────────────────────────────────────────────────────────────────────────────*/
comma: parse arg ?;  do jc=length(?)-3  to 1  by -3; ?= insert(',', ?, jc); end;  return ?
floor: procedure; parse arg x;  _= x % 1;          return  _   -    (x < 0)   *   (x \= _)
/*──────────────────────────────────────────────────────────────────────────────────────*/
iSqrt: procedure; parse arg x;  r= 0;     q= 1;           do  while q<=x;  q= q * 4;   end
         do  while q>1; q= q%4; _= x-r-q; r= r%2; if _>=0  then do; x= _; r= r+q; end; end
       return r                                  /*R:  is the integer square root of X. */
/*──────────────────────────────────────────────────────────────────────────────────────*/
pells: procedure; parse arg n; x= iSqrt(n);  y=x /*obtain arg;  obtain integer sqrt of N*/
       parse value  1 0   with   e1 e2  1  f2 f1 /*assign values for: E1, E2, and F2, F1*/
       z= 1;        r= x + x
                                         do  until ( (e2 + x*f2)**2  -  n*f2*f2)  ==  1
                                         y= r*z  -  y;     z= floor( (n - y*y) / z)
                                                           r= floor( (x + y  ) / z)
                                         parse value  e2   r*e2  +  e1     with     e1  e2
                                         parse value  f2   r*f2  +  f1     with     f1  f2
                                         end   /*until*/
       return e2  +  x * f2     f2


def solve_pell(n)
  x = Integer.sqrt(n)
  y = x
  z = 1
  r = 2*x
  e1, e2 = 1, 0
  f1, f2 = 0, 1

  loop do
    y = r*z - y
    z = (n - y*y) / z
    r = (x + y) / z
    e1, e2 = e2, r*e2 + e1
    f1, f2 = f2, r*f2 + f1
    a,  b  = e2 + x*f2, f2
    break a, b if a*a - n*b*b == 1
  end
end

[61, 109, 181, 277].each {|n| puts "x*x - %3s*y*y = 1 for x = %-21s and y = %s" % [n, *solve_pell(n)]}


use num_bigint::{ToBigInt, BigInt};
use num_traits::{Zero, One};
//use std::mem::replace in the loop if you want this to be more efficient

fn main() {
    test(61u64);
    test(109u64);
    test(181u64);
    test(277u64);
}

struct Pair {
    v1: BigInt,
    v2: BigInt,
}

impl Pair {
    pub fn make_pair(a: &BigInt, b: &BigInt) -> Pair {
        Pair {
            v1: a.clone(),
            v2: b.clone(),
        }
    }

}

fn solve_pell(n: u64) -> Pair{
    let x: BigInt = ((n as f64).sqrt()).to_bigint().unwrap();
    if x.clone() * x.clone() == n.to_bigint().unwrap() {
        Pair::make_pair(&One::one(), &Zero::zero())
    } else {
        let mut y: BigInt = x.clone();
        let mut z: BigInt = One::one();
        let mut r: BigInt = ( &z + &z) * x.clone();
        let mut e: Pair = Pair::make_pair(&One::one(), &Zero::zero());
        let mut f: Pair = Pair::make_pair(&Zero::zero() ,&One::one());
        let mut a: BigInt = Zero::zero();
        let mut b: BigInt = Zero::zero();
        while &a * &a - n * &b * &b != One::one() {
            //println!("{}  {}  {}", y, z, r);
            y = &r * &z - &y;
            z = (n - &y * &y) / &z;
            r = (&x + &y) / &z;

            e = Pair::make_pair(&e.v2, &(&r * &e.v2 + &e.v1));
            f = Pair::make_pair(&f.v2, &(&r * &f.v2 + &f.v1));
            a = &e.v2 + &x * &f.v2;
            b = f.v2.clone();
        }
        let pa = &a;
        let pb = &b;
        Pair::make_pair(&pa.clone(), &pb.clone())
    }
}

fn test(n: u64) {
    let r: Pair = solve_pell(n);
    println!("x^2 - {} * y^2 = 1 for x = {} and y = {}", n, r.v1, r.v2);
}


def pellFermat(n: Int): (BigInt,BigInt) = {
  import scala.math.{sqrt, floor}

  val x = BigInt(floor(sqrt(n)).toInt)

  var i = 0

  // Use the Continued Fractions method
  def converge(y:BigInt, z:BigInt, r:BigInt, e1:BigInt, e2:BigInt, f1:BigInt, f2:BigInt ) : (BigInt,BigInt) = {

    val a = f2 * x + e2
    val b = f2

    if (a * a - n * b * b == 1) {
      return (a, b)
    }

    val yh = r * z - y
    val zh = (n - yh * yh) / z
    val rh = (x + yh) / zh

    converge(yh,zh,rh,e2,e1 + e2 * rh,f2,f1 + f2 * rh)
  }

  converge(x,BigInt("1"),x << 1,BigInt("1"),BigInt("0"),BigInt("0"),BigInt("1"))
}

val nums = List(61,109,181,277)
val solutions = nums.map{pellFermat(_)}

{
  println("For Pell's Equation, x\u00b2 - ny\u00b2 = 1\n")
  (nums zip solutions).foreach{ case (n, (x,y)) => println(s"n = $n, x = $x, y = $y")}
}


func solvePell<T: BinaryInteger>(n: T, _ a: inout T, _ b: inout T) {
  func swap(_ a: inout T, _ b: inout T, mul by: T) {
    (a, b) = (b, b * by + a)
  }

  let x = T(Double(n).squareRoot())
  var y = x
  var z = T(1)
  var r = x << 1
  var e1 = T(1)
  var e2 = T(0)
  var f1 = T(0)
  var f2 = T(1)

  while true {
    y = r * z - y
    z = (n - y * y) / z
    r = (x + y) / z

    swap(&e1, &e2, mul: r)
    swap(&f1, &f2, mul: r)

    (a, b) = (f2, e2)

    swap(&b, &a, mul: x)

    if a * a - n * b * b == 1 {
      return
    }
  }
}

var x = BigInt(0)
var y = BigInt(0)

for n in [61, 109, 181, 277] {
  solvePell(n: BigInt(n), &x, &y)

  print("x\u{00b2} - \(n)y\u{00b2} = 1 for x = \(x) and y = \(y)")
}


Imports System.Numerics

Module Module1
    Sub Fun(ByRef a As BigInteger, ByRef b As BigInteger, c As Integer)
        Dim t As BigInteger = a : a = b : b = b * c + t
    End Sub

    Sub SolvePell(n As Integer, ByRef a As BigInteger, ByRef b As BigInteger)
        Dim x As Integer = Math.Sqrt(n), y As Integer = x, z As Integer = 1, r As Integer = x << 1,
            e1 As BigInteger = 1, e2 As BigInteger = 0, f1 As BigInteger = 0, f2 As BigInteger = 1
        While True
            y = r * z - y : z = (n - y * y) / z : r = (x + y) / z
            Fun(e1, e2, r) : Fun(f1, f2, r) : a = f2 : b = e2 : Fun(b, a, x)
            If a * a - n * b * b = 1 Then Exit Sub
        End While
    End Sub

    Sub Main()
        Dim x As BigInteger, y As BigInteger
        For Each n As Integer In {61, 109, 181, 277}
            SolvePell(n, x, y)
            Console.WriteLine("x^2 - {0,3} * y^2 = 1 for x = {1,27:n0} and y = {2,25:n0}", n, x, y)
        Next
    End Sub
End Module


import "/big" for BigInt
import "/fmt" for Fmt

var solvePell = Fn.new { |n|
    n = BigInt.new(n)
    var x = n.isqrt
    var y = x.copy()
    var z = BigInt.one
    var r = x * 2
    var e1 = BigInt.one
    var e2 = BigInt.zero
    var f1 = BigInt.zero
    var f2 = BigInt.one
    while (true) {
        y = r*z - y
        z = (n - y*y) / z
        r = (x + y) / z
        var t = e1.copy()
        e1 = e2.copy()
        e2 = r*e2 + t
        t = f1.copy()
        f1 = f2.copy()
        f2 = r*f2 + t
        var a = e2 + x*f2
        var b = f2.copy()
        if (a*a - n*b*b == BigInt.one) return [a, b]
    }
}

for (n in [61, 109, 181, 277]) {
    var res = solvePell.call(n)
    Fmt.print("x² - $3dy² = 1 for x = $-21i and y = $i", n, res[0], res[1])
}


var [const] BI=Import("zklBigNum");  // libGMP

fcn solve_pell(n){
   x,y,z,r := BI(n).root(2),  x.copy(),  BI(1),  x*2;
   e1,e2, f1,f2 := BI(1), BI(0),  BI(0), BI(1);
   reg t;	// a,b = c,d is a=c; b=d
   do(30_000){  // throttle this in case of screw up
      y,z,r = (r*z - y),  (n - y*y)/z,  (x + y)/z;

      t,e2,e1 = e2,  r*e2 + e1,  t;
      t,f2,f1 = f2,  r*f2 + f1,  t;

      A,B := e2 + x*f2, f2;

      if (A*A - B*B*n == 1) return(A,B);
   }
}


V a = [1, 2, 3]
L
   print(a)
   I !a.next_permutation()
      L.break


*        Permutations              26/10/2015
PERMUTE  CSECT
         USING  PERMUTE,R15        set base register
         LA     R9,TMP-A           n=hbound(a)
         SR     R10,R10            nn=0
LOOP     LA     R10,1(R10)         nn=nn+1
         LA     R11,PG             [email protected]
         LA     R6,1               i=1
LOOPI1   CR     R6,R9              do i=1 to n
         BH     ELOOPI1
         LA     R2,A-1(R6)         @a(i)
         MVC    0(1,R11),0(R2)     output a(i)
         LA     R11,1(R11)         pgi=pgi+1
         LA     R6,1(R6)           i=i+1
         B      LOOPI1
ELOOPI1  XPRNT  PG,80
         LR     R6,R9              i=n
LOOPUIM  BCTR   R6,0               i=i-1
         LTR    R6,R6              until i=0
         BE     ELOOPUIM
         LA     R2,A-1(R6)         @a(i)
         LA     R3,A(R6)           @a(i+1)
         CLC    0(1,R2),0(R3)      or until a(i)<a(i+1)
         BNL    LOOPUIM
ELOOPUIM LR     R7,R6              j=i
         LA     R7,1(R7)           j=i+1
         LR     R8,R9              k=n
LOOPWJ   CR     R7,R8              do while j<k
         BNL    ELOOPWJ
         LA     R2,A-1(R7)         [email protected](j)
         LA     R3,A-1(R8)         [email protected](k)
         MVC    TMP,0(R2)          tmp=a(j)
         MVC    0(1,R2),0(R3)      a(j)=a(k)
         MVC    0(1,R3),TMP        a(k)=tmp
         LA     R7,1(R7)           j=j+1
         BCTR   R8,0               k=k-1
         B      LOOPWJ
ELOOPWJ  LTR    R6,R6              if i>0
         BNP    ILE0
         LR     R7,R6              j=i
         LA     R7,1(R7)           j=i+1
LOOPWA   LA     R2,A-1(R7)         @a(j)
         LA     R3,A-1(R6)         @a(i)
         CLC    0(1,R2),0(R3)      do while a(j)<a(i)
         BNL    AJGEAI
         LA     R7,1(R7)           j=j+1
         B      LOOPWA
AJGEAI   LA     R2,A-1(R7)         [email protected](j)
         LA     R3,A-1(R6)         [email protected](i)
         MVC    TMP,0(R2)          tmp=a(j)
         MVC    0(1,R2),0(R3)      a(j)=a(i)
         MVC    0(1,R3),TMP        a(i)=tmp
ILE0     LTR    R6,R6              until i<>0
         BNE    LOOP
         XR     R15,R15            set return code
         BR     R14                return to caller
A        DC     C'ABCD'            <== input
TMP      DS     C                  temp for swap
PG       DC     CL80' '            buffer
         YREGS
         END    PERMUTE


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

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

/*********************************/
/* Initialized data              */
/*********************************/
.data

sMessResult:        .asciz "Value  : @\n"
sMessCounter:       .asciz "Permutations =  @ \n"
szCarriageReturn:   .asciz "\n"

.align 4
TableNumber:       .quad   1,2,3
                   .equ NBELEMENTS, (. - TableNumber) / 8
/*********************************/
/* UnInitialized data            */
/*********************************/
.bss
sZoneConv:            .skip 24
/*********************************/
/*  code section                 */
/*********************************/
.text
.global main
main:                                 //entry of program
    ldr x0,qAdrTableNumber            //address number table
    mov x1,NBELEMENTS                 //number of élements
    mov x10,0                         //counter
    bl heapIteratif
    mov x0,x10                        //display counter
    ldr x1,qAdrsZoneConv              //
    bl conversion10S                  //décimal conversion
    ldr x0,qAdrsMessCounter
    ldr x1,qAdrsZoneConv              //insert conversion
    bl strInsertAtCharInc
    bl affichageMess                  //display message

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

qAdrszCarriageReturn:     .quad szCarriageReturn
qAdrsMessResult:          .quad sMessResult
qAdrTableNumber:          .quad TableNumber
qAdrsMessCounter:         .quad sMessCounter
/******************************************************************/
/*     permutation by heap iteratif (wikipedia)                                   */
/******************************************************************/
/* x0 contains the address of table */
/* x1 contains the eléments number  */
heapIteratif:
    stp x2,lr,[sp,-16]!             // save  registers
    stp x3,x4,[sp,-16]!             // save  registers
    stp x5,x6,[sp,-16]!             // save  registers
    stp x7,fp,[sp,-16]!             // save  registers
    tst x1,1                        // odd ?
    add x2,x1,1
    csel x2,x2,x1,ne                // the stack must be a multiple of 16
    lsl x7,x2,3                     // 8 bytes by count
    sub sp,sp,x7
    mov fp,sp
    mov x3,#0
    mov x4,#0                       // index
1:                                  // init area counter
    str x4,[fp,x3,lsl 3]
    add x3,x3,#1
    cmp x3,x1
    blt 1b

    bl displayTable
    add x10,x10,#1
    mov x3,#0                       // index
2:
    ldr x4,[fp,x3,lsl 3]            // load count [i]
    cmp x4,x3                       // compare with i
    bge 5f
    tst x3,#1                       // even ?
    bne 3f
    ldr x5,[x0]                     // yes load value A[0]
    ldr x6,[x0,x3,lsl 3]            // and swap with value A[i]
    str x6,[x0]
    str x5,[x0,x3,lsl 3]
    b 4f
3:
    ldr x5,[x0,x4,lsl 3]           // load value A[count[i]]
    ldr x6,[x0,x3,lsl 3]           // and swap with value A[i]
    str x6,[x0,x4,lsl 3]
    str x5,[x0,x3,lsl 3]
4:
    bl displayTable
    add x10,x10,1
    add x4,x4,1                    // increment count i
    str x4,[fp,x3,lsl 3]           // and store on stack
    mov x3,0                       // raz index
    b 2b                           // and loop
5:
    mov x4,0                       // raz count [i]
    str x4,[fp,x3,lsl 3]
    add x3,x3,1                    // increment index
    cmp x3,x1                      // end ?
    blt 2b                         // no -> loop

    add sp,sp,x7                   // stack alignement
100:
    ldp x7,fp,[sp],16              // restaur  2 registers
    ldp x5,x6,[sp],16              // restaur  2 registers
    ldp x3,x4,[sp],16              // restaur  2 registers
    ldp x2,lr,[sp],16              // restaur  2 registers
    ret                            // return to address lr x30
/******************************************************************/
/*      Display table elements                                */
/******************************************************************/
/* x0 contains the address of table */
displayTable:
    stp x1,lr,[sp,-16]!              // save  registers
    stp x2,x3,[sp,-16]!              // save  registers
    mov x2,x0                        // table address
    mov x3,#0
1:                                   // loop display table
    ldr x0,[x2,x3,lsl 3]
    ldr x1,qAdrsZoneConv
    bl conversion10S                 // décimal conversion
    ldr x0,qAdrsMessResult
    ldr x1,qAdrsZoneConv             // insert conversion
    bl strInsertAtCharInc
    bl affichageMess                 // display message
    add x3,x3,1
    cmp x3,NBELEMENTS - 1
    ble 1b
    ldr x0,qAdrszCarriageReturn
    bl affichageMess
    mov x0,x2
100:
    ldp x2,x3,[sp],16                // restaur  2 registers
    ldp x1,lr,[sp],16                // restaur  2 registers
    ret                              // return to address lr x30
qAdrsZoneConv:           .quad sZoneConv
/********************************************************/
/*        File Include fonctions                        */
/********************************************************/
/* for this file see task include a file in language AArch64 assembly */
.include "../includeARM64.inc"


data: lv_flag type c,
      lv_number type i,
      lt_numbers type table of i.

append 1 to lt_numbers.
append 2 to lt_numbers.
append 3 to lt_numbers.

do.
  perform permute using lt_numbers changing lv_flag.
  if lv_flag = 'X'.
    exit.
  endif.
  loop at lt_numbers into lv_number.
    write (1) lv_number no-gap left-justified.
    if sy-tabix <> '3'.
      write ', '.
    endif.
  endloop.
  skip.
enddo.

" Permutation function - this is used to permute:
" Can be used for an unbounded size set.
form permute using iv_set like lt_numbers
             changing ev_last type c.
  data: lv_len     type i,
        lv_first   type i,
        lv_third   type i,
        lv_count   type i,
        lv_temp    type i,
        lv_temp_2  type i,
        lv_second  type i,
        lv_changed type c,
        lv_perm    type i.
  describe table iv_set lines lv_len.

  lv_perm = lv_len - 1.
  lv_changed = ' '.
  " Loop backwards through the table, attempting to find elements which
  " can be permuted. If we find one, break out of the table and set the
  " flag indicating a switch.
  do.
    if lv_perm <= 0.
      exit.
    endif.
    " Read the elements.
    read table iv_set index lv_perm into lv_first.
    add 1 to lv_perm.
    read table iv_set index lv_perm into lv_second.
    subtract 1 from lv_perm.
    if lv_first < lv_second.
      lv_changed = 'X'.
      exit.
    endif.
    subtract 1 from lv_perm.
  enddo.

  " Last permutation.
  if lv_changed <> 'X'.
    ev_last = 'X'.
    exit.
  endif.

  " Swap tail decresing to get a tail increasing.
  lv_count = lv_perm + 1.
  do.
    lv_first = lv_len + lv_perm - lv_count + 1.
    if lv_count >= lv_first.
      exit.
    endif.

    read table iv_set index lv_count into lv_temp.
    read table iv_set index lv_first into lv_temp_2.
    modify iv_set index lv_count from lv_temp_2.
    modify iv_set index lv_first from lv_temp.
    add 1 to lv_count.
  enddo.

  lv_count = lv_len - 1.
  do.
    if lv_count <= lv_perm.
      exit.
    endif.

    read table iv_set index lv_count into lv_first.
    read table iv_set index lv_perm into lv_second.
    read table iv_set index lv_len into lv_third.
    if ( lv_first < lv_third ) and ( lv_first > lv_second ).
      lv_len = lv_count.
    endif.

    subtract 1 from lv_count.
  enddo.

  read table iv_set index lv_perm into lv_temp.
  read table iv_set index lv_len into lv_temp_2.
  modify iv_set index lv_perm from lv_temp_2.
  modify iv_set index lv_len from lv_temp.
endform.


PROC PrintArray(BYTE ARRAY a BYTE len)
  BYTE i

  FOR i=0 TO len-1
  DO
    PrintB(a(i))
  OD
  Print(" ")
RETURN

BYTE FUNC NextPermutation(BYTE ARRAY a BYTE len)
  BYTE i,j,k,tmp

  i=len-1
  WHILE i>0 AND a(i-1)>a(i)
  DO
    i==-1
  OD

  j=i
  k=len-1
  WHILE j<k
  DO
    tmp=a(j) a(j)=a(k) a(k)=tmp
    j==+1 k==-1
  OD

  IF i=0 THEN
    RETURN (0)
  FI

  j=i
  WHILE a(j)<a(i-1)
  DO
    j==+1
  OD
  tmp=a(i-1) a(i-1)=a(j) a(j)=tmp
RETURN (1)

PROC Main()
  DEFINE len="5"
  BYTE ARRAY a(len)
  BYTE RMARGIN=$53,oldRMARGIN
  BYTE i

  oldRMARGIN=RMARGIN
  RMARGIN=37 ;change right margin on the screen

  FOR i=0 TO len-1
  DO
    a(i)=i
  OD

  DO
    PrintArray(a,len)
  UNTIL NextPermutation(a,len)=0
  OD

  RMARGIN=oldRMARGIN ;restore right margin on the screen
RETURN


generic
   N: positive;
package Generic_Perm is
   subtype Element is Positive range 1 .. N;
   type Permutation is array(Element) of Element;

   procedure Set_To_First(P: out Permutation; Is_Last: out Boolean);
   procedure Go_To_Next(P: in out Permutation; Is_Last: out Boolean);
end Generic_Perm;


# -*- coding: utf-8 -*- #

COMMENT REQUIRED BY "prelude_permutations.a68"
  MODE PERMDATA = ~;
PROVIDES:
# PERMDATA*=~* #
# perm*=~ list* #
END COMMENT

MODE PERMDATALIST = REF[]PERMDATA;
MODE PERMDATALISTYIELD = PROC(PERMDATALIST)VOID;

# Generate permutations of the input data list of data list #
PROC perm gen permutations = (PERMDATALIST data list, PERMDATALISTYIELD yield)VOID: (
# Warning: this routine does not correctly handle duplicate elements #
  IF LWB data list = UPB data list THEN
    yield(data list)
  ELSE
    FOR elem FROM LWB data list TO UPB data list DO
      PERMDATA first = data list[elem];
      data list[LWB data list+1:elem] := data list[:elem-1];
      data list[LWB data list] := first;
    # FOR PERMDATALIST next data list IN # perm gen permutations(data list[LWB data list+1:] # ) DO #,
    ##   (PERMDATALIST next)VOID:(
        yield(data list)
    # OD #));
      data list[:elem-1] := data list[LWB data list+1:elem];
      data list[elem] := first
    OD
  FI
);

SKIP


/* hopper-JAMBO - a flavour of Amazing Hopper! */

#include <jambo.h>
Main
  leng=0
  Void(lista)
  Set("la realidad","escapa","a los sentidos"), Apnd list(lista)
  Length(lista), Move to(leng)
  Toksep(" ")
  Printnl( lista )
  Set(1) Gosub(Permutar)
End-Return

Subrutines

Define( Permutar, pos )
    If ( Sub(leng, pos) Isgeq(1) )
       i=pos
       Loop if( Less( i, leng ) )
          Plusone(pos), Gosub(Permutar)
          Set( pos ),   Gosub(Rotate)
          Printnl( lista )
          ++i
       Back
      Plusone(pos), Gosub(Permutar)
      Set( pos ),   Gosub(Rotate)
   End If
Return

Define ( Rotate, pos )
    c=0, [pos] Get(lista), Move to(c)
    [ Plusone(pos): leng ] Cget(lista)
    [ pos: Minusone(leng) ] Cput(lista)
    Set(c), [ leng ] Cput(lista)
Return


⍝ Builtin version, takes a vector:
⎕CY'dfns'
perms←{↓⍵[pmat ≢⍵]} ⍝ pmat always gives lexicographically ordered permutations.

⍝ Recursive fast implementation, courtesy of dzaima from The APL Orchard:
dpmat←{1=⍵:,⊂,0 ⋄ (⊃,/)¨(⍳⍵)⌽¨⊂(⊂(!⍵-1)⍴⍵-1),⍨∇⍵-1}
perms2←{↓⍵[1+⍉↑dpmat ≢⍵]}


----------------------- PERMUTATIONS -----------------------

-- permutations :: [a] -> [[a]]
on permutations(xs)
    script go
        on |λ|(xs)
            script h
                on |λ|(x)
                    script ts
                        on |λ|(ys)
                            {{x} & ys}
                        end |λ|
                    end script
                    concatMap(ts, go's |λ|(|delete|(x, xs)))
                end |λ|
            end script

            if {} ≠ xs then
                concatMap(h, xs)
            else
                {{}}
            end if
        end |λ|
    end script
    go's |λ|(xs)
end permutations

--------------------------- TEST ---------------------------
on run

    permutations({"aardvarks", "eat", "ants"})

end run

-------------------- GENERIC FUNCTIONS ---------------------

-- concatMap :: (a -> [b]) -> [a] -> [b]
on concatMap(f, xs)
    set lst to {}
    set lng to length of xs
    tell mReturn(f)
        repeat with i from 1 to lng
            set lst to (lst & |λ|(contents of item i of xs, i, xs))
        end repeat
    end tell
    return lst
end concatMap

-- delete :: a -> [a] -> [a]
on |delete|(x, xs)
    if length of xs > 0 then
        set {h, t} to uncons(xs)
        if x = h then
            t
        else
            {h} & |delete|(x, t)
        end if
    else
        {}
    end if
end |delete|

-- Lift 2nd class handler function into 1st class script wrapper
-- mReturn :: Handler -> Script
on mReturn(f)
    if class of f is script then
        f
    else
        script
            property |λ| : f
        end script
    end if
end mReturn

-- uncons :: [a] -> Maybe (a, [a])
on uncons(xs)
    if length of xs > 0 then
        {item 1 of xs, rest of xs}
    else
        missing value
    end if
end uncons


/* ARM assembly Raspberry PI  */
/*  program permutation.s  */

 /* REMARK 1 : this program use routines in a include file
   see task Include a file language arm assembly
   for the routine affichageMess conversion10
   see at end of this program the instruction include */
/* for constantes see task include a file in arm assembly */
/************************************/
/* Constantes                       */
/************************************/
.include "../constantes.inc"

/*********************************/
/* Initialized data              */
/*********************************/
.data

sMessResult:        .asciz "Value  : @ \n"
sMessCounter:       .asciz "Permutations =  @  \n"
szCarriageReturn:   .asciz "\n"

.align 4
TableNumber:       .int   1,2,3
                   .equ NBELEMENTS, (. - TableNumber) / 4
/*********************************/
/* UnInitialized data            */
/*********************************/
.bss
sZoneConv:            .skip 24
/*********************************/
/*  code section                 */
/*********************************/
.text
.global main
main:                                              @ entry of program
    ldr r0,iAdrTableNumber                         @ address number table
    mov r1,#NBELEMENTS                             @ number of élements
    mov r10,#0                                     @ counter
    bl heapIteratif
    mov r0,r10                                     @ display counter
    ldr r1,iAdrsZoneConv                           @
    bl conversion10S                               @ décimal conversion
    ldr r0,iAdrsMessCounter
    ldr r1,iAdrsZoneConv                           @ insert conversion
    bl strInsertAtCharInc
    bl affichageMess                               @ display message

100:                                               @ standard end of the program
    mov r0, #0                                     @ return code
    mov r7, #EXIT                                  @ request to exit program
    svc #0                                         @ perform the system call

iAdrszCarriageReturn:     .int szCarriageReturn
iAdrsMessResult:          .int sMessResult
iAdrTableNumber:          .int TableNumber
iAdrsMessCounter:         .int sMessCounter
/******************************************************************/
/*     permutation by heap iteratif (wikipedia)                                   */
/******************************************************************/
/* r0 contains the address of table */
/* r1 contains the eléments number  */
heapIteratif:
    push {r3-r9,lr}                @ save registers
    lsl r9,r1,#2                   @ four bytes by count
    sub sp,sp,r9
    mov fp,sp
    mov r3,#0
    mov r4,#0                      @ index
1:                                 @ init area counter
    str r4,[fp,r3,lsl #2]
    add r3,r3,#1
    cmp r3,r1
    blt 1b

    bl displayTable
    add r10,r10,#1
    mov r3,#0                       @ index
2:
    ldr r4,[fp,r3,lsl #2]           @ load count [i]
    cmp r4,r3                       @ compare with i
    bge 5f
    tst r3,#1                       @ even ?
    bne 3f
    ldr r5,[r0]                     @ yes load value A[0]
    ldr r6,[r0,r3,lsl #2]           @ and swap with value A[i]
    str r6,[r0]
    str r5,[r0,r3,lsl #2]
    b 4f
3:
    ldr r5,[r0,r4,lsl #2]         @ load value A[count[i]]
    ldr r6,[r0,r3,lsl #2]         @ and swap with value A[i]
    str r6,[r0,r4,lsl #2]
    str r5,[r0,r3,lsl #2]
4:
    bl displayTable
    add r10,r10,#1
    add r4,r4,#1                    @ increment count i
    str r4,[fp,r3,lsl #2]           @ and store on stack
    mov r3,#0                       @ raz index
    b 2b                            @ and loop
5:
    mov r4,#0                       @ raz count [i]
    str r4,[fp,r3,lsl #2]
    add r3,r3,#1                    @ increment index
    cmp r3,r1                       @ end ?
    blt 2b                          @ no -> loop

    add sp,sp,r9                    @ stack alignement
100:
    pop {r3-r9,lr}
    bx lr                           @ return

/******************************************************************/
/*      Display table elements                                */
/******************************************************************/
/* r0 contains the address of table */
displayTable:
    push {r0-r3,lr}                                    @ save registers
    mov r2,r0                                          @ table address
    mov r3,#0
1:                                                     @ loop display table
    ldr r0,[r2,r3,lsl #2]
    ldr r1,iAdrsZoneConv                               @
    bl conversion10S                                    @ décimal conversion
    ldr r0,iAdrsMessResult
    ldr r1,iAdrsZoneConv                               @ insert conversion
    bl strInsertAtCharInc
    bl affichageMess                                   @ display message
    add r3,#1
    cmp r3,#NBELEMENTS - 1
    ble 1b
    ldr r0,iAdrszCarriageReturn
    bl affichageMess
    mov r0,r2
100:
    pop {r0-r3,lr}
    bx lr
iAdrsZoneConv:           .int sZoneConv
/***************************************************/
/*      ROUTINES INCLUDE                           */
/***************************************************/
.include "../affichage.inc"


#NoEnv
StringCaseSense On

o := str := "Hello"

Loop
{
   str := perm_next(str)
   If !str
   {
      MsgBox % clipboard := o
      break
   }
   o.= "`n" . str
}

perm_Next(str){
   p := 0, sLen := StrLen(str)
   Loop % sLen
   {
      If A_Index=1
         continue
      t := SubStr(str, sLen+1-A_Index, 1)
      n := SubStr(str, sLen+2-A_Index, 1)
      If ( t < n )
      {
         p := sLen+1-A_Index, pC := SubStr(str, p, 1)
         break
      }
   }
   If !p
      return false
   Loop
   {
      t := SubStr(str, sLen+1-A_Index, 1)
      If ( t > pC )
      {
         n := sLen+1-A_Index, nC := SubStr(str, n, 1)
         break
      }
   }
   return SubStr(str, 1, p-1) . nC . Reverse(SubStr(str, p+1, n-p-1) . pC .  SubStr(str, n+1))
}

Reverse(s){
   Loop Parse, s
      o := A_LoopField o
   return o
}


# syntax: GAWK -f PERMUTATIONS.AWK [-v sep=x] [word]
#
# examples:
#   REM all permutations on one line
#   GAWK -f PERMUTATIONS.AWK
#
#   REM all permutations on a separate line
#   GAWK -f PERMUTATIONS.AWK -v sep="\n"
#
#   REM use a different word
#   GAWK -f PERMUTATIONS.AWK Gwen
#
#   REM command used for RosettaCode output
#   GAWK -f PERMUTATIONS.AWK -v sep="\n" Gwen
#
BEGIN {
    sep = (sep == "") ? " " : substr(sep,1,1)
    str = (ARGC == 1) ? "abc" : ARGV[1]
    printf("%s%s",str,sep)
    leng = length(str)
    for (i=1; i<=leng; i++) {
      arr[i-1] = substr(str,i,1)
    }
    ana_permute(0)
    exit(0)
}
function ana_permute(pos,  i,j,str) {
    if (leng - pos < 2) { return }
    for (i=pos; i<leng-1; i++) {
      ana_permute(pos+1)
      ana_rotate(pos)
      for (j=0; j<=leng-1; j++) {
        printf("%s",arr[j])
      }
      printf(sep)
    }
    ana_permute(pos+1)
    ana_rotate(pos)
}
function ana_rotate(pos,  c,i) {
    c = arr[pos]
    for (i=pos; i<leng-1; i++) {
      arr[i] = arr[i+1]
    }
    arr[leng-1] = c
}


arraybase 1
n = 4 : cont = 0
dim a(n)
dim c(n)

for j = 1 to n
    a[j] = j
next j

do
    for i = 1 to n
        print a[i];
    next
    print " ";

    i = n
    cont += 1
    if cont = 12 then
        print
        cont = 0
    else
        print " ";
    end if

    do
        i -= 1
    until (i = 0) or (a[i] < a[i+1])
    j = i + 1
    k = n
    while j < k
        tmp = a[j] : a[j] = a[k] : a[k] = tmp
        j += 1
        k -= 1
    end while
    if i > 0 then
        j = i + 1
        while a[j] < a[i]
            j += 1
        end while
        tmp = a[j] : a[j] = a[i] : a[i] = tmp
    end if
until i = 0
end


@echo off
setlocal enabledelayedexpansion
set arr=ABCD
set /a n=4
:: echo !arr!
call :permu  %n% arr
goto:eof

:permu num  &arr
setlocal
if %1 equ 1 call echo(!%2! & exit /b
set /a "num=%1-1,n2=num-1"
set arr=!%2!
for /L %%c in (0,1,!n2!) do (
   call:permu !num! arr
   set /a  n1="num&1"
   if !n1! equ 0 (call:swapit !num! 0 arr) else (call:swapit !num! %%c arr)
   )
   call:permu !num! arr
endlocal & set %2=%arr%
exit /b

:swapit  from  to  &arr
setlocal
set arr=!%3!
set temp1=!arr:~%~1,1!
set temp2=!arr:~%~2,1!
set arr=!arr:%temp1%[email protected]!
set arr=!arr:%temp2%=%temp1%!
set arr=!arr:@=%temp2%!
:: echo %1 %2 !%~3! !arr!
endlocal & set %3=%arr%
exit /b


      DIM List%(3)
      List%() = 1, 2, 3, 4
      FOR perm% = 1 TO 24
        FOR i% = 0 TO DIM(List%(),1)
          PRINT List%(i%);
        NEXT
        PRINT
        PROC_NextPermutation(List%())
      NEXT
      END

      DEF PROC_NextPermutation(A%())
      LOCAL first, last, elementcount, pos
      elementcount = DIM(A%(),1)
      IF elementcount < 1 THEN ENDPROC
      pos = elementcount-1
      WHILE A%(pos) >= A%(pos+1)
        pos -= 1
        IF pos < 0 THEN
          PROC_Permutation_Reverse(A%(), 0, elementcount)
          ENDPROC
        ENDIF
      ENDWHILE
      last = elementcount
      WHILE A%(last) <= A%(pos)
        last -= 1
      ENDWHILE
      SWAP A%(pos), A%(last)
      PROC_Permutation_Reverse(A%(), pos+1, elementcount)
      ENDPROC

      DEF PROC_Permutation_Reverse(A%(), first, last)
      WHILE first < last
        SWAP A%(first), A%(last)
        first += 1
        last -= 1
      ENDWHILE
      ENDPROC


  ( perm
  =   prefix List result original A Z
    .   !arg:(?.)
      |   !arg:(?prefix.?List:?original)
        & :?result
        &   whl
          ' ( !List:%?A ?Z
            & !result perm$(!prefix !A.!Z):?result
            & !Z !A:~!original:?List
            )
        & !result
  )
& out$(perm$(.a 2 "]" u+z);


#include <stdio.h>
int main (int argc, char *argv[]) {
//here we check arguments
	if (argc < 2) {
        printf("Enter an argument. Example 1234 or dcba:\n");
        return 0;
	}
//it calculates an array's length
        int x;
        for (x = 0; argv[1][x] != '\0'; x++);
//buble sort the array
	int f, v, m;
	 for(f=0; f < x; f++) {
    	 for(v = x-1; v > f; v-- ) {
     	 if (argv[1][v-1] > argv[1][v]) {
	m=argv[1][v-1];
	argv[1][v-1]=argv[1][v];
	argv[1][v]=m;
    }
  }
}

//it calculates a factorial to stop the algorithm
    char a[x];
	int k=0;
	int fact=k+1;
             while (k!=x) {
                   a[k]=argv[1][k];
               	   k++;
		  fact = k*fact;
                   }
                   a[k]='\0';
//Main part: here we permutate
           int i, j;
           int y=0;
           char c;
          while (y != fact) {
          printf("%s\n", a);
          i=x-2;
          while(a[i] > a[i+1] ) i--;
          j=x-1;
          while(a[j] < a[i] ) j--;
      c=a[j];
      a[j]=a[i];
      a[i]=c;
i++;
for (j = x-1; j > i; i++, j--) {
  c = a[i];
  a[i] = a[j];
  a[j] = c;
      }
y++;
   }
}


public static class Extension
{
    public static IEnumerable<IEnumerable<T>> Permutations<T>(this IEnumerable<T> values) where T : IComparable<T>
    {
        if (values.Count() == 1)
            return new[] { values };
        return values.SelectMany(v => Permutations(values.Where(x => x.CompareTo(v) != 0)), (v, p) => p.Prepend(v));
    }
}


#include <algorithm>
#include <string>
#include <vector>
#include <iostream>

template<class T>
void print(const std::vector<T> &vec)
{
    for (typename std::vector<T>::const_iterator i = vec.begin(); i != vec.end(); ++i)
    {
        std::cout << *i;
        if ((i + 1) != vec.end())
            std::cout << ",";
    }
    std::cout << std::endl;
}

int main()
{
    //Permutations for strings
    std::string example("Hello");
    std::sort(example.begin(), example.end());
    do {
        std::cout << example << '\n';
    } while (std::next_permutation(example.begin(), example.end()));

    // And for vectors
    std::vector<int> another;
    another.push_back(1234);
    another.push_back(4321);
    another.push_back(1234);
    another.push_back(9999);

    std::sort(another.begin(), another.end());
    do {
        print(another);
    } while (std::next_permutation(another.begin(), another.end()));

    return 0;
}


user=> (require 'clojure.contrib.combinatorics)
nil
user=> (clojure.contrib.combinatorics/permutations [1 2 3])
((1 2 3) (1 3 2) (2 1 3) (2 3 1) (3 1 2) (3 2 1))


# Returns a copy of an array with the element at a specific position
# removed from it.
arrayExcept = (arr, idx) ->
	res = arr[0..]
	res.splice idx, 1
	res

# The actual function which returns the permutations of an array-like
# object (or a proper array).
permute = (arr) ->
	arr = Array::slice.call arr, 0
	return [[]] if arr.length == 0

	permutations = (for value,idx in arr
		[value].concat perm for perm in permute arrayExcept arr, idx)

	# Flatten the array before returning it.
	[].concat permutations...


(defun permute (list)
  (if list
    (mapcan #'(lambda (x)
		(mapcar #'(lambda (y) (cons x y))
			(permute (remove x list))))
	    list)
    '(()))) ; else

(print (permute '(A B Z)))


insert :: a -> [a] -> [a]
insert x xs  = x : xs
insert x (y:ys) = y : insert x ys

permutation :: [a] -> [a]
permutation []     = []
permutation (x:xs) = insert x $ permutation xs


T[][] permutations(T)(T[] items) pure nothrow {
    T[][] result;

    void perms(T[] s, T[] prefix=[]) nothrow {
        if (s.length)
            foreach (immutable i, immutable c; s)
               perms(s[0 .. i] ~ s[i+1 .. $], prefix ~ c);
        else
            result ~= prefix;
    }

    perms(items);
    return result;
}

version (permutations1_main) {
    void main() {
        import std.stdio;
        writefln("%(%s\n%)", [1, 2, 3].permutations);
    }
}


program TestPermutations;

{$APPTYPE CONSOLE}

type
  TItem = Integer;                // declare ordinal type for array item
  TArray = array[0..3] of TItem;

const
  Source: TArray = (1, 2, 3, 4);

procedure Permutation(K: Integer; var A: TArray);
var
  I, J: Integer;
  Tmp: TItem;

begin
  for I:= Low(A) + 1 to High(A) + 1 do begin
    J:= K mod I;
    Tmp:= A[J];
    A[J]:= A[I - 1];
    A[I - 1]:= Tmp;
    K:= K div I;
  end;
end;

var
  A: TArray;
  I, K, Count: Integer;
  S, S1, S2: ShortString;

begin
  Count:= 1;
  I:= Length(A);
  while I > 1 do begin
    Count:= Count * I;
    Dec(I);
  end;

  S:= '';
  for K:= 0 to Count - 1 do begin
    A:= Source;
    Permutation(K, A);
    S1:= '';
    for I:= Low(A) to High(A) do begin
      Str(A[I]:1, S2);
      S1:= S1 + S2;
    end;
    S:= S + '  ' + S1;
    if Length(S) > 40 then begin
      Writeln(S);
      S:= '';
    end;
  end;

  if Length(S) > 0 then Writeln(S);
  Readln;
end.


[Permutations task for Rosetta Code.]
[EDSAC program, Initial Orders 2.]

    T51K P200F [G parameter: start address of subroutines]
    T47K P100F [M parameter: start address of main routine]

[====================== G parameter: Subroutines =====================]
            E25K TG GK
[Constants used in the subroutines]
      [0]   AF  [add to address to make A order for that address]
      [1]   SF  [add to address to make S order for that address]
      [2]   UF  [(1) add to address to make U order for that address]
                [(2) subtract from S order to make T order, same address]
      [3]   OF  [add to A order to make T order, same address]

[-----------------------------------------------------------
Subroutine to initialize an array of n short (17-bit) words
to 0, 1, 2, ..., n-1 (in the address field).
Parameters: 4F = address of array; 5F = n = length of array.
Workspace: 0F, 1F.]
      [4]   A3F     [plant return link as usual]
            [email protected]
            A4F     [address of array]
            [email protected]     [make U order for that address]
            T1F     [store U order in 1F]
            A5F     [load n = number of elements (in address field)]
            S2F     [make n-1]
[Start of loop; works backwards, n-1 to 0]
     [11]   UF      [store array element in 0F]
            A1F     [make order to store element in array]
            [email protected]    [plant that order in code]
            AF      [pick up element fron 0F]
     [15]   UF      [(planted) store element in array]
            S2F     [dec to next element]
            [email protected]    [loop if still >= 0]
            TF      [clear acc. before return]
     [19]   ZF      [overwritten by jump back to caller]

[-------------------------------------------------------------------
Subroutine to get next permutation in lexicographic order.
Uses same 4-step algorithm as Wikipedia article "Permutations",
but notation in comments differs from that in Wikipedia.
Parameters: 4F = address of array; 5F = n = length of array.
            0F is returned as 0 for success, < 0 if passed-in
               permutation is the last.
Workspace: 0F, 1F.]
     [20]   A3F     [plant return link as usual]
            [email protected]

[Step 1: Find the largest index k such that a{k} > a{k-1}.
 If no such index exists, the passed-in permutation is the last.]
            A4F     [load address of a{0}]
            [email protected]      [make A order for a{0}]
            U1F     [store as test for end of loop]
            A5F     [make A order for a{n}]
            [email protected]    [plant in code below]
            S2F     [make A order for a{n-1}]
            [email protected]    [plant in code below]
            A4F     [load address of a{0}]
            A5F     [make address of a{n}]
            [email protected]     [make S order for a{n}]
            [email protected]    [plant in code below]
[Start of loop for comparing a{k} with a{k-1}]
     [33]   TF      [clear acc]
            [email protected]    [load A order for a{k}]
            S2F     [make A order for a{k-1}]
            S1F     [tested all yet?]
            [email protected]   [if yes, jump to failed (no more permutations)]
            A1F     [restore accumulator after test]
            [email protected]    [plant updated A order]
            [email protected]    [dec address in S order]
            S2F
            [email protected]
     [43]   SF      [(planted) load a{k-1}]
     [44]   AF      [(planted) subtract a{k}]
            [email protected]    [loop back if a{k-1} > a{k}]

[Step 2: Find the largest index j >= k such that a{j} > a{k-1}.
 Such an index j exists, because j = k is an instance.]
            TF      [clear acc]
            A4F     [load address of a{0}]
            A5F     [make address of a{n}]
            [email protected]     [make S order for a{n}]
            T1F     [save as test for end of loop]
            [email protected]    [load S order for a{k}]
            [email protected]    [plant in code below]
            [email protected]    [load A order for a{k-1}]
            [email protected]    [plant in code below]
[Start of loop]
     [55]   TF      [clear acc]
            [email protected]    [load S order for a{j} (initially j = k)]
            [email protected]    [plant in code below]
            A2F     [inc address (in effect inc j)]
            S1F     [test for end of array]
            [email protected]    [jump out if so]
            A1F     [restore acc after test]
            [email protected]    [update S order]
     [63]   AF      [(planted) load a{k-1}]
     [64]   SF      [(planted) subtract a{j}]
            [email protected]    [loop back if a{j} still > a{k-1}]
     [66]
[Step 3: Swap a{k-1} and a{j}]
            TF      [clear acc]
            [email protected]    [load A order for a{k-1}]
            [email protected]    [plant in code below, 2 places]
            [email protected]
            [email protected]     [make T order for a{k-1}]
            [email protected]    [plant in code below]
            [email protected]    [load S order for a{j}]
            [email protected]     [make T order for a{j}]
            [email protected]    [plant in code below]
     [75]   SF      [(planted) load -a{j}]
            TF      [park -a{j} in 0F]
     [77]   AF      [(planted) load a{k-1}]
     [78]   TF      [(planted) store a{j}]
            SF      [load a{j} by subtracting -a{j}]
     [80]   TF      [(planted) store in a{k-1}]

[Step 4: Now a{k}, ..., a{n-1} are in decreasing order.
 Change to increasing order by repeated swapping.]
     [81]   [email protected]    [counting down from a{n} (exclusive end of array)]
            S2F     [make A order for a{n-1}]
            [email protected]    [plant in code]
            [email protected]     [make T order for a{n-1}]
            [email protected]    [plant]
            [email protected]    [counting up from a{k-1} (exclusive)]
            A2F     [make A order for a{k}]
            [email protected]    [plant]
            [email protected]     [make T order for a{k}]
            [email protected]    [plant]
            [email protected]    [swapped all yet?]
            [email protected]   [if yes, jump to exit from subroutine]
[Swapping two array elements, initially a{k} and a{n-1}]
            TF      [clear acc]
     [94]   AF      [(planted) load 1st element]
            TF      [park in 0F]
     [96]   AF      [(planted) load 2nd element]
     [97]   TF      [(planted) copy to 1st element]
            AF      [load old 1st element]
     [99]   TF      [(planted) copy to 2nd element]
            [email protected]    [always loop back]
    [101]   TF      [done, return 0 in location 0F]
    [102]   TF      [return status to caller in 0F; also clears acc]
    [103]   ZF      [(planted) jump back to caller]

[==================== M parameter: Main routine ==================]
[Prints all 120 permutations of the letters in 'EDSAC'.]
            E25K TM GK
[Constants used in the main routine]
      [0]   P900F   [address of permutation array]
      [1]   P5F     [number of elements in permutation (in address field)]
[Array of letters in 'EDSAC', in alphabetical order]
      [2]   AF CF DF EF SF
      [7]   [email protected]     [add to index to make O order for letter in array]
      [8]   P12F    [permutations per printed line (in address field)]
      [9]   AF      [add to address to make A order for that address]
[Teleprinter characters]
     [10]   K2048F  [set letters mode]
     [11]   !F      [space]
     [12]   @F      [carriage return]
     [13]   &F      [line feed]
     [14]   K4096F  [null]

[Entry point, with acc = 0.]
     [15]   [email protected]    [set teleprinter to letters]
            [email protected]     [intialize -ve count of permutations per line]
            T7F     [keep count in 7F]
            [email protected]      [pass address of permutation array in 4F]
            T4F
            [email protected]     [pass number of elements in 5F]
            T5F
     [22]   [email protected]    [call subroutine to initialize permutation array]
            G4G
[Loop: print current permutation, then get next (if any)]
     [24]   A4F     [address]
            [email protected]     [make A order]
            [email protected]    [plant in code]
            S5F     [initialize -ve count of array elements]
     [28]   T6F     [keep count in 6F]
     [29]   AF      [(planted) load permutation element]
            [email protected]     [make order to print letter from table]
            [email protected]    [plant in code]
     [32]   OF      [(planted) print letter from table]
            [email protected]    [inc address in permutation array]
            A2F
            [email protected]
            A6F     [inc -ve count of array elements]
            A2F
            [email protected]    [loop till count becomes 0]
            A7F     [inc -ve count of perms per line]
            A2F
            [email protected]    [jump if end of line]
            [email protected]    [else print a space]
            [email protected]    [join common code]
     [44]   [email protected]    [print CR]
            [email protected]    [print LF]
            [email protected]
     [47]   T7F     [update -ve count of permutations in line]
     [48]   [email protected]    [call subroutine for next permutation (if any)]
            G20G
            AF      [test 0F: got a new permutation?]
            [email protected]    [if so, loop to print it]
            [email protected]    [no more, output null to flush teleprinter buffer]
            ZF      [halt program]
            E15Z    [define entry point]
            PF      [enter with acc = 0]
[end]


class
	APPLICATION

create
	make

feature {NONE}

	make
		do
			test := <<2, 5, 1>>
			permute (test, 1)
		end

	test: ARRAY [INTEGER]

	permute (a: ARRAY [INTEGER]; k: INTEGER)
			-- All permutations of 'a'.
		require
			count_positive: a.count > 0
			k_valid_index: k > 0
		local
			t: INTEGER
		do
			if k = a.count then
				across
					a as ar
				loop
					io.put_integer (ar.item)
				end
				io.new_line
			else
				across
					k |..| a.count as c
				loop
					t := a [k]
					a [k] := a [c.item]
					a [c.item] := t
					permute (a, k + 1)
					t := a [k]
					a [k] := a [c.item]
					a [c.item] := t
				end
			end
		end

end


defmodule RC do
  def permute([]), do: [[]]
  def permute(list) do
    for x <- list, y <- permute(list -- [x]), do: [x|y]
  end
end

IO.inspect RC.permute([1, 2, 3])


-module(permute).
-export([permute/1]).

permute([]) -> [[]];
permute(L) -> [[X|Y] || X<-L, Y<-permute(L--[X])].


function reverse(sequence s, integer first, integer last)
    object x
    while first < last do
        x = s[first]
        s[first] = s[last]
        s[last] = x
        first += 1
        last -= 1
    end while
    return s
end function

function nextPermutation(sequence s)
    integer pos, last
    object x
    if length(s) < 1 then
        return 0
    end if

    pos = length(s)-1
    while compare(s[pos], s[pos+1]) >= 0 do
        pos -= 1
        if pos < 1 then
            return -1
        end if
    end while

    last = length(s)
    while compare(s[last], s[pos]) <= 0 do
        last -= 1
    end while
    x = s[pos]
    s[pos] = s[last]
    s[last] = x

    return reverse(s, pos+1, length(s))
end function

object s
s = "abcd"
puts(1, s & '\t')
while 1 do
    s = nextPermutation(s)
    if atom(s) then
        exit
    end if
    puts(1, s & '\t')
end while


let rec insert left x right = seq {
    match right with
    | [] -> yield left @ [x]
    | head :: tail ->
        yield left @ [x] @ right
        yield! insert (left @ [head]) x tail
    }

let rec perms permute =
    seq {
        match permute with
        | [] -> yield []
        | head :: tail -> yield! Seq.collect (insert [] head) (perms tail)
    }

[<EntryPoint>]
let main argv =
    perms (Seq.toList argv)
    |> Seq.iter (fun x -> printf "%A\n" x)
    0


program permutations

  implicit none
  integer, parameter :: value_min = 1
  integer, parameter :: value_max = 3
  integer, parameter :: position_min = value_min
  integer, parameter :: position_max = value_max
  integer, dimension (position_min : position_max) :: permutation

  call generate (position_min)

contains

  recursive subroutine generate (position)

    implicit none
    integer, intent (in) :: position
    integer :: value

    if (position > position_max) then
      write (*, *) permutation
    else
      do value = value_min, value_max
        if (.not. any (permutation (: position - 1) == value)) then
          permutation (position) = value
          call generate (position + 1)
        end if
      end do
    end if

  end subroutine generate

end program permutations


' version 07-04-2017
' compile with: fbc -s console

' Heap's algorithm non-recursive
Sub perms(n As Long)

    Dim As ULong i, j, count = 1
    Dim As ULong a(0 To n -1), c(0 To n -1)

    For j = 0 To n -1
        a(j) = j +1
        Print a(j);
    Next
    Print " ";

    i = 0
    While i < n
        If c(i) < i Then
            If (i And 1) = 0 Then
                Swap a(0), a(i)
            Else
                Swap a(c(i)), a(i)
            End If
            For j = 0 To n -1
                Print a(j);
            Next
            count += 1
            If count = 12 Then
                Print
                count = 0
            Else
                Print " ";
            End If
            c(i) += 1
            i = 0
        Else
            c(i) = 0
            i += 1
        End If
    Wend

End Sub

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

perms(4)

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


a = [1,2,3,4]
println[formatTable[a.lexicographicPermute[]]]


$$ n !! k    dyadic: Permutations for k out of n elements (in this case k = n)
$$ #s        monadic: number of elements in s
$$ ,,        monadic: expose with space-lf separators
$$ s[n]      index n of s

'Hello' 123 7.9 '•'=>s;
s[s# !! (s#)],,


#delimiter should not occur inside elements
delimiter=;
#convert list to delimiter separated string
implode=$(subst $() $(),$(delimiter),$(strip $1))
#convert delimiter separated string to list
explode=$(strip $(subst $(delimiter), ,$1))
#enumerate all permutations and subpermutations
permutations0=$(if $1,$(foreach x,$1,$x $(addprefix $x$(delimiter),$(call permutations0,$(filter-out $x,$1)))),)
#remove subpermutations from permutations0 output
permutations=$(strip $(foreach x,$(call permutations0,$1),$(if $(filter $(words $1),$(words $(call explode,$x))),$(call implode,$(call explode,$x)),)))

delimiter_separated_output=$(call permutations,a b c d)
$(info $(delimiter_separated_output))


package main

import "fmt"

func main() {
    demoPerm(3)
}

func demoPerm(n int) {
    // create a set to permute.  for demo, use the integers 1..n.
    s := make([]int, n)
    for i := range s {
        s[i] = i + 1
    }
    // permute them, calling a function for each permutation.
    // for demo, function just prints the permutation.
    permute(s, func(p []int) { fmt.Println(p) })
}

// permute function.  takes a set to permute and a function
// to call for each generated permutation.
func permute(s []int, emit func([]int)) {
    if len(s) == 0 {
        emit(s)
        return
    }
    // Steinhaus, implemented with a recursive closure.
    // arg is number of positions left to permute.
    // pass in len(s) to start generation.
    // on each call, weave element at pp through the elements 0..np-2,
    // then restore array to the way it was.
    var rc func(int)
    rc = func(np int) {
        if np == 1 {
            emit(s)
            return
        }
        np1 := np - 1
        pp := len(s) - np1
        // weave
        rc(np1)
        for i := pp; i > 0; i-- {
            s[i], s[i-1] = s[i-1], s[i]
            rc(np1)
        }
        // restore
        w := s[0]
        copy(s, s[1:pp+1])
        s[pp] = w
    }
    rc(len(s))
}


def makePermutations = { l -> l.permutations() }


import Data.List (permutations)

main = mapM_ print (permutations [1,2,3])


procedure main(A)
    every p := permute(A) do every writes((!p||" ")|"\n")
end

procedure permute(A)
    if *A <= 1 then return A
    suspend [(A[1]<->A[i := 1 to *A])] ||| permute(A[2:0])
end


100 PROGRAM "Permutat.bas"
110 LET N=4 ! Number of elements
120 NUMERIC T(1 TO N)
130 FOR I=1 TO N
140   LET T(I)=I
150 NEXT
160 LET S=0
170 CALL PERM(N)
180 PRINT "Number of permutations:";S
190 END
200 DEF PERM(I)
210   NUMERIC J,X
220   IF I=1 THEN
230     FOR X=1 TO N
240       PRINT T(X);
250     NEXT
260     PRINT :LET S=S+1
270   ELSE
280     CALL PERM(I-1)
290     FOR J=1 TO I-1
300       LET C=T(J):LET T(J)=T(I):LET T(I)=C
310       CALL PERM(I-1)
320       LET C=T(J):LET T(J)=T(I):LET T(I)=C
330     NEXT
340   END IF
350 END DEF


public class PermutationGenerator {
    private int[] array;
    private int firstNum;
    private boolean firstReady = false;

    public PermutationGenerator(int n, int firstNum_) {
        if (n < 1) {
            throw new IllegalArgumentException("The n must be min. 1");
        }
        firstNum = firstNum_;
        array = new int[n];
        reset();
    }

    public void reset() {
        for (int i = 0; i < array.length; i++) {
            array[i] = i + firstNum;
        }
        firstReady = false;
    }

    public boolean hasMore() {
        boolean end = firstReady;
        for (int i = 1; i < array.length; i++) {
            end = end && array[i] < array[i-1];
        }
        return !end;
    }

    public int[] getNext() {

        if (!firstReady) {
            firstReady = true;
            return array;
        }

        int temp;
        int j = array.length - 2;
        int k = array.length - 1;

        // Find largest index j with a[j] < a[j+1]

        for (;array[j] > array[j+1]; j--);

        // Find index k such that a[k] is smallest integer
        // greater than a[j] to the right of a[j]

        for (;array[j] > array[k]; k--);

        // Interchange a[j] and a[k]

        temp = array[k];
        array[k] = array[j];
        array[j] = temp;

        // Put tail end of permutation after jth position in increasing order

        int r = array.length - 1;
        int s = j + 1;

        while (r > s) {
            temp = array[s];
            array[s++] = array[r];
            array[r--] = temp;
        }

        return array;
    } // getNext()

    // For testing of the PermutationGenerator class
    public static void main(String[] args) {
        PermutationGenerator pg = new PermutationGenerator(3, 1);

        while (pg.hasMore()) {
            int[] temp =  pg.getNext();
            for (int i = 0; i < temp.length; i++) {
                System.out.print(temp[i] + " ");
            }
            System.out.println();
        }
    }

} // class


def permutations:
  if length == 0 then []
  else
    range(0;length) as $i
    | [.[$i]] + (del(.[$i])|permutations)
  end ;


julia> perms(l) = isempty(l) ? [l] : [[x; y] for x in l for y in perms(setdiff(l, x))]


   perm:{:[1<x;,/(>:'(x,x)#1,x#0)[;0,'1+_f x-1];,!x]}
   perm 2
(0 1
 1 0)

   `0:{1_,/" ",/:x}'[email protected]@#r:("some";"random";"text")
some random text
some text random
random some text
random text some
text some random
text random some


// version 1.1.2

fun <T> permute(input: List<T>): List<List<T>> {
    if (input.size == 1) return listOf(input)
    val perms = mutableListOf<List<T>>()
    val toInsert = input[0]
    for (perm in permute(input.drop(1))) {
        for (i in 0..perm.size) {
            val newPerm = perm.toMutableList()
            newPerm.add(i, toInsert)
            perms.add(newPerm)
        }
    }
    return perms
}

fun main(args: Array<String>) {
    val input = listOf('a', 'b', 'c', 'd')
    val perms = permute(input)
    println("There are ${perms.size} permutations of $input, namely:\n")
    for (perm in perms) println(perm)
}


val .factorial = f if(.x < 2: 1; .x x self(.x - 1))

val .permute = f(.arr) {
    if not isArray(.arr): throw "expected array"

    val .limit = 10
    if len(.arr) > .limit: throw $"permutation limit exceeded (currently \.limit;)"

    var .elements = .arr
    var .ordinals = pseries len .elements

    val .n = len(.ordinals)
    var .i, .j

    for[.p=[.arr]] of .factorial(len .arr)-1 {
        .i = .n - 1
        .j = .n
        while .ordinals[.i] > .ordinals[.i+1] {
            .i -= 1
        }
        while .ordinals[.j] < .ordinals[.i] {
            .j -= 1
        }

        .ordinals[.i], .ordinals[.j] = .ordinals[.j], .ordinals[.i]
        .elements[.i], .elements[.j] = .elements[.j], .elements[.i]

        .i += 1
        for .j = .n; .i < .j ; .i, .j = .i+1, .j-1 {
            .ordinals[.i], .ordinals[.j] = .ordinals[.j], .ordinals[.i]
            .elements[.i], .elements[.j] = .elements[.j], .elements[.i]
        }
        .p = more .p, .elements
    }
}

for .e in .permute([1, 3.14, 7]) {
    writeln .e
}


n=3
dim a(n+1)  '+1 needed due to bug in LB that checks loop condition
    '   until (i=0) or (a(i)<a(i+1))
    'before executing i=i-1 in loop body.
for i=1 to n: a(i)=i: next
do
  for i=1 to n: print a(i);: next: print
  i=n
  do
    i=i-1
  loop until (i=0) or (a(i)<a(i+1))
  j=i+1
  k=n
  while j<k
    'swap a(j),a(k)
    tmp=a(j): a(j)=a(k): a(k)=tmp
    j=j+1
    k=k-1
  wend
  if i>0 then
    j=i+1
    while a(j)<a(i)
      j=j+1
    wend
    'swap a(i),a(j)
    tmp=a(j): a(j)=a(i): a(i)=tmp
  end if
loop until i=0


// Lobster implementation of the (very fast) Go example
// http://rosettacode.org/wiki/Permutations#Go
// implementing the plain changes (bell ringers) algorithm, using a recursive function
// https://en.wikipedia.org/wiki/Steinhaus–Johnson–Trotter_algorithm

def permr(s, f):
    if s.length == 0:
        f(s)
        return
    def rc(np: int):
        if np == 1:
            f(s)
            return
        let np1 = np - 1
        let pp = s.length - np1
        rc(np1) // recurs prior swaps
        var i = pp
        while i > 0:
            // swap s[i], s[i-1]
            let t = s[i]
            s[i] = s[i-1]
            s[i-1] = t
            rc(np1) // recurs swap
            i -= 1
        let w = s[0]
        for(pp): s[_] = s[_+1]
        s[pp] = w
    rc(s.length)

// Heap's recursive method https://en.wikipedia.org/wiki/Heap%27s_algorithm

def permh(s, f):
    def rc(k: int):
        if k <= 1:
            f(s)
        else:
            // Generate permutations with kth unaltered
            // Initially k == length(s)
            rc(k-1)
            // Generate permutations for kth swapped with each k-1 initial
            for(k-1) i:
                // Swap choice dependent on parity of k (even or odd)
                 // zero-indexed, the kth is at k-1
                if (k & 1) == 0:
                    let t = s[i]
                    s[i] = s[k-1]
                    s[k-1] = t
                else:
                    let t = s[0]
                    s[0] = s[k-1]
                    s[k-1] = t
                rc(k-1)
    rc(s.length)

// iterative Boothroyd method

import std

def permi(xs, f):
    var d = 1
    let c = map(xs.length): 0
    f(xs)
    while true:
        while d > 1:
            d -= 1
            c[d] = 0
        while c[d] >= d:
            d += 1
            if d >= xs.length:
                return
        let i = if (d & 1) == 1: c[d] else: 0
        let t = xs[i]
        xs[i] = xs[d]
        xs[d] = t
        f(xs)
        c[d] = c[d] + 1

// next lexicographical permutation
// to get all permutations the initial input `a` must be in sorted order
// returns false when input `a` is in reverse sorted order

def next_lex_perm(a):
    def swap(i, j):
        let t = a[i]
        a[i] = a[j]
        a[j] = t
    let n = a.length
    /* 1. Find the largest index k such that a[k] < a[k + 1]. If no such
          index exists, the permutation is the last permutation. */
    var k = n - 1
    while k > 0 and a[k-1] >= a[k]: k--
    if k == 0: return false
    k -= 1
    /* 2. Find the largest index l such that a[k] < a[l]. Since k + 1 is
       such an index, l is well defined */
    var l = n - 1
    while a[l] <= a[k]: l--
    /* 3. Swap a[k] with a[l] */
    swap(k, l)
    /* 4. Reverse the sequence from a[k + 1] to the end */
    k += 1
    l = n - 1
    while l > k:
        swap(k, l)
        l -= 1
        k += 1
    return true

var se = [0, 1, 2, 3] //, 4, 5, 6, 7, 8, 9, 10]

print "Iterative lexicographical permuter"

print se
while next_lex_perm(se): print se

print "Recursive plain changes iterator"

se = [0, 1, 2, 3]

permr(se): print(_)

print "Recursive Heap\'s iterator"

se = [0, 1, 2, 3]

permh(se): print(_)

print "Iterative Boothroyd iterator"

se = [0, 1, 2, 3]

permi(se): print(_)


using System;
using System.Linq;

namespace PentominoTiling
{
    class Program
    {
        static readonly char[] symbols = "FILNPTUVWXYZ-".ToCharArray();

        static readonly int nRows = 8;
        static readonly int nCols = 8;
        static readonly int target = 12;
        static readonly int blank = 12;

        static int[][] grid = new int[nRows][];
        static bool[] placed = new bool[target];

        static void Main(string[] args)
        {
            var rand = new Random();

            for (int r = 0; r < nRows; r++)
                grid[r] = Enumerable.Repeat(-1, nCols).ToArray();

            for (int i = 0; i < 4; i++)
            {
                int randRow, randCol;
                do
                {
                    randRow = rand.Next(nRows);
                    randCol = rand.Next(nCols);
                }
                while (grid[randRow][randCol] == blank);

                grid[randRow][randCol] = blank;
            }

            if (Solve(0, 0))
            {
                PrintResult();
            }
            else
            {
                Console.WriteLine("no solution");
            }

            Console.ReadKey();
        }

        private static void PrintResult()
        {
            foreach (int[] r in grid)
            {
                foreach (int i in r)
                    Console.Write("{0} ", symbols[i]);
                Console.WriteLine();
            }
        }

        private static bool Solve(int pos, int numPlaced)
        {
            if (numPlaced == target)
                return true;

            int row = pos / nCols;
            int col = pos % nCols;

            if (grid[row][col] != -1)
                return Solve(pos + 1, numPlaced);

            for (int i = 0; i < shapes.Length; i++)
            {
                if (!placed[i])
                {
                    foreach (int[] orientation in shapes[i])
                    {
                        if (!TryPlaceOrientation(orientation, row, col, i))
                            continue;

                        placed[i] = true;

                        if (Solve(pos + 1, numPlaced + 1))
                            return true;

                        RemoveOrientation(orientation, row, col);
                        placed[i] = false;
                    }
                }
            }
            return false;
        }

        private static void RemoveOrientation(int[] orientation, int row, int col)
        {
            grid[row][col] = -1;
            for (int i = 0; i < orientation.Length; i += 2)
                grid[row + orientation[i]][col + orientation[i + 1]] = -1;
        }

        private static bool TryPlaceOrientation(int[] orientation, int row, int col, int shapeIndex)
        {
            for (int i = 0; i < orientation.Length; i += 2)
            {
                int x = col + orientation[i + 1];
                int y = row + orientation[i];
                if (x < 0 || x >= nCols || y < 0 || y >= nRows || grid[y][x] != -1)
                    return false;
            }

            grid[row][col] = shapeIndex;
            for (int i = 0; i < orientation.Length; i += 2)
                grid[row + orientation[i]][col + orientation[i + 1]] = shapeIndex;

            return true;
        }

        // four (x, y) pairs are listed, (0,0) not included
        static readonly int[][] F = {
            new int[] {1, -1, 1, 0, 1, 1, 2, 1}, new int[] {0, 1, 1, -1, 1, 0, 2, 0},
            new int[] {1, 0, 1, 1, 1, 2, 2, 1}, new int[] {1, 0, 1, 1, 2, -1, 2, 0},
            new int[] {1, -2, 1, -1, 1, 0, 2, -1}, new int[] {0, 1, 1, 1, 1, 2, 2, 1},
            new int[] {1, -1, 1, 0, 1, 1, 2, -1}, new int[] {1, -1, 1, 0, 2, 0, 2, 1}};

        static readonly int[][] I = {
            new int[] { 0, 1, 0, 2, 0, 3, 0, 4 }, new int[] { 1, 0, 2, 0, 3, 0, 4, 0 } };

        static readonly int[][] L = {
            new int[] {1, 0, 1, 1, 1, 2, 1, 3}, new int[] {1, 0, 2, 0, 3, -1, 3, 0},
            new int[] {0, 1, 0, 2, 0, 3, 1, 3}, new int[] {0, 1, 1, 0, 2, 0, 3, 0},
            new int[] {0, 1, 1, 1, 2, 1, 3, 1}, new int[] {0, 1, 0, 2, 0, 3, 1, 0},
            new int[] {1, 0, 2, 0, 3, 0, 3, 1}, new int[] {1, -3, 1, -2, 1, -1, 1, 0}};

        static readonly int[][] N = {
            new int[] {0, 1, 1, -2, 1, -1, 1, 0}, new int[] {1, 0, 1, 1, 2, 1, 3, 1},
            new int[]  {0, 1, 0, 2, 1, -1, 1, 0}, new int[] {1, 0, 2, 0, 2, 1, 3, 1},
            new int[] {0, 1, 1, 1, 1, 2, 1, 3}, new int[] {1, 0, 2, -1, 2, 0, 3, -1},
            new int[] {0, 1, 0, 2, 1, 2, 1, 3}, new int[] {1, -1, 1, 0, 2, -1, 3, -1}};

        static readonly int[][] P = {
            new int[] {0, 1, 1, 0, 1, 1, 2, 1}, new int[] {0, 1, 0, 2, 1, 0, 1, 1},
            new int[] {1, 0, 1, 1, 2, 0, 2, 1}, new int[] {0, 1, 1, -1, 1, 0, 1, 1},
            new int[] {0, 1, 1, 0, 1, 1, 1, 2}, new int[] {1, -1, 1, 0, 2, -1, 2, 0},
            new int[] {0, 1, 0, 2, 1, 1, 1, 2}, new int[] {0, 1, 1, 0, 1, 1, 2, 0}};

        static readonly int[][] T = {
            new int[] {0, 1, 0, 2, 1, 1, 2, 1}, new int[] {1, -2, 1, -1, 1, 0, 2, 0},
            new int[] {1, 0, 2, -1, 2, 0, 2, 1}, new int[] {1, 0, 1, 1, 1, 2, 2, 0}};

        static readonly int[][] U = {
            new int[] {0, 1, 0, 2, 1, 0, 1, 2}, new int[] {0, 1, 1, 1, 2, 0, 2, 1},
            new int[]  {0, 2, 1, 0, 1, 1, 1, 2}, new int[] {0, 1, 1, 0, 2, 0, 2, 1}};

        static readonly int[][] V = {
            new int[] {1, 0, 2, 0, 2, 1, 2, 2}, new int[] {0, 1, 0, 2, 1, 0, 2, 0},
            new int[] {1, 0, 2, -2, 2, -1, 2, 0}, new int[] {0, 1, 0, 2, 1, 2, 2, 2}};

        static readonly int[][] W = {
            new int[] {1, 0, 1, 1, 2, 1, 2, 2}, new int[] {1, -1, 1, 0, 2, -2, 2, -1},
            new int[] {0, 1, 1, 1, 1, 2, 2, 2}, new int[] {0, 1, 1, -1, 1, 0, 2, -1}};

        static readonly int[][] X = { new int[] { 1, -1, 1, 0, 1, 1, 2, 0 } };

        static readonly int[][] Y = {
            new int[] {1, -2, 1, -1, 1, 0, 1, 1}, new int[] {1, -1, 1, 0, 2, 0, 3, 0},
            new int[] {0, 1, 0, 2, 0, 3, 1, 1}, new int[] {1, 0, 2, 0, 2, 1, 3, 0},
            new int[] {0, 1, 0, 2, 0, 3, 1, 2}, new int[] {1, 0, 1, 1, 2, 0, 3, 0},
            new int[] {1, -1, 1, 0, 1, 1, 1, 2}, new int[] {1, 0, 2, -1, 2, 0, 3, 0}};

        static readonly int[][] Z = {
            new int[] {0, 1, 1, 0, 2, -1, 2, 0}, new int[] {1, 0, 1, 1, 1, 2, 2, 2},
            new int[] {0, 1, 1, 1, 2, 1, 2, 2}, new int[] {1, -2, 1, -1, 1, 0, 2, -2}};

        static readonly int[][][] shapes = { F, I, L, N, P, T, U, V, W, X, Y, Z };
    }
}


:- object(list).

    :- public(permutation/2).

    permutation(List, Permutation) :-
        same_length(List, Permutation),
        permutation2(List, Permutation).

    permutation2([], []).
    permutation2(List, [Head| Tail]) :-
        select(Head, List, Remaining),
        permutation2(Remaining, Tail).

    same_length([], []).
    same_length([_| Tail1], [_| Tail2]) :-
        same_length(Tail1, Tail2).

    select(Head, [Head| Tail], Tail).
    select(Head, [Head2| Tail], [Head2| Tail2]) :-
        select(Head, Tail, Tail2).

:- end_object.


local function permutation(a, n, cb)
	if n == 0 then
		cb(a)
	else
		for i = 1, n do
			a[i], a[n] = a[n], a[i]
			permutation(a, n - 1, cb)
			a[i], a[n] = a[n], a[i]
		end
	end
end

--Usage
local function callback(a)
	print('{'..table.concat(a, ', ')..'}')
end
permutation({1,2,3}, 3, callback)


Module Checkit {
      Global a$
      Document a$
      Module Permutations (s){
            Module Level (n, s, h)   {
                  If n=1 then {
                        while Len(s) {
                              m1=each(h)
                              while m1 {
                                    Print Array$(m1);" ";
                              }
                               Print Array$(S)
                               ToClipBoard()
                               s=cdr(s)
                         }
                  } Else {
                        for i=1 to len(s) {
                              call Level n-1, cdr(s),  cons(h, car(s))
                              s=cons(cdr(s), car(s))
                        }
                  }
                  Sub ToClipBoard()
                        local m=each(h)
                        Local b$=""
                        While m {
                              b$+=If$(Len(b$)<>0->" ","")+Array$(m)+" "
                        }
                        b$+=If$(Len(b$)<>0->" ","")+Array$(s,0)+" "+{
                        }
                        a$<=b$   ' assign to global need <=
                  End Sub
            }
            If len(s)=0 then Error
            Head=(,)
            Call Level Len(s),  s, Head
      }
      Clear a$
      Permutations (1,2,3,4)
      Permutations (100, 200, 500)
      Permutations ("A", "B", "C","D")
      Permutations ("DOG", "CAT", "BAT")
      ClipBoard a$
}
Checkit


package pentominotiling;

import java.util.*;

public class PentominoTiling {

    static final char[] symbols = "FILNPTUVWXYZ-".toCharArray();
    static final Random rand = new Random();

    static final int nRows = 8;
    static final int nCols = 8;
    static final int blank = 12;

    static int[][] grid = new int[nRows][nCols];
    static boolean[] placed = new boolean[symbols.length - 1];

    public static void main(String[] args) {
        shuffleShapes();

        for (int r = 0; r < nRows; r++)
            Arrays.fill(grid[r], -1);

        for (int i = 0; i < 4; i++) {
            int randRow, randCol;
            do {
                randRow = rand.nextInt(nRows);
                randCol = rand.nextInt(nCols);
            } while (grid[randRow][randCol] == blank);
            grid[randRow][randCol] = blank;
        }

        if (solve(0, 0)) {
            printResult();
        } else {
            System.out.println("no solution");
        }
    }

    static void shuffleShapes() {
        int n = shapes.length;
        while (n > 1) {
            int r = rand.nextInt(n--);

            int[][] tmp = shapes[r];
            shapes[r] = shapes[n];
            shapes[n] = tmp;

            char tmpSymbol = symbols[r];
            symbols[r] = symbols[n];
            symbols[n] = tmpSymbol;
        }
    }

    static void printResult() {
        for (int[] r : grid) {
            for (int i : r)
                System.out.printf("%c ", symbols[i]);
            System.out.println();
        }
    }

    static boolean tryPlaceOrientation(int[] o, int r, int c, int shapeIndex) {

        for (int i = 0; i < o.length; i += 2) {
            int x = c + o[i + 1];
            int y = r + o[i];
            if (x < 0 || x >= nCols || y < 0 || y >= nRows || grid[y][x] != -1)
                return false;
        }

        grid[r][c] = shapeIndex;
        for (int i = 0; i < o.length; i += 2)
            grid[r + o[i]][c + o[i + 1]] = shapeIndex;

        return true;
    }

    static void removeOrientation(int[] o, int r, int c) {
        grid[r][c] = -1;
        for (int i = 0; i < o.length; i += 2)
            grid[r + o[i]][c + o[i + 1]] = -1;
    }

    static boolean solve(int pos, int numPlaced) {
        if (numPlaced == shapes.length)
            return true;

        int row = pos / nCols;
        int col = pos % nCols;

        if (grid[row][col] != -1)
            return solve(pos + 1, numPlaced);

        for (int i = 0; i < shapes.length; i++) {
            if (!placed[i]) {
                for (int[] orientation : shapes[i]) {

                    if (!tryPlaceOrientation(orientation, row, col, i))
                        continue;

                    placed[i] = true;

                    if (solve(pos + 1, numPlaced + 1))
                        return true;

                    removeOrientation(orientation, row, col);
                    placed[i] = false;
                }
            }
        }
        return false;
    }

    static final int[][] F = {{1, -1, 1, 0, 1, 1, 2, 1}, {0, 1, 1, -1, 1, 0, 2, 0},
    {1, 0, 1, 1, 1, 2, 2, 1}, {1, 0, 1, 1, 2, -1, 2, 0}, {1, -2, 1, -1, 1, 0, 2, -1},
    {0, 1, 1, 1, 1, 2, 2, 1}, {1, -1, 1, 0, 1, 1, 2, -1}, {1, -1, 1, 0, 2, 0, 2, 1}};

    static final int[][] I = {{0, 1, 0, 2, 0, 3, 0, 4}, {1, 0, 2, 0, 3, 0, 4, 0}};

    static final int[][] L = {{1, 0, 1, 1, 1, 2, 1, 3}, {1, 0, 2, 0, 3, -1, 3, 0},
    {0, 1, 0, 2, 0, 3, 1, 3}, {0, 1, 1, 0, 2, 0, 3, 0}, {0, 1, 1, 1, 2, 1, 3, 1},
    {0, 1, 0, 2, 0, 3, 1, 0}, {1, 0, 2, 0, 3, 0, 3, 1}, {1, -3, 1, -2, 1, -1, 1, 0}};

    static final int[][] N = {{0, 1, 1, -2, 1, -1, 1, 0}, {1, 0, 1, 1, 2, 1, 3, 1},
    {0, 1, 0, 2, 1, -1, 1, 0}, {1, 0, 2, 0, 2, 1, 3, 1}, {0, 1, 1, 1, 1, 2, 1, 3},
    {1, 0, 2, -1, 2, 0, 3, -1}, {0, 1, 0, 2, 1, 2, 1, 3}, {1, -1, 1, 0, 2, -1, 3, -1}};

    static final int[][] P = {{0, 1, 1, 0, 1, 1, 2, 1}, {0, 1, 0, 2, 1, 0, 1, 1},
    {1, 0, 1, 1, 2, 0, 2, 1}, {0, 1, 1, -1, 1, 0, 1, 1}, {0, 1, 1, 0, 1, 1, 1, 2},
    {1, -1, 1, 0, 2, -1, 2, 0}, {0, 1, 0, 2, 1, 1, 1, 2}, {0, 1, 1, 0, 1, 1, 2, 0}};

    static final int[][] T = {{0, 1, 0, 2, 1, 1, 2, 1}, {1, -2, 1, -1, 1, 0, 2, 0},
    {1, 0, 2, -1, 2, 0, 2, 1}, {1, 0, 1, 1, 1, 2, 2, 0}};

    static final int[][] U = {{0, 1, 0, 2, 1, 0, 1, 2}, {0, 1, 1, 1, 2, 0, 2, 1},
    {0, 2, 1, 0, 1, 1, 1, 2}, {0, 1, 1, 0, 2, 0, 2, 1}};

    static final int[][] V = {{1, 0, 2, 0, 2, 1, 2, 2}, {0, 1, 0, 2, 1, 0, 2, 0},
    {1, 0, 2, -2, 2, -1, 2, 0}, {0, 1, 0, 2, 1, 2, 2, 2}};

    static final int[][] W = {{1, 0, 1, 1, 2, 1, 2, 2}, {1, -1, 1, 0, 2, -2, 2, -1},
    {0, 1, 1, 1, 1, 2, 2, 2}, {0, 1, 1, -1, 1, 0, 2, -1}};

    static final int[][] X = {{1, -1, 1, 0, 1, 1, 2, 0}};

    static final int[][] Y = {{1, -2, 1, -1, 1, 0, 1, 1}, {1, -1, 1, 0, 2, 0, 3, 0},
    {0, 1, 0, 2, 0, 3, 1, 1}, {1, 0, 2, 0, 2, 1, 3, 0}, {0, 1, 0, 2, 0, 3, 1, 2},
    {1, 0, 1, 1, 2, 0, 3, 0}, {1, -1, 1, 0, 1, 1, 1, 2}, {1, 0, 2, -1, 2, 0, 3, 0}};

    static final int[][] Z = {{0, 1, 1, 0, 2, -1, 2, 0}, {1, 0, 1, 1, 1, 2, 2, 2},
    {0, 1, 1, 1, 2, 1, 2, 2}, {1, -2, 1, -1, 1, 0, 2, -2}};

    static final int[][][] shapes = {F, I, L, N, P, T, U, V, W, X, Y, Z};
}


divert(-1)

# 1-based indexing of a string's characters.
define(`get',`substr(`$1',decr(`$2'),1)')
define(`set',`substr(`$1',0,decr(`$2'))`'$3`'substr(`$1',`$2')')
define(`swap',
`pushdef(`_u',`get(`$1',`$2')')`'dnl
pushdef(`_v',`get(`$1',`$3')')`'dnl
set(set(`$1',`$2',_v),`$3',_u)`'dnl
popdef(`_u',`_v')')

# $1-fold repetition of $2.
define(`repeat',`ifelse($1,0,`',`$2`'$0(decr($1),`$2')')')

#
# Heap's algorithm. Algorithm 2 in Robert Sedgewick, 1977. Permutation
# generation methods. ACM Comput. Surv. 9, 2 (June 1977), 137-164.
#
# This implementation permutes the characters in a string of length no
# more than 9. On longer strings, it may strain the resources of a
# very old implementation of m4.
#
define(`permutations',
    `ifelse($2,`',`$1
$0(`$1',repeat(len(`$1'),1),2)',
        `ifelse(eval(($3) <= len(`$1')),1,
             `ifelse(eval(get($2,$3) < $3),1,
                       `swap(`$1',_$0($2,$3),$3)
$0(swap(`$1',_$0($2,$3),$3),set($2,$3,incr(get($2,$3))),2)',
                       `$0(`$1',set($2,$3,1),incr($3))')')')')
define(`_permutations',`eval((($2) % 2) + ((1 - (($2) % 2)) * get($1,$2)))')

divert`'dnl
permutations(`123')
permutations(`abcd')


(***Standard list functions:*)
fold[f_, x_, {}] := x
fold[f_, x_, {h_, t___}] := fold[f, f[x, h], {t}]
insert[L_, x_, n_] := Join[L[[;; n - 1]], {x}, L[[n ;;]]]

(***Generate all permutations of a list S:*)

permutations[S_] :=
 fold[Join @@ (Function[{L},
       Table[insert[L, #2, k + 1], {k, 0, Length[L]}]] /@ #1) &, {{}},
   S]


#!/usr/bin/perl

use strict;  # first open space version
use warnings;

my $size = shift // 8;

sub rotate
  {
  local $_ = shift;
  my $ans = '';
  $ans .= "\n" while s/.$/$ans .= $&; ''/gem;
  $ans;
  }

sub topattern
  {
  local $_ = shift;
  s/.+/ $& . ' ' x ($size - length $&)/ge;
  s/^\s+|\s+\z//g;
  [ tr/ \nA-Z/.. /r, lc tr/ \n/\0/r, substr $_, 0, 1 ]; # pattern, xor-update
  }

my %all;
@all{ " FF\nFF \n F \n", "IIIII\n", "LLLL\nL   \n", "NNN \n  NN\n",
  "PPP\nPP \n", "TTT\n T \n T \n", "UUU\nU U\n", "VVV\nV  \nV  \n",
  "WW \n WW\n  W\n", " X \nXXX\n X \n", "YYYY\n Y  \n", "ZZ \n Z \n ZZ\n",
  } = ();
@all{map rotate($_), keys %all} = () for 1 .. 3;  # all four rotations
@all{map s/.+/reverse $&/ger, keys %all} = ();    # mirror
my @all = map topattern($_), keys %all;
my $grid = ( ' ' x $size . "\n" ) x $size;
my %used;
find( $grid );

sub find
  {
  my $grid = shift;
  %used >= 12 and exit not print $grid;
  for ( grep ! $used{ $_->[2] }, @all )
    {
    my ($pattern, $pentomino, $letter) = @$_;
    local $used{$letter} = 1;
    $grid =~ /^[^ ]*\K$pattern/s and find( $grid ^ "\0" x $-[0] . $pentomino );
    }
  }


next_permutation(v) := block([n, i, j, k, t],
   n: length(v), i: 0,
   for k: n - 1 thru 1 step -1 do (if v[k] < v[k + 1] then (i: k, return())),
   j: i + 1, k: n,
   while j < k do (t: v[j], v[j]: v[k], v[k]: t, j: j + 1, k: k - 1),
   if i = 0 then return(false),
   j: i + 1,
   while v[j] < v[i] do j: j + 1,
   t: v[j], v[j]: v[i], v[i]: t,
   true
)$

print_perm(n) := block([v: makelist(i, i, 1, n)],
   disp(v),
   while next_permutation(v) do disp(v)
)$

print_perm(3);
/* [1, 2, 3]
   [1, 3, 2]
   [2, 1, 3]
   [2, 3, 1]
   [3, 1, 2]
   [3, 2, 1] */


:- module permutations2.
:- interface.

:- import_module io.

:- pred main(io::di, io::uo) is det.

:- import_module list.
:- import_module set_ordlist.
:- import_module set.
:- import_module solutions.

%% permutationSet(List, Set) is true if List is a permutation of Set:
:- pred permutationSet(list(A)::out,set(A)::in) is nondet.

%% Two ways to compute all permutations of a given list (using backtracking):
:- func all_permutations1(list(int))=set_ordlist.set_ordlist(list(int)).
:- func all_permutations2(list(int))=set_ordlist.set_ordlist(list(int)).

:- implementation.

permutationSet([],set.init).
permutationSet([H|T], S) :- set.member(H,S), permutationSet(T,set.delete(S,H)).

all_permutations1(L) =
    solutions_set(pred(X::out) is nondet:-permutationSet(X,set.from_list(L))).

%%Alternatively, using the imported list.perm predicate:
all_permutations2(L) =
    solutions_set(pred(X::out) is nondet:-perm(L,X)).

main(!IO) :-
    print(all_permutations1([1,2,3,4]),!IO),
    nl(!IO),
    print(all_permutations2([1,2,3,4]),!IO).