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

double PI;
typedef double complex cplx;

void _fft(cplx buf[], cplx out[], int n, int step)
{
	if (step < n) {
		_fft(out, buf, n, step * 2);
		_fft(out + step, buf + step, n, step * 2);

		for (int i = 0; i < n; i += 2 * step) {
			cplx t = cexp(-I * PI * i / n) * out[i + step];
			buf[i / 2]     = out[i] + t;
			buf[(i + n)/2] = out[i] - t;
		}
	}
}

void fft(cplx buf[], int n)
{
	cplx out[n];
	for (int i = 0; i < n; i++) out[i] = buf[i];
	_fft(buf, out, n, 1);
}

/* pad array length to power of two */
cplx *pad_two(double g[], int len, int *ns)
{
	int n = 1;
	if (*ns) n = *ns;
	else while (n < len) n *= 2;

	cplx *buf = calloc(sizeof(cplx), n);
	for (int i = 0; i < len; i++) buf[i] = g[i];
	*ns = n;
	return buf;
}

void deconv(double g[], int lg, double f[], int lf, double out[], int row_len) {
	int ns = 0;
	cplx *g2 = pad_two(g, lg, &ns);
	cplx *f2 = pad_two(f, lf, &ns);

	fft(g2, ns);
	fft(f2, ns);

	cplx h[ns];
	for (int i = 0; i < ns; i++) h[i] = g2[i] / f2[i];
	fft(h, ns);

	for (int i = 0; i < ns; i++) {
		if (cabs(creal(h[i])) < 1e-10)
			h[i] = 0;
	}

	for (int i = 0; i > lf - lg - row_len; i--)
		out[-i] = h[(i + ns) % ns]/32;
	free(g2);
	free(f2);
}

double* unpack2(void *m, int rows, int len, int to_len)
{
	double *buf = calloc(sizeof(double), rows * to_len);
	for (int i = 0; i < rows; i++)
		for (int j = 0; j < len; j++)
			buf[i * to_len + j] = ((double(*)[len])m)[i][j];
	return buf;
}

void pack2(double * buf, int rows, int from_len, int to_len, void *out)
{
	for (int i = 0; i < rows; i++)
		for (int j = 0; j < to_len; j++)
			((double(*)[to_len])out)[i][j] = buf[i * from_len + j] / 4;
}

void deconv2(void *g, int row_g, int col_g, void *f, int row_f, int col_f, void *out) {
	double *g2 = unpack2(g, row_g, col_g, col_g);
	double *f2 = unpack2(f, row_f, col_f, col_g);

	double ff[(row_g - row_f + 1) * col_g];
	deconv(g2, row_g * col_g, f2, row_f * col_g, ff, col_g);
	pack2(ff, row_g - row_f + 1, col_g, col_g - col_f + 1, out);

	free(g2);
	free(f2);
}

double* unpack3(void *m, int x, int y, int z, int to_y, int to_z)
{
	double *buf = calloc(sizeof(double), x * to_y * to_z);
	for (int i = 0; i < x; i++)
		for (int j = 0; j < y; j++) {
			for (int k = 0; k < z; k++)
				buf[(i * to_y + j) * to_z + k] =
					((double(*)[y][z])m)[i][j][k];
		}
	return buf;
}

void pack3(double * buf, int x, int y, int z, int to_y, int to_z, void *out)
{
	for (int i = 0; i < x; i++)
		for (int j = 0; j < to_y; j++)
			for (int k = 0; k < to_z; k++)
				((double(*)[to_y][to_z])out)[i][j][k] =
					buf[(i * y + j) * z + k] / 4;
}

void deconv3(void *g, int gx, int gy, int gz, void *f, int fx, int fy, int fz, void *out) {
	double *g2 = unpack3(g, gx, gy, gz, gy, gz);
	double *f2 = unpack3(f, fx, fy, fz, gy, gz);

	double ff[(gx - fx + 1) * gy * gz];
	deconv(g2, gx * gy * gz, f2, fx * gy * gz, ff, gy * gz);
	pack3(ff, gx - fx + 1, gy, gz, gy - fy + 1, gz - fz + 1, out);

	free(g2);
	free(f2);
}

int main()
{
	PI = atan2(1,1) * 4;
	double h[2][3][4] = {
		{{-6, -8, -5,  9}, {-7, 9, -6, -8}, { 2, -7,  9,  8}},
		{{ 7,  4,  4, -6}, { 9, 9,  4, -4}, {-3,  7, -2, -3}}
	};
	int hx = 2, hy = 3, hz = 4;
	double f[3][2][3] = {	{{-9,  5, -8}, { 3,  5,  1}},
				{{-1, -7,  2}, {-5, -6,  6}},
				{{ 8,  5,  8}, {-2, -6, -4}} };
	int fx = 3, fy = 2, fz = 3;
	double g[4][4][6] = {
		{	{ 54,  42,  53, -42,  85, -72}, { 45,-170,  94, -36,  48,  73},
			{-39,  65,-112, -16, -78, -72}, {  6, -11,  -6,  62,  49,   8} },
		{ 	{-57,  49, -23,   52, -135,  66},{-23, 127, -58,   -5, -118,  64},
			{ 87, -16,  121,  23,  -41, -12},{-19,  29,   35,-148,  -11,  45} },
		{	{-55, -147, -146, -31,  55,  60},{-88,  -45,  -28,  46, -26,-144},
			{-12, -107,  -34, 150, 249,  66},{ 11,  -15,  -34,  27, -78, -50} },
		{	{ 56,  67, 108,   4,  2,-48},{ 58,  67,  89,  32, 32, -8},
			{-42, -31,-103, -30,-23, -8},{  6,   4, -26, -10, 26, 12}
		}
	};
	int gx = 4, gy = 4, gz = 6;

	double h2[gx - fx + 1][gy - fy + 1][gz - fz + 1];
	deconv3(g, gx, gy, gz, f, fx, fy, fz, h2);
	printf("deconv3(g, f):\n");
	for (int i = 0; i < gx - fx + 1; i++) {
		for (int j = 0; j < gy - fy + 1; j++) {
			for (int k = 0; k < gz - fz + 1; k++)
				printf("%g ", h2[i][j][k]);
			printf("\n");
		}
		if (i < gx - fx) printf("\n");
	}

	double f2[gx - hx + 1][gy - hy + 1][gz - hz + 1];
	deconv3(g, gx, gy, gz, h, hx, hy, hz, f2);
	printf("\ndeconv3(g, h):\n");
	for (int i = 0; i < gx - hx + 1; i++) {
		for (int j = 0; j < gy - hy + 1; j++) {
			for (int k = 0; k < gz - hz + 1; k++)
				printf("%g ", f2[i][j][k]);
			printf("\n");
		}
		if (i < gx - hx) printf("\n");
	}
}

/* two-D case; since task doesn't require showing it, it's commented out */
/*
int main()
{
	PI = atan2(1,1) * 4;
	double h[][6] = { 	{-8, 1, -7, -2, -9, 4},
				{4, 5, -5, 2, 7, -1},
				{-6, -3, -3, -6, 9, 5} };
	int hr = 3, hc = 6;

	double f[][5] = {	{-5, 2, -2, -6, -7},
				{9, 7, -6, 5, -7},
				{1, -1, 9, 2, -7},
				{5, 9, -9, 2, -5},
				{-8, 5, -2, 8, 5} };
	int fr = 5, fc = 5;
	double g[][10] = {
			{40, -21, 53, 42, 105, 1, 87, 60, 39, -28},
			{-92, -64, 19, -167, -71, -47, 128, -109, 40, -21},
			{58, 85, -93, 37, 101, -14, 5, 37, -76, -56},
			{-90, -135, 60, -125, 68, 53, 223, 4, -36, -48},
			{78, 16, 7, -199, 156, -162, 29, 28, -103, -10},
			{-62, -89, 69, -61, 66, 193, -61, 71, -8, -30},
			{48, -6, 21, -9, -150, -22, -56, 32, 85, 25}	};
	int gr = 7, gc = 10;

	double h2[gr - fr + 1][gc - fc + 1];
	deconv2(g, gr, gc, f, fr, fc, h2);
	for (int i = 0; i < gr - fr + 1; i++) {
		for (int j = 0; j < gc - fc + 1; j++)
			printf(" %g", h2[i][j]);
		printf("\n");
	}

	double f2[gr - hr + 1][gc - hc + 1];
	deconv2(g, gr, gc, h, hr, hc, f2);
	for (int i = 0; i < gr - hr + 1; i++) {
		for (int j = 0; j < gc - hc + 1; j++)
			printf(" %g", f2[i][j]);
		printf("\n");
	}
}*/


import std.stdio, std.conv, std.algorithm, std.numeric, std.range;

class M(T) {
    private size_t[] dim;
    private size_t[] subsize;
    private T[] d;

    this(size_t[] dimension...) pure nothrow {
        setDimension(dimension);
        d[] = 0; // init each  entry to zero;
    }

    M!T dup() {
        auto m = new M!T(dim);
        return m.set1DArray(d);
    }

    M!T setDimension(size_t[] dimension ...) pure nothrow {
        foreach (const e; dimension)
            assert(e > 0, "no zero dimension");
        dim = dimension.dup;
        subsize = dim.dup;
        foreach (immutable i; 0 .. dim.length)
            subsize[i] = reduce!q{a * b}(1, dim[i + 1 .. $]);
        immutable dlength = dim[0] * subsize[0];
        if (d.length != dlength)
            d = new T[dlength];
        return this;
    }

    M!T set1DArray(in T[] t ...) pure nothrow @nogc {
        auto minLen = min(t.length, d.length);
        d[] = 0;
        d[0 .. minLen] = t[0 .. minLen];
        return this;
    }

    size_t[] seq2idx(in size_t seq) const pure nothrow {
        size_t acc = seq, tmp;
        size_t[] idx;
        foreach (immutable e; subsize) {
            idx ~= tmp = acc / e;
            acc = acc - tmp * e; // same as % (mod) e.
        }
        return idx;
    }

    size_t size() const pure nothrow @nogc @property {
        return d.length;
    }

    size_t rank() const pure nothrow @nogc @property {
        return dim.length;
    }

    size_t[] shape() const pure nothrow @property { return dim.dup; }

    T[] raw() const pure nothrow @property { return d.dup; }

    bool checkBound(size_t[] idx ...) const pure nothrow @nogc {
        if (idx.length > dim.length)
            return false;
        foreach (immutable i, immutable dm; idx)
            if (dm >= dim[i])
                return false;
        return true;
    }

    T opIndex(size_t[] idx ...) const pure nothrow @nogc {
        assert(checkBound(idx), "OOPS");
        return d[dotProduct(idx, subsize)];
    }

    T opIndexAssign(T v, size_t[] idx ...) pure nothrow @nogc {
        assert(checkBound(idx), "OOPS");
        d[dotProduct(idx, subsize)] = v;
        return v;
    }

    override bool opEquals(Object o) const pure {
        const rhs = to!(M!T)(o);
        return dim == rhs.dim && d == rhs.d;
    }

    int opApply(int delegate(ref size_t[]) dg) const {
        size_t[] yieldIdx;
        foreach (immutable i; 0 .. d.length) {
            yieldIdx = seq2idx(i);
            if (dg(yieldIdx))
                break;
        }
        return 0;
    }

    int opApply(int delegate(ref size_t[], ref T) dg) {
        size_t idx1d = 0;
        foreach (idx; this) {
            if (dg(idx, d[idx1d++]))
                break;
        }
        return 0;
    }

    // _this_ is h, rhs is f, output g.
    M!T convolute(M!T rhs) const pure nothrow {
        auto dm = dim.dup;
        dm[] += rhs.dim[] - 1;
        M!T m = new M!T(dm); // dm will be reused as m's idx.
        auto bound = m.size;
        foreach (immutable i; 0 .. d.length) {
            auto thisIdx = seq2idx(i);
            foreach (immutable j; 0 .. rhs.d.length) {
                dm[] = thisIdx[] + rhs.seq2idx(j)[];
                immutable midx1d = dotProduct(dm, m.subsize);
                if (midx1d < bound)
                    m.d[midx1d] += d[i] * rhs.d[j];
                else
                    break; // Bound reach, OK to break.
            }
        }
        return m;
    }

    // _this_ is g, rhs is f, output is h.
    M!T deconvolute(M!T rhs) const pure nothrow {
        auto dm = dim.dup;
        foreach (i, e; dm)
            assert(e + 1 > rhs.dim[i],
                   "deconv : dimensions is zero or negative");
        dm[] -= (rhs.dim[] - 1);
        auto m = new M!T(dm); // dm will be reused as rhs' idx.

        foreach (immutable i; 0 .. m.size) {
            auto idx = m.seq2idx(i);
            m.d[i] = this[idx];
            foreach (immutable j; 0 .. i) {
                immutable jdx = m.seq2idx(j);
                dm[] = idx[] - jdx[];
                if (rhs.checkBound(dm))
                    m.d[i] -=  m.d[j] * rhs[dm];
            }
            m.d[i] /= rhs.d[0];
        }
        return m;
    }

    override string toString() const pure { return d.text; }
}

auto fold(T)(T[] arr, ref size_t[] d) pure {
    if (d.length == 0)
        d ~= arr.length;

    static if (is(T U : U[])) { // Is arr an array of arrays?
        assert(arr.length > 0, "no empty dimension");
        d ~= arr[0].length;
        foreach (e; arr)
            assert(e.length == arr[0].length, "Not rectangular");
        return fold(arr.reduce!q{a ~ b}, d);
    } else {
        assert(arr.length == d.reduce!q{a * b}, "Not same size");
        return arr;
    }
}

auto arr2M(T)(T a) pure {
    size_t[] dm;
    auto d = fold(a, dm);
    alias E = ElementType!(typeof(d));
    auto m = new M!E(dm);
    m.set1DArray(d);
    return m;
}

void main() {
    alias Mi = M!int;
    auto hh = [[[-6, -8, -5, 9], [-7, 9, -6, -8], [2, -7, 9, 8]],
               [[7, 4, 4, -6], [9, 9, 4, -4], [-3, 7, -2, -3]]];
    auto ff = [[[-9, 5, -8], [3, 5, 1]],[[-1, -7, 2], [-5, -6, 6]],
               [[8, 5, 8],[-2, -6, -4]]];
    auto h = arr2M(hh);
    auto f = arr2M(ff);

    const g = h.convolute(f);

    writeln("g == f convolute h ? ", g == f.convolute(h));
    writeln("h == g deconv f    ? ", h == g.deconvolute(f));
    writeln("f == g deconv h    ? ", f == g.deconvolute(h));
    writeln("         f = ", f);
    writeln("g deconv h = ", g.deconvolute(h));
}


package main

import (
    "fmt"
    "math"
    "math/cmplx"
)

func fft(buf []complex128, n int) {
    out := make([]complex128, n)
    copy(out, buf)
    fft2(buf, out, n, 1)
}

func fft2(buf, out []complex128, n, step int) {
    if step < n {
        fft2(out, buf, n, step*2)
        fft2(out[step:], buf[step:], n, step*2)
        for j := 0; j < n; j += 2 * step {
            fj, fn := float64(j), float64(n)
            t := cmplx.Exp(-1i*complex(math.Pi, 0)*complex(fj, 0)/complex(fn, 0)) * out[j+step]
            buf[j/2] = out[j] + t
            buf[(j+n)/2] = out[j] - t
        }
    }
}

/* pad slice length to power of two */
func padTwo(g []float64, le int, ns *int) []complex128 {
    n := 1
    if *ns != 0 {
        n = *ns
    } else {
        for n < le {
            n *= 2
        }
    }
    buf := make([]complex128, n)
    for i := 0; i < le; i++ {
        buf[i] = complex(g[i], 0)
    }
    *ns = n
    return buf
}

func deconv(g []float64, lg int, f []float64, lf int, out []float64, rowLe int) {
    ns := 0
    g2 := padTwo(g, lg, &ns)
    f2 := padTwo(f, lf, &ns)
    fft(g2, ns)
    fft(f2, ns)
    h := make([]complex128, ns)
    for i := 0; i < ns; i++ {
        h[i] = g2[i] / f2[i]
    }
    fft(h, ns)
    for i := 0; i < ns; i++ {
        if math.Abs(real(h[i])) < 1e-10 {
            h[i] = 0
        }
    }
    for i := 0; i > lf-lg-rowLe; i-- {
        out[-i] = real(h[(i+ns)%ns] / 32)
    }
}

func unpack2(m [][]float64, rows, le, toLe int) []float64 {
    buf := make([]float64, rows*toLe)
    for i := 0; i < rows; i++ {
        for j := 0; j < le; j++ {
            buf[i*toLe+j] = m[i][j]
        }
    }
    return buf
}

func pack2(buf []float64, rows, fromLe, toLe int, out [][]float64) {
    for i := 0; i < rows; i++ {
        for j := 0; j < toLe; j++ {
            out[i][j] = buf[i*fromLe+j] / 4
        }
    }
}

func deconv2(g [][]float64, rowG, colG int, f [][]float64, rowF, colF int, out [][]float64) {
    g2 := unpack2(g, rowG, colG, colG)
    f2 := unpack2(f, rowF, colF, colG)
    ff := make([]float64, (rowG-rowF+1)*colG)
    deconv(g2, rowG*colG, f2, rowF*colG, ff, colG)
    pack2(ff, rowG-rowF+1, colG, colG-colF+1, out)
}

func unpack3(m [][][]float64, x, y, z, toY, toZ int) []float64 {
    buf := make([]float64, x*toY*toZ)
    for i := 0; i < x; i++ {
        for j := 0; j < y; j++ {
            for k := 0; k < z; k++ {
                buf[(i*toY+j)*toZ+k] = m[i][j][k]
            }
        }
    }
    return buf
}

func pack3(buf []float64, x, y, z, toY, toZ int, out [][][]float64) {
    for i := 0; i < x; i++ {
        for j := 0; j < toY; j++ {
            for k := 0; k < toZ; k++ {
                out[i][j][k] = buf[(i*y+j)*z+k] / 4
            }
        }
    }
}

func deconv3(g [][][]float64, gx, gy, gz int, f [][][]float64, fx, fy, fz int, out [][][]float64) {
    g2 := unpack3(g, gx, gy, gz, gy, gz)
    f2 := unpack3(f, fx, fy, fz, gy, gz)
    ff := make([]float64, (gx-fx+1)*gy*gz)
    deconv(g2, gx*gy*gz, f2, fx*gy*gz, ff, gy*gz)
    pack3(ff, gx-fx+1, gy, gz, gy-fy+1, gz-fz+1, out)
}

func main() {
    f := [][][]float64{
        {{-9, 5, -8}, {3, 5, 1}},
        {{-1, -7, 2}, {-5, -6, 6}},
        {{8, 5, 8}, {-2, -6, -4}},
    }
    fx, fy, fz := len(f), len(f[0]), len(f[0][0])

    g := [][][]float64{
        {{54, 42, 53, -42, 85, -72}, {45, -170, 94, -36, 48, 73},
            {-39, 65, -112, -16, -78, -72}, {6, -11, -6, 62, 49, 8}},
        {{-57, 49, -23, 52, -135, 66}, {-23, 127, -58, -5, -118, 64},
            {87, -16, 121, 23, -41, -12}, {-19, 29, 35, -148, -11, 45}},
        {{-55, -147, -146, -31, 55, 60}, {-88, -45, -28, 46, -26, -144},
            {-12, -107, -34, 150, 249, 66}, {11, -15, -34, 27, -78, -50}},
        {{56, 67, 108, 4, 2, -48}, {58, 67, 89, 32, 32, -8},
            {-42, -31, -103, -30, -23, -8}, {6, 4, -26, -10, 26, 12},
        },
    }
    gx, gy, gz := len(g), len(g[0]), len(g[0][0])

    h := [][][]float64{
        {{-6, -8, -5, 9}, {-7, 9, -6, -8}, {2, -7, 9, 8}},
        {{7, 4, 4, -6}, {9, 9, 4, -4}, {-3, 7, -2, -3}},
    }
    hx, hy, hz := gx-fx+1, gy-fy+1, gz-fz+1

    h2 := make([][][]float64, hx)
    for i := 0; i < hx; i++ {
        h2[i] = make([][]float64, hy)
        for j := 0; j < hy; j++ {
            h2[i][j] = make([]float64, hz)
        }
    }
    deconv3(g, gx, gy, gz, f, fx, fy, fz, h2)
    fmt.Println("deconv3(g, f):\n")
    for i := 0; i < hx; i++ {
        for j := 0; j < hy; j++ {
            for k := 0; k < hz; k++ {
                fmt.Printf("% .10g  ", h2[i][j][k])
            }
            fmt.Println()
        }
        if i < hx-1 {
            fmt.Println()
        }
    }

    kx, ky, kz := gx-hx+1, gy-hy+1, gz-hz+1
    f2 := make([][][]float64, kx)
    for i := 0; i < kx; i++ {
        f2[i] = make([][]float64, ky)
        for j := 0; j < ky; j++ {
            f2[i][j] = make([]float64, kz)
        }
    }
    deconv3(g, gx, gy, gz, h, hx, hy, hz, f2)
    fmt.Println("\ndeconv(g, h):\n")
    for i := 0; i < kx; i++ {
        for j := 0; j < ky; j++ {
            for k := 0; k < kz; k++ {
                fmt.Printf("% .10g  ", f2[i][j][k])
            }
            fmt.Println()
        }
        if i < kx-1 {
            fmt.Println()
        }
    }
}


use feature 'say';
use ntheory qw/forsetproduct/;

# Deconvolution of N dimensional matrices
sub deconvolve_N {
    our @g; local *g = shift;
    our @f; local *f = shift;
    my @df = shape(@f);
    my @dg = shape(@g);
    my @hsize;
    push @hsize, $dg[$_] - $df[$_] + 1 for 0..$#df;
    my @toSolve = map { [row(\@g, \@f, \@hsize, $_)] } coords(shape(@g));
    rref( \@toSolve );

    my @h;
    my $n = 0;
    for (coords(@hsize)) {
        my($k,$j,$i) = split ' ', $_;
        $h[$i][$j][$k] = $toSolve[$n++][-1];
    }
    @h;
}

sub row {
    our @g;      local *g      = shift;
    our @f;      local *f      = shift;
    our @hsize;  local *hsize  = shift;
    my @gc = reverse split ' ', shift;

    my @row;
    my @fdim = shape(@f);
    for (coords(@hsize)) {
        my @hc = reverse split ' ', $_;
        my @fc;
        for my $i (0..$#hc) {
            my $window = $gc[$i] - $hc[$i];
            push(@fc, $window), next if 0 <= $window && $window < $fdim[$i];
        }
        push @row, $#fc == $#hc ? $f [$fc[0]] [$fc[1]] [$fc[2]] : 0;
    }
    push @row, $g [$gc[0]] [$gc[1]] [$gc[2]];
    return @row;
}

sub rref {
  our @m; local *m = shift;
  @m or return;
  my ($lead, $rows, $cols) = (0, scalar(@m), scalar(@{$m[0]}));

  foreach my $r (0 .. $rows - 1) {
     $lead < $cols or return;
      my $i = $r;

      until ($m[$i][$lead])
         {++$i == $rows or next;
          $i = $r;
          ++$lead == $cols and return;}

      @m[$i, $r] = @m[$r, $i];
      my $lv = $m[$r][$lead];
      $_ /= $lv foreach @{ $m[$r] };

      my @mr = @{ $m[$r] };
      foreach my $i (0 .. $rows - 1)
         {$i == $r and next;
          ($lv, my $n) = ($m[$i][$lead], -1);
          $_ -= $lv * $mr[++$n] foreach @{ $m[$i] };}

      ++$lead;}
}

# Constructs an AoA of coordinates to all elements of N dimensional array
sub coords {
    my(@dimensions) = reverse @_;
    my(@ranges,@coords);
    push @ranges, [0..$_-1] for @dimensions;
    forsetproduct { push @coords, "@_" } @ranges;
    @coords;
}

sub shape {
    my(@dim);
    push @dim, scalar @_;
    push @dim, shape(@{$_[0]}) if 'ARRAY' eq ref $_[0];
    @dim;
}

# Pretty printer for N dimensional arrays
# Assumes if first element in level is an array, then all are
sub pretty_print {
    my($i, @a) = @_;
    if ('ARRAY' eq ref $a[0]) {
        say ' 'x$i, '[';
        pretty_print($i+2, @$_) for @a;
        say ' 'x$i, ']', $i ? ',' : '';
    } else {
        say ' 'x$i, '[', sprintf("@{['%5s'[email protected]]}",@a), ']', $i ? ',' : '';
    }
}

my @f = (
  [
    [ -9,  5, -8 ],
    [  3,  5,  1 ],
  ],
  [
    [ -1, -7,  2 ],
    [ -5, -6,  6 ],
  ],
  [
    [  8,  5,  8 ],
    [ -2, -6, -4 ],
  ]
);

my @g = (
  [
    [  54,  42,  53, -42,  85, -72 ],
    [  45,-170,  94, -36,  48,  73 ],
    [ -39,  65,-112, -16, -78, -72 ],
    [   6, -11,  -6,  62,  49,   8 ],
  ],
  [
    [ -57,  49, -23,  52,-135,  66 ],
    [ -23, 127, -58,  -5,-118,  64 ],
    [  87, -16, 121,  23, -41, -12 ],
    [ -19,  29,  35,-148, -11,  45 ],
  ],
  [
    [ -55,-147,-146, -31,  55,  60 ],
    [ -88, -45, -28,  46, -26,-144 ],
    [ -12,-107, -34, 150, 249,  66 ],
    [  11, -15, -34,  27, -78, -50 ],
  ],
  [
    [  56,  67, 108,   4,   2, -48 ],
    [  58,  67,  89,  32,  32,  -8 ],
    [ -42, -31,-103, -30, -23,  -8 ],
    [   6,   4, -26, -10,  26,  12 ],
  ]
);

my @h  = deconvolve_N( \@g, \@f );
my @ff = deconvolve_N( \@g, \@h );

my $d = scalar shape(@g);
print "${d}D arrays:\n";
print "h =\n";
pretty_print(0,@h);
print "\nff =\n";
pretty_print(0,@ff);


-- demo\rosetta\Deconvolution.exw
with javascript_semantics
function m_size(sequence m)
--
-- returns the size of a matrix as a list of lengths
--
    sequence res = {}
    object me = m
    while sequence(me) do
        res &= length(me)
        me = me[1]
    end while
    return res
end function

function make_coordset(sequence size)
--
-- returns all points in the matrix, in zero-based indexes,
-- eg {{0,0,0}..{3,3,5}} for a 4x4x6 matrix [96 in total]
--
    sequence res = {}
    integer count = product(size)
    for i=0 to count-1 do
        sequence coords = {}
        integer j = i
        for s=length(size) to 1 by -1 do
            integer dimension = size[s]
            coords &= mod(j,dimension)
            j = floor(j/dimension)
        end for
        coords = reverse(coords)
        res = append(res,coords)
    end for
    return res
end function

function row(sequence g, f, gs, gc, fs, hs)
--
--# Assembles a row, which is one of the simultaneous equations that needs
--# to be solved by reducing the whole set to reduced row echelon form. Note
--# that each row describes the equation for a single cell of the 'g' function.
--#
--# Arguments:
--# g   The "result" matrix of the convolution being undone.
--# h   The known "input" matrix of the convolution being undone.
--# gs  The size descriptor of 'g', passed as argument for efficiency.
--# gc  The coordinate in 'g' that we are generating the equation for.
--# fs  The size descriptor of 'f', passed as argument for efficiency.
--# hs  The size descriptor of 'h' (the unknown "input" matrix), passed
--#     as argument for efficiency.
--
    sequence row = {},
             coords = make_coordset(hs)
    for i=1 to length(coords) do
        sequence hc = coords[i]
        object fn = f
        for k=1 to length(gc) do
            integer d = gc[k]-hc[k]
            if d<0 or d>=fs[k] then
                fn = 0
                exit
            end if
            fn = fn[d+1]
        end for
        row = append(row,fn)
    end for
    object gn = g
    for i=1 to length(gc) do
        gn = gn[gc[i]+1]
    end for
    row = append(row,gn)
    return row
end function

function toRREF(sequence m)
--
-- [renamed] copy of Reduced_row_echelon_form.htm#Phix
-- plus one small tweak, as noted below, exit->return,
-- not that said seems to make any actual difference.
--
integer lead = 1,
        rows = length(m),
        cols = length(m[1])
    m = deep_copy(m)
    for r=1 to rows do
        if lead>=cols then exit end if
        integer i = r
        while m[i][lead]=0 do
            i += 1
            if i=rows then
                i = r
                lead += 1
--              if lead=cols then exit end if
                if lead=cols then return m end if
            end if
        end while
        sequence mi = deep_copy(m[r]),
                 mr = sq_div(m[i],m[i][lead])
        m[i] = mi
        m[r] = mr
        for j=1 to rows do
            if j!=r then
                m[j] = sq_sub(m[j],sq_mul(m[j][lead],m[r]))
            end if
        end for
        lead += 1
    end for
    return m
end function

function lset(sequence h, sequence idx, object v)
-- helper routine: store v somewhere deep inside h
    h = deep_copy(h)
    integer i1 = idx[1]+1
    if length(idx)=1 then
        h[i1] = v
    else
        h[i1] = lset(h[i1],idx[2..$],v)
    end if
    return h
end function

function deconvolve(sequence g, f)
--
--# Deconvolve a pair of matrixes. Solves for 'h' such that 'g = f convolve h'.
--#
--# Arguments:
--# g     The matrix of data to be deconvolved.
--# f     The matrix describing the convolution to be removed.
--
    -- Compute the sizes of the various matrixes involved.
    sequence gsize = m_size(g),
             fsize = m_size(f),
             hsize = sq_add(sq_sub(gsize,fsize),1)

    -- Prepare the set of simultaneous equations to solve
    sequence toSolve = {},
             coords = make_coordset(gsize)
    for i=1 to length(coords) do
        toSolve = append(toSolve,row(g,f,gsize,coords[i],fsize,hsize))
    end for

    -- Solve the equations
    sequence solved = toRREF(toSolve)

    -- Create a result matrix of the right size
    object h = 0
    for i=length(hsize) to 1 by -1 do
        h = repeat(h,hsize[i])
    end for

    -- Fill the results from the equations into the result matrix
    coords = make_coordset(hsize)
    for i=1 to length(coords) do
        h = lset(h,coords[i],solved[i][$])
    end for
    return h
end function

constant f1 = { 6, -9, -7, -5},
         g1 = {-48, 84, -16, 95, 125, -70, 7, 29, 54, 10},
         h1 = {-8, 2, -9, -2, 9, -8, -2}

if deconvolve(g1, f1)!=h1 then ?9/0 end if
if deconvolve(g1, h1)!=f1 then ?9/0 end if

constant f2 = {{-5, 2,-2,-6,-7},
               { 9, 7,-6, 5,-7},
               { 1,-1, 9, 2,-7},
               { 5, 9,-9, 2,-5},
               {-8, 5,-2, 8, 5}},
         g2 = {{ 40, -21, 53,  42, 105,   1,  87,  60,  39, -28},
               {-92, -64, 19,-167, -71, -47, 128,-109,  40, -21},
               { 58,  85,-93,  37, 101, -14,   5,  37, -76, -56},
               {-90,-135, 60,-125,  68,  53, 223,   4, -36, -48},
               { 78,  16,  7,-199, 156,-162,  29,  28,-103, -10},
               {-62, -89, 69, -61,  66, 193, -61,  71,  -8, -30},
               { 48,  -6, 21,  -9,-150, -22, -56,  32,  85,  25}},
         h2 = {{-8, 1,-7,-2,-9, 4},
               { 4, 5,-5, 2, 7,-1},
               {-6,-3,-3,-6, 9, 5}}

if deconvolve(g2, f2)!=h2 then ?9/0 end if
if deconvolve(g2, h2)!=f2 then ?9/0 end if

constant f3 = {{{-9,  5, -8}, { 3,  5,  1}},
               {{-1, -7,  2}, {-5, -6,  6}},
               {{ 8,  5,  8}, {-2, -6, -4}}},
         g3 = {{{ 54,  42,  53, -42,  85, -72},
                { 45,-170,  94, -36,  48,  73},
                {-39,  65,-112, -16, -78, -72},
                {  6, -11,  -6,  62,  49,   8}},
               {{-57,  49, -23,  52,-135,  66},
                {-23, 127, -58,  -5,-118,  64},
                { 87, -16, 121,  23, -41, -12},
                {-19,  29,  35,-148, -11,  45}},
               {{-55,-147,-146, -31,  55,  60},
                {-88, -45, -28,  46, -26,-144},
                {-12,-107, -34, 150, 249,  66},
                { 11, -15, -34,  27, -78, -50}},
               {{ 56,  67, 108,   4,   2, -48},
                { 58,  67,  89,  32,  32,  -8},
                {-42, -31,-103, -30, -23,  -8},
                {  6,   4, -26, -10,  26,  12}}},
         h3 = {{{ -6, -8, -5,  9},
                { -7,  9, -6, -8},
                {  2, -7,  9,  8}},
               {{  7,  4,  4, -6},
                {  9,  9,  4, -4},
                { -3,  7, -2, -3}}}

if deconvolve(g3, f3)!=h3 then ?9/0 end if
if deconvolve(g3, h3)!=f3 then ?9/0 end if

ppOpt({pp_Nest,2,pp_IntFmt,"%3d"})
pp(deconvolve(g3, f3))
pp(deconvolve(g3, h3))


"""

https://rosettacode.org/wiki/Deconvolution/2D%2B

Working on 3 dimensional example using test data from the
RC task.

Python fft:

https://docs.scipy.org/doc/numpy/reference/routines.fft.html

"""

import numpy
import pprint

h =  [
      [[-6, -8, -5, 9], [-7, 9, -6, -8], [2, -7, 9, 8]],
      [[7, 4, 4, -6], [9, 9, 4, -4], [-3, 7, -2, -3]]]
f =  [
      [[-9, 5, -8], [3, 5, 1]],
      [[-1, -7, 2], [-5, -6, 6]],
      [[8, 5, 8],[-2, -6, -4]]]
g =  [
      [
         [54, 42, 53, -42, 85, -72],
         [45, -170, 94, -36, 48, 73],
         [-39, 65, -112, -16, -78, -72],
         [6, -11, -6, 62, 49, 8]],
      [
         [-57, 49, -23, 52, -135, 66],
         [-23, 127, -58, -5, -118, 64],
         [87, -16, 121, 23, -41, -12],
         [-19, 29, 35, -148, -11, 45]],
      [
         [-55, -147, -146, -31, 55, 60],
         [-88, -45, -28, 46, -26, -144],
         [-12, -107, -34, 150, 249, 66],
         [11, -15, -34, 27, -78, -50]],
      [
         [56, 67, 108, 4, 2, -48],
         [58, 67, 89, 32, 32, -8],
         [-42, -31, -103, -30, -23, -8],
         [6, 4, -26, -10, 26, 12]]]

def trim_zero_empty(x):
    """

    Takes a structure that represents an n dimensional example.
    For a 2 dimensional example it will be a list of lists.
    For a 3 dimensional one it will be a list of list of lists.
    etc.

    Actually these are multidimensional numpy arrays but I was thinking
    in terms of lists.

    Returns the same structure without trailing zeros in the inner
    lists and leaves out inner lists with all zeros.

    """

    if len(x) > 0:
        if type(x[0]) != numpy.ndarray:
            # x is 1d array
            return list(numpy.trim_zeros(x))
        else:
            # x is a multidimentional array
            new_x = []
            for l in x:
               tl = trim_zero_empty(l)
               if len(tl) > 0:
                   new_x.append(tl)
            return new_x
    else:
        # x is empty list
        return x

def deconv(a, b):
    """

    Returns function c such that b * c = a.

    https://en.wikipedia.org/wiki/Deconvolution

    """

    # Convert larger polynomial using fft

    ffta = numpy.fft.fftn(a)

    # Get it's shape so fftn will expand
    # smaller polynomial to fit.

    ashape = numpy.shape(a)

    # Convert smaller polynomial with fft
    # using the shape of the larger one

    fftb = numpy.fft.fftn(b,ashape)

    # Divide the two in frequency domain

    fftquotient = ffta / fftb

    # Convert back to polynomial coefficients using ifft
    # Should give c but with some small extra components

    c = numpy.fft.ifftn(fftquotient)

    # Get rid of imaginary part and round up to 6 decimals
    # to get rid of small real components

    trimmedc = numpy.around(numpy.real(c),decimals=6)

    # Trim zeros and eliminate
    # empty rows of coefficients

    cleanc = trim_zero_empty(trimmedc)

    return cleanc

print("deconv(g,h)=")

pprint.pprint(deconv(g,h))

print(" ")

print("deconv(g,f)=")

pprint.pprint(deconv(g,f))


# Deconvolution of N dimensional matrices.
sub deconvolve-N ( @g, @f ) {
    my @hsize = @g.shape »-« @f.shape »+» 1;

    my @toSolve = coords(@g.shape).map:
      { [row(@g, @f, $^coords, @hsize)] };

    my @solved = rref( @toSolve );

    my @h;
    for flat coords(@hsize) Z @solved[*;*-1] -> $_, $v {
        @h.AT-POS(|$_) = $v;
    }
    @h
}

# Construct a row for each value in @g to be sent to the simultaneous equation solver
sub row ( @g, @f, @gcoord, $hsize ) {
    my @row;
    @gcoord = @gcoord[(^@f.shape)]; # clip extraneous values
    for coords( $hsize ) -> @hc {
        my @fcoord;
        for ^@hc -> $i {
            my $window = @gcoord[$i] - @hc[$i];
            @fcoord.push($window) and next if 0 ≤ $window < @f.shape[$i];
            last;
        }
        @row.push: @fcoord == @hc ?? @f.AT-POS(|@fcoord) !! 0;
    }
    @row.push: @g.AT-POS(|@gcoord);
    @row
}

# Constructs an AoA of coordinates to all elements of N dimensional array
sub coords ( @dim ) {
    @[reverse $_ for [X] ([^$_] for reverse @dim)]
}

# Reduced Row Echelon Form simultaneous equation solver
# Can handle over-specified systems (N unknowns in N + M equations)
sub rref (@m) {
    @m = trim-system @m;
    my ($lead, $rows, $cols) = 0, @m, @m[0];
    for ^$rows -> $r {
        return @m unless $lead < $cols;
        my $i = $r;
        until @m[$i;$lead] {
            next unless ++$i == $rows;
            $i = $r;
            return @m if ++$lead == $cols;
        }
        @m[$i, $r] = @m[$r, $i] if $r != $i;
        @m[$r] »/=» $ = @m[$r;$lead];
        for ^$rows -> $n {
            next if $n == $r;
            @m[$n] »-=» @m[$r] »×» (@m[$n;$lead] // 0);
        }
        ++$lead;
    }
    @m
 }

# Reduce to N equations in N unknowns; a no-op unless rows > cols
sub trim-system (@m) {
    return @m unless @m ≥ @m[0];
    my (\vars, @t) = @m[0] - 1;
    for ^vars -> \lead {
        for ^@m -> \row {
            @t.append: @m.splice(row, 1) and last if @m[row;lead];
        }
    }
    while @t < vars and @m { @t.push: shift @m }
    @t
}

# Pretty printer for N dimensional arrays
# Assumes if first element in level is an array, then all are
sub pretty-print ( @array, $indent = 0 ) {
    if @array[0] ~~ Array {
        say ' ' x $indent,"[";
        pretty-print( $_, $indent + 2 ) for @array;
        say ' ' x $indent, "]{$indent??','!!''}";
    } else {
        say ' ' x $indent, "[{say_it(@array)} ]{$indent??','!!''}";
    }

    sub say_it ( @array ) { return join ",", @array».fmt("%4s"); }
}

my @f[3;2;3] = (
  [
    [ -9,  5, -8 ],
    [  3,  5,  1 ],
  ],
  [
    [ -1, -7,  2 ],
    [ -5, -6,  6 ],
  ],
  [
    [  8,  5,  8 ],
    [ -2, -6, -4 ],
  ]
);

my @g[4;4;6] = (
  [
    [  54,  42,  53, -42,  85, -72 ],
    [  45,-170,  94, -36,  48,  73 ],
    [ -39,  65,-112, -16, -78, -72 ],
    [   6, -11,  -6,  62,  49,   8 ],
  ],
  [
    [ -57,  49, -23,  52,-135,  66 ],
    [ -23, 127, -58,  -5,-118,  64 ],
    [  87, -16, 121,  23, -41, -12 ],
    [ -19,  29,  35,-148, -11,  45 ],
  ],
  [
    [ -55,-147,-146, -31,  55,  60 ],
    [ -88, -45, -28,  46, -26,-144 ],
    [ -12,-107, -34, 150, 249,  66 ],
    [  11, -15, -34,  27, -78, -50 ],
  ],
  [
    [  56,  67, 108,   4,   2, -48 ],
    [  58,  67,  89,  32,  32,  -8 ],
    [ -42, -31,-103, -30, -23,  -8 ],
    [   6,   4, -26, -10,  26,  12 ],
  ]
);

say "# {[email protected]}D array:";
my @h = deconvolve-N( @g, @f );
say "h =";
pretty-print( @h );
my @h-shaped[2;3;4] = @(deconvolve-N( @g, @f ));
my @ff = deconvolve-N( @g, @h-shaped );
say "\nff =";
pretty-print( @ff );


package require Tcl 8.5
namespace path {::tcl::mathfunc ::tcl::mathop}

# Utility to extract the number of dimensions of a matrix
proc rank m {
    for {set rank 0} {[llength $m] > 1} {incr rank} {
	set m [lindex $m 0]
    }
    return $rank
}

# Utility to get the size of a matrix, as a list of lengths
proc size m {
    set r [rank $m]
    set index {}
    set size {}
    for {set i 0} {$i<$r} {incr i} {
	lappend size [llength [lindex $m $index]]
	lappend index 0
    }
    return $size
}

# Utility that iterates over the space of coordinates within a matrix.
#
# Arguments:
#   var   The name of the variable (in the caller's context) to set to each
#         coordinate.
#   size  The size of matrix whose coordinates are to be iterated over.
#   body  The script to evaluate (in the caller's context) for each coordinate,
#         with the variable named by 'var' set to the coordinate for the particular
#         iteration.
proc loopcoords {var size body} {
    upvar 1 $var v
    set count [* {*}$size]
    for {set i 0} {$i < $count} {incr i} {
	set coords {}
	set j $i
	for {set s $size} {[llength $s]} {set s [lrange $s 0 end-1]} {
	    set dimension [lindex $s end]
	    lappend coords [expr {$j % $dimension}]
	    set j [expr {$j / $dimension}]
	}
	set v [lreverse $coords]
	uplevel 1 $body
    }
}

# Assembles a row, which is one of the simultaneous equations that needs
# to be solved by reducing the whole set to reduced row echelon form. Note
# that each row describes the equation for a single cell of the 'g' function.
#
# Arguments:
#   g	The "result" matrix of the convolution being undone.
#   h	The known "input" matrix of the convolution being undone.
#   gs	The size descriptor of 'g', passed as argument for efficiency.
#   gc	The coordinate in 'g' that we are generating the equation for.
#   fs	The size descriptor of 'f', passed as argument for efficiency.
#   hs	The size descriptor of 'h' (the unknown "input" matrix), passed
#	as argument for efficiency.
proc row {g f gs gc fs hs} {
    loopcoords hc $hs {
	set fc {}
	set ok 1
	foreach a $gc b $fs c $hc {
	    set d [expr {$a - $c}]
	    if {$d < 0 || $d >= $b} {
		set ok 0
		break
	    }
	    lappend fc $d
	}
	if {$ok} {
	    lappend row [lindex $f $fc]
	} else {
	    lappend row 0
	}
    }
    return [lappend row [lindex $g $gc]]
}

# Utility for converting a matrix to Reduced Row Echelon Form
# From http://rosettacode.org/wiki/Reduced_row_echelon_form#Tcl
proc toRREF {m} {
    set lead 0
    set rows [llength $m]
    set cols [llength [lindex $m 0]]
    for {set r 0} {$r < $rows} {incr r} {
	if {$cols <= $lead} {
	    break
	}
	set i $r
	while {[lindex $m $i $lead] == 0} {
	    incr i
	    if {$rows == $i} {
		set i $r
		incr lead
		if {$cols == $lead} {
		    # Tcl can't break out of nested loops
		    return $m
		}
	    }
	}
	# swap rows i and r
	foreach j [list $i $r] row [list [lindex $m $r] [lindex $m $i]] {
	    lset m $j $row
	}
	# divide row r by m(r,lead)
	set val [lindex $m $r $lead]
	for {set j 0} {$j < $cols} {incr j} {
	    lset m $r $j [/ [double [lindex $m $r $j]] $val]
	}

	for {set i 0} {$i < $rows} {incr i} {
	    if {$i != $r} {
		# subtract m(i,lead) multiplied by row r from row i
		set val [lindex $m $i $lead]
		for {set j 0} {$j < $cols} {incr j} {
		    lset m $i $j \
			[- [lindex $m $i $j] [* $val [lindex $m $r $j]]]
		}
	    }
	}
	incr lead
    }
    return $m
}

# Deconvolve a pair of matrixes. Solves for 'h' such that 'g = f convolve h'.
#
# Arguments:
#   g     The matrix of data to be deconvolved.
#   f     The matrix describing the convolution to be removed.
#   type  Optional description of the type of data expected. Defaults to 32-bit
#         integer data; use 'double' for floating-point data.
proc deconvolve {g f {type int}} {
    # Compute the sizes of the various matrixes involved.
    set gsize [size $g]
    set fsize [size $f]
    foreach gs $gsize fs $fsize {
	lappend hsize [expr {$gs - $fs + 1}]
    }

    # Prepare the set of simultaneous equations to solve
    set toSolve {}
    loopcoords coords $gsize {
	lappend toSolve [row $g $f $gsize $coords $fsize $hsize]
    }

    # Solve the equations
    set solved [toRREF $toSolve]

    # Make a dummy result matrix of the right size
    set h 0
    foreach hs [lreverse $hsize] {set h [lrepeat $hs $h]}

    # Fill the results from the equations into the result matrix
    set idx 0
    loopcoords coords $hsize {
	lset h $coords [$type [lindex $solved $idx end]]
	incr idx
    }

    return $h
}


#import std
#import nat

break = ~&r**+ zipt*+ ~&lh*~+ ~&lzyCPrX|\+ -*^|\~&tK33 :^/~& 0!*t

band = pad0+ ~&rSS+ zipt^*D(~&r,^lrrSPT/~&ltK33tx zipt^/~&r ~&lSNyCK33+ zipp0)^/~&rx ~&B->NlNSPC ~&bt

deconv = # takes a natural number n to the n-dimensional deconvolution function

~&?\math..div! iota; ~&!*; @h|\; (~&al^?\~&ar [email protected])^^(
   ~&B->NlC~&bt*++ [email protected]+ ~~*,
   lapack..dgelsd^^(
      (~&||0.!**+ ~&B^?a\~&[email protected] ^lriFhNSS2iDrlYSK7LS2SL2rQ/~&alt [email protected])^|\~&+ gang,
      @t =>~&l ~&[email protected]))


import "/complex" for Complex
import "/fmt" for Fmt

var fft2 // recursive
fft2 = Fn.new { |buf, out, n, step, start|
    if (step < n) {
        fft2.call(out, buf, n, step*2, start)
        fft2.call(out, buf, n, step*2, start + step)
        var j = 0
        while (j < n) {
            var t = (Complex.imagMinusOne * Num.pi * j / n).exp * out[j+step+start]
            buf[(j/2).floor + start] = out[j+start] + t
            buf[((j+n)/2).floor + start] = out[j+start] - t
            j = j + 2 * step
        }
    }
}

var fft = Fn.new { |buf, n|
    var out = List.filled(n, null)
    for (i in 0...n) out[i] = buf[i]
    fft2.call(buf, out, n, 1, 0)
}

/* pad list length to power of two */
var padTwo = Fn.new { |g, le, nsl|
    var n = 1
    var ns = nsl[0]
    if (ns != 0) {
        n = ns
    } else {
        while (n < le) n = n * 2
    }
    var buf = List.filled(n, Complex.zero)
    for (i in 0...le) buf[i] = Complex.new(g[i], 0)
    nsl[0] = n
    return buf
}

var deconv = Fn.new { |g, lg, f, lf, out, rowLe|
    var ns = 0
    var nsl = [ns]
    var g2 = padTwo.call(g, lg, nsl)
    var f2 = padTwo.call(f, lf, nsl)
    ns = nsl[0]
    fft.call(g2, ns)
    fft.call(f2, ns)
    var h = List.filled(ns, null)
    for (i in 0...ns) h[i] = g2[i] / f2[i]
    fft.call(h, ns)
    for (i in 0...ns) {
        if (h[i].real.abs < 1e-10) h[i] = Complex.zero
    }
    var i = 0
    while (i > lf-lg-rowLe) {
        out[-i] = (h[(i+ns)%ns]/32).real
        i = i - 1
    }
}

var unpack2 = Fn.new { |m, rows, le, toLe|
    var buf = List.filled(rows*toLe, 0)
    for (i in 0...rows) {
        for (j in 0...le) buf[i*toLe+j] = m[i][j]
    }
    return buf
}

var pack2 = Fn.new { |buf, rows, fromLe, toLe, out|
    for (i in 0...rows) {
        for (j in 0...toLe) out[i][j] = buf[i*fromLe+j] / 4
    }
}

var deconv2 = Fn.new { |g, rowG, colG, f, rowF, colF, out|
    var g2 = unpack2.call(g, rowG, colG, colG)
    var f2 = unpack2.call(f, rowF, colF, colG)
    var ff = List.filled((rowG-rowF+1)*colG, 0)
    deconv.call(g2, rowG*colG, f2, rowF*colG, ff, colG)
    pack2.call(ff, rowG-rowF+1, colG, colG-colF+1, out)
}

var unpack3 = Fn.new { |m, x, y, z, toY, toZ|
    var buf = List.filled(x*toY*toZ, 0)
    for (i in 0...x) {
        for (j in 0...y) {
            for (k in 0...z) {
                buf[(i*toY+j)*toZ+k] = m[i][j][k]
            }
        }
    }
    return buf
}

var pack3 = Fn.new { |buf, x, y, z, toY, toZ, out|
    for (i in 0...x) {
        for (j in 0...toY) {
            for (k in 0...toZ) {
                out[i][j][k] = buf[(i*y+j)*z+k] / 4
            }
        }
    }
}

var deconv3 = Fn.new { |g, gx, gy, gz, f, fx, fy, fz, out|
    var g2 = unpack3.call(g, gx, gy, gz, gy, gz)
    var f2 = unpack3.call(f, fx, fy, fz, gy, gz)
    var ff = List.filled((gx-fx+1)*gy*gz, 0)
    deconv.call(g2, gx*gy*gz, f2, fx*gy*gz, ff, gy*gz)
    pack3.call(ff, gx-fx+1, gy, gz, gy-fy+1, gz-fz+1, out)
}

var f = [
    [[-9,  5, -8], [ 3,  5,  1]],
    [[-1, -7,  2], [-5, -6,  6]],
    [[ 8,  5,  8], [-2, -6, -4]]
]
var fx = f.count
var fy = f[0].count
var fz = f[0][0].count

var g = [
    [[ 54, 42, 53, -42, 85, -72], [45, -170, 94, -36, 48, 73],
     [-39, 65, -112, -16, -78, -72], [6, -11, -6, 62, 49,  8]],
    [[-57, 49, -23, 52, -135, 66], [-23, 127, -58, -5, -118, 64],
     [ 87, -16, 121, 23, -41, -12], [-19, 29, 35, -148, -11, 45]],
    [[-55, -147, -146, -31, 55, 60], [-88, -45, -28, 46, -26, -144],
     [-12, -107, -34, 150, 249, 66], [11, -15, -34, 27, -78, -50]],
    [[ 56, 67, 108, 4, 2, -48], [58, 67, 89, 32, 32, -8],
     [-42, -31, -103, -30, -23, -8], [6, 4, -26, -10, 26, 12]]
]

var gx = g.count
var gy = g[0].count
var gz = g[0][0].count

var h = [
    [[-6, -8, -5,  9], [-7, 9, -6, -8], [ 2, -7,  9,  8]],
    [[ 7,  4,  4, -6], [ 9, 9,  4, -4], [-3,  7, -2, -3]]
]

var hx = gx - fx + 1
var hy = gy - fy + 1
var hz = gz - fz + 1

var h2 = List.filled(hx, null)
for (i in 0...hx) {
    h2[i] = List.filled(hy, 0)
    for (j in 0...hy) h2[i][j] = List.filled(hz, 0)
}
deconv3.call(g, gx, gy, gz, f, fx, fy, fz, h2)
System.print("deconv3(g, f):\n")
for (i in 0...hx) {
    for (j in 0...hy) {
        for (k in 0...hz) Fmt.write("$9.6h ", h2[i][j][k])
        System.print()
    }
    if (i < hx-1) System.print()
}

var kx = gx - hx + 1
var ky = gy - hy + 1
var kz = gz - hz + 1
var f2 = List.filled(kx, null)
for (i in 0...kx) {
    f2[i] = List.filled(ky, 0)
    for (j in 0...ky) f2[i][j] = List.filled(kz, 0)
}
deconv3.call(g, gx, gy, gz, h, hx, hy, hz, f2)
System.print("\ndeconv3(g, h):\n")
for (i in 0...kx) {
    for (j in 0...ky) {
        for (k in 0...kz) Fmt.write("$9.6h ", f2[i][j][k])
        System.print()
    }
    if (i < kx-1) System.print()
}


V digits = ‘0123456789’

F deBruijn(k, n)
   V alphabet = :digits[0 .< k]
   V a = [Byte(0)] * (k * n)
   [Byte] seq

   F db(Int t, Int p) -> N
      I t > @n
         I @n % p == 0
            @seq.extend(@a[1 .< p + 1])
      E
         @a[t] = @a[t - p]
         @db(t + 1, p)
         V j = @a[t - p] + 1
         L j < @k
            @a[t] = j [&] F'F
            @db(t + 1, t)
            j++

   db(1, 1)
   V buf = ‘’
   L(i) seq
      buf ‘’= alphabet[i]

   R buf‘’buf[0 .< n - 1]

F validate(db)
   V found = [0] * 10'000
   [String] errs

   L(i) 0 .< db.len - 3
      V s = db[i .< i + 4]
      I s.is_digit()
         found[Int(s)]++

   L(i) 10'000
      I found[i] == 0
         errs [+]= ‘    PIN number #04 missing’.format(i)
      E I found[i] > 1
         errs [+]= ‘    PIN number #04 occurs #. times’.format(i, found[i])

   I errs.empty
      print(‘  No errors found’)
   E
      V pl = I errs.len == 1 {‘’} E ‘s’
      print(‘  ’String(errs.len)‘ error’pl‘ found:’)
      L(err) errs
         print(err)

V db = deBruijn(10, 4)

print(‘The length of the de Bruijn sequence is ’db.len)
print("\nThe first 130 digits of the de Bruijn sequence are: "db[0.<130])
print("\nThe last 130 digits of the de Bruijn sequence are: "db[(len)-130..])

print("\nValidating the deBruijn sequence:")
validate(db)

print("\nValidating the reversed deBruijn sequence:")
validate(reversed(db))

db[4443] = ‘.’
print("\nValidating the overlaid deBruijn sequence:")
validate(db)


bdos:	equ	5	; BDOS entry point
putch:	equ	2	; Write character to console
puts:	equ	9	; Write string to console
	org	100h
	lhld	bdos+1	; Put stack at highest usable address
	sphl
	;;;	Generate de_bruijn(10,4) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
	mvi	c,40	; Zero out a[]
	xra	a
	lxi	d,arr
zloop:	stax	d
	inx	d
	dcr	c
	jnz	zloop
	lxi	h,seq	; H = start of sequence
	lxi	b,0101h	; db(1,1)
	call	db_
	lxi	d,seq	; Allow wrap-around by appending first 3 digits
	mvi	c,3
wrap:	ldax	d	; get one of first digits
	mov	m,a	; store after last digit
	inx	d	; advance pointers
	inx	h
	dcr	c	; do this 3 times
	jnz	wrap
	push	h	; store end of data
	;;;	Print length ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
	lxi	d,slen	; print "Length: "
	call	pstr
	lxi 	d,-seq	; calculate length (-seq+seqEnd)
	dad	d
	call	puthl	; print length
	call	pnl	; print newline
	;;;	Print first and last 130 digits ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
	lxi	d,sfrst	; print "First 130: "
	call	pstr
	lxi 	h,seq	; print first 130 digits
	call	p130
	call	pnl	; print newline
	lxi	d,slast	; print "Last 130: "
	call	pstr
	pop	h	; Get end of sequence
	push	h
	lxi	d,-130	; 130th last digit
	dad	d
	call	p130	; print last 130 digits
	call	pnl
	call	verify	; verify that all numbers are there
	;;;	Reverse and verify ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
	lxi	d,srev	; Print "reversing..."
	call	pstr
	pop	h	; HL = address of last digit
	dcx	h
	push	h	; stack = address of last digit
	lxi	d,seq	; DE = address of first digit
	call	rvrs	; Reverse
	call	verify	; Verify that all numbers are there
	lxi	d,seq	; Then reverse again (restoring it)
	pop	h
	call	rvrs
	;;;	Replace 4444th digit with '.' and verify ;;;;;;;;;;;;;;;;;;;;;;
	lxi	d,s4444
	call	pstr
	mvi	a,'.'
	sta	seq+4444
	call	verify
	rst	0
	;;;	db(t,p); t,p in B,C; end of sequence in HL ;;;;;;;;;;;;;;;;;;;;
db_:	mov	a,b	; if t>n (n=4)
	cpi	5	; t >= n+1
	jc	dbelse
	mov	a,c	; 4%p==0, for p in {1,2,3,4}, is false iff p=3
	cpi	3
	rz		; stop if p=3, i.e. 4%p<>0
	lxi	d,arr+1	; copy P elements to seq forom arr[1..]
dbextn:	ldax	d	; take from a[]
	mov	m,a	; store in sequence
	inx	h	; advance pointers
	inx	d
	dcr	c	; and do this P times
	jnz	dbextn
	ret
dbelse:	mov	a,b	; t - p
	sub	c
	mvi	d,arr/256
	mov	e,a	; a[] is page-aligned for easier indexing
	ldax	d	; get a[t-p]
	mov	e,b	; store in a[t]
	stax	d
	push	b	; keep T and P
	inr	b	; db(t+1, p)
	call	db_
	pop	b	; restore T and P
	mov	a,b	; get a[t-p]
	sub	c
	mvi	d,arr/256
	mov	e,a
	ldax	d	; j = a[t-p]
dbloop:	inr	a	; j++
	cpi	10	; reached K = 10?
	rnc		; then stop
	mvi	d,arr/256
	mov	e,b
	stax	d	; a[t] = j
	push	psw	; keep j
	push	b	; keep t and p
	mov	c,b
	inr	b
	call	db_	; db(t+1, t)
	pop	b	; restore t and p
	pop	psw	; restore j
	jmp	dbloop
	;;;	Verify that all numbers are there ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
verify:	lxi	d,sver	; print "Verifying... "
	call	pstr
	mvi	d,0	; Zero out the flag array
	lxi	b,10000
	lxi	h,val
vzero:	mov	m,d
	inx	h
	dcx	b
	mov	a,b
	ora	c
	jnz	vzero
	lxi	h,seq	; Sequence pointer
donum:	push	h	; Store sequence pointer
	push	h	; Push two copies
	lxi	h,0	; Current 4-digit number
	mvi	c,4	; Number has 4 digits
dgtadd:	mov	d,h	; HL *= 10
	mov	e,l
	dad	h
	dad	h
	dad	d
	dad	h
	xthl		; Get sequence pointer
	mov	a,m	; Get digit
	inx	h	; Advance pointer
	cpi	10	; Valid digit?
	jnc	dinval	; If not, go do next 4-digit number
	xthl		; Back to number
	mov	e,a
	mvi	d,0
	dad	d	; Add digit to number
	dcr	c	; More digits?
	jnz	dgtadd	; Then get digit
	lxi	d,val	; HL is now the current 4-digit number
	dad	d
	inr	m 	; val[HL]++ (we've seen it)
dinval:	pop	h	; Pointer to after last valid digit
	pop	h	; Pointer to start of current number
	inx	h	; Get 4-digit number that starts at next digit
	mov	d,h	; Next pointer in DE
	mov	e,l
	lxi	b,-(seq+10000)	; Are we there yet?
	dad	b
	mov	a,h
	ora	l
	xchg		; Next pointer back in HL
	jnz	donum	; If not done, do next number.
	lxi	h,val	; Done - get start of validation array
	mvi	b,0	; B will be set if one is missing
vnum:	mov	a,m	; Have we seen HL-val?
	ana	a
	jnz	vnext	; If so, do the next number
	push	h	; Otherwise, keep current address,
	lxi	d,-val	; Subtract val (to get the number)
	dad	d
	call	puthl	; Print this number as being missing
	mvi	b,1	; Set B,
	pop 	h	; and then restore the address
vnext:	inx	h	; Increment the number
	push	h
	lxi	d,-(val+10000)	; Are we there yet?
	dad	d
	mov	a,h
	ora	l
	pop	h
	jnz	vnum	; If not, check next number.
	dcr	b	; At the end, if B was not set,
	lxi	d,snone	; print "none missing",
	jnz	pstr
	lxi	d,smiss	; otherwise, print "missing"
	jmp	pstr
	;;;	Subroutines ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
	;;;	reverse memory starting at DE and ending at HL
rvrs:	mov	b,m	; Load [HL]
	ldax	d	; Load [DE]
	mov	m,a	; [HL] = old [DE]
	mov	a,b
	stax	d	; [DE] = old [HL]
	inx	d	; Move bottom pointer upwards,
	dcx	h	; Move top pointer downwards,
	mov	a,d	; D<H = not there yet
	cmp	h
	jc	rvrs
	mov	a,e	; E<L = not there yet
	cmp	l
	jc	rvrs
	ret
	;;;	print number in HL, saving registers
puthl:	push	h	; save registers
	push	d
	push	b
	lxi	b,nbuf	; number buffer pointer
	push	b	; keep it on the stack
dgt:	lxi	b,-10
	lxi	d,-1
dgtdiv:	inx	d	; calculate digit
	dad	b
	jc	dgtdiv
	mvi	a,'0'+10
	add	l
	pop	h	; get pointer from stack
	dcx	h	; go to previous digit
	mov	m,a	; store digit
	push	h 	; put pointer back
	xchg		; are there any more digits?
	mov	a,h
	ora	l
	jnz	dgt	; if so, calculate next digit
	pop	d 	; otherwise, get pointer to first digit
	jmp	pstr_	; and print the resulting string
	;;;	print 130 digits from the sequence, starting at HL
p130:	push	h
	push	d
	push	b
	mvi	b,130	; 130 digits
p130l:	mov	a,m	; get current digit
	adi 	'0'	; make ASCII
	inx	h	; advance pointer
	push	b	; save pointer and counter
	push	h
	mvi	c,putch	; print character
	mov	e,a
	call	bdos
	pop	h	; restore pointer and counter
	pop	b
	dcr	b	; one fewer character left
	jnz	p130l	; if characters left, print next
	jmp	rsreg	; otherwise, restore registers and return
	;;;	print newline
pnl:	lxi	d,snl
	;;;	print string in DE, saving registers
pstr:	push	h	; store registers
	push	d
	push 	b
pstr_:	mvi	c,puts	; print string using CP/M
	call	bdos
rsreg:	pop	b	; restore registers
	pop	d
	pop 	h
	ret
snl:	db	13,10,'$'
slen:	db	'Length: $'
sfrst:	db	'First 130: $'
slast:	db	'Last 130: $'
srev:	db	'Reversing...',13,10,'$'
s4444:	db	'Set seq[4444] to `.`...',13,10,'$'
sver:	db	'Verifying... $'
snone:	db	'none '
smiss:	db	'missing',13,10,'$'
	db	'00000'	; number output buffer
nbuf:	db	' $'
arr:	equ	($/256+1)*256	; Place to store a[] (page-aligned)
val:	equ	arr+40		; Place to store validation flags
seq:	equ	val+10000	; Place to store De Bruijn sequence


putch:	equ	2	; Print character
puts:	equ	9	; Print string
	cpu	8086
	bits	16
section	.text
	org	100h
	;;;	Calculate de_bruijn(10, 4) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
	xor	ax,ax		; zero a[]
	mov	di,arr
	mov	cx,20		; 20 words = 40 bytes
	rep	stosw
	mov	di,seq		; start of sequence
	mov	dx,0101h	; db(1,1)
	call	db_
	mov	si,seq		; Add first 3 to end for wrapping
	mov	cx,3
	rep	movsb
	lea	bp,[di-1]	; Store pointer to last digit in BP
	;;;	Print length ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
	mov	ah,puts		; Print "Length:"
	mov	dx,slen
	int	21h
	mov	ax,di		; Length = end - start
	sub	ax,seq
	call	putax		; Print length
	;;;	Print first and last 130 characters and verify ;;;;;;;;;;;;;;;;
	mov	ah,puts		; Print "First 130..."
	mov	dx,sfrst
	int	21h
	mov	si,seq		; print first 130 digits
	call	p130
	mov	ah,puts		; Print "Last 130..."
	mov	dx,slast
	int 	21h
	mov	si,di		; print last 130 digit
	sub	si,130
	call	p130
	call	verify
	;;;;	Reverse the sequence and verify ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
	mov	ah,puts		; Print "Reversing..."
	mov	dx,srev
	int	21h
	mov	si,seq		; SI = first digit in sequence
	mov	di,bp		; DI = last digit in sequence
	call	rvrs		; Reverse
	call	verify		; Verify
	mov	si,seq		; Reverse again, putting it back
	mov	di,bp
	call	rvrs
	;;;	Set seq[4444] to '.' and verify ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
	mov	ah,puts		; Print "set seq[4444] to '.'"
	mov	dx,s4444
	int	21h
	mov	[seq+4444],byte '.'
	call	verify		; Verify
	ret
	;;;	db(t, p); t=dh p=dl, di=seq ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
db_:	cmp	dh,4		; t>n? (n=4)
	jbe	.els
	cmp	dl,3		; for p in {1,2,3,4}, 4%p==0 iff p=3
	je	.out
	mov	si,arr+1	; add DL=P bytes from a[1..] to sequence
	mov	cl,dl
	xor 	ch,ch
	rep	movsb
	jmp	.out
.els:	xor	bh,bh
	mov	bl,dh
	sub	bl,dl		; t - p
	mov	al,[arr+bx]	; al = a[t-p]
	mov	bl,dh		; t
	mov	[arr+bx],al	; a[t] = al
	push	dx		; keep arguments
	inc	dh		; db(++t,p)
	call	db_
	pop	dx		; restore arguments
	mov	bl,dh		; al = a[t-p]
	sub	bl,dl
	mov	al,[arr+bx]
.loop:	inc	al		; al++
	cmp	al,10		; when al>=k,
	jae	.out		; then stop.
	mov	bl,dh
	mov	[arr+bx],al	; a[t] = j
	push	ax		; keep state
	push	dx
	mov	dl,dh		; db(t+1, t)
	inc	dh
	call	db_
	pop	dx
	pop	ax
	jmp	.loop
.out:	ret
	;;;	Verify that all numbers are there ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
verify:	mov	ah,puts		; Print "verifying..."
	mov	dx,sver
	int	21h
	mov	di,val		; Zero validation array
	mov	cx,5000		; 10000 bytes = 5000 words
	xor	ax,ax
	rep	stosw
	mov	di,val
	mov	si,seq		; Pointer to start of sequence
	mov	cx,6409h	; CH=100 (multiplier), CL=9 (highest digit)
.num:	mov	ax,[si]		; Read first two digits
	cmp	ah,cl		; Check that they are valid
	ja	.inval
	cmp	al,cl
	ja	.inval
	xchg	al,ah		; High digit * 10 + low digit
	aad
	mul	ch		; Multiply by 100 (to add in next two)
	mov	bx,ax
	mov	ax,[si+2]	; Read last two digits
	cmp	ah,cl		; Check that they are valid
	ja	.inval
	cmp	al,cl
	ja	.inval
	xchg	al,ah		; High digit * 10 + low digit
	aad
	add	bx,ax		; BX = final 4-digit number
	inc	byte [di+bx]	; Mark this 4-digit number as seen
.inval:	inc	si		; Next digit
	cmp	si,seq+10000	; Are we at the end yet?
	jne	.num		; If not, do next number
	mov	si,val		; For each number < 10000, check if it's there
	xor	cl,cl		; Will be set if a number is missing
.test:	lodsb			; Do we have this number?
	test	al,al
	jnz	.tnext		; If so, try next number
	mov	ax,si		; Otherwise, print the missing number
	sub	ax,val
	call	putax
	mov	cl,1		; And set CL
.tnext:	cmp	si,val+10000	; Are we at the end yet?
	jne	.test
	test	cl,cl
	mov	dx,smiss	; Print "... missing"
	jnz	.print		; if CL is set
	mov	dx,snone	; or "none missing" otherwise.
.print:	mov	ah,puts
	int	21h
	ret
	;;;	Subroutines ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
	;;;	Print number in AX
putax:	push	ax		; Keep registers we're changing
	push	dx
	push	bx
	push	di
	mov	di,numbuf	; Pointer to number buffer
	mov	bx,10		; Divisor
.digit:	xor	dx,dx		; Divide AX by 10
	div	bx
	add	dl,'0'		; Add '0' to remainder (digit)
	dec	di		; Store digit in buffer
	mov	[di],dl
	test	ax,ax		; Any more digits?
	jnz	.digit		; If so, do next digits
	mov	dx,di		; At the end, print the string
	mov	ah,puts
	int	21h
	pop	di		; Restore registers
	pop	bx
	pop	dx
	pop	ax
	ret
	;;;	Print 130 digits starting at SI
p130:	mov	cx,130		; 130 characters
	mov	ah,putch	; Print characters
.loop:	lodsb			; Get digit
	add	al,'0'		; Make ASCII
	mov	dl,al		; Print digit
	int	21h
	loop 	.loop
	ret
	;;;	Reverse memory starting at SI and ending at DI
rvrs:	mov	al,[si]		; Load [SI],
	mov	ah,[di]		; Load [DI],
	mov	[di],al		; Set [DI] = old [SI]
	mov	[si],ah		; Set [SI] = old [DI]
	inc	si		; Increment bottom pointer
	dec	di		; Decrement top pointer
	cmp	si,di		; If SI >= DI, we're done
	jb	rvrs
	ret
section	.data
slen:	db	'Length: $'
sfrst:	db	13,10,'First 130: $'
slast:	db	13,10,'Last 130: $'
srev:	db	13,10,'Reversing... $'
s4444:	db	13,10,'Set seq[4444] to `.`...$'
sver:	db	13,10,'Verifying... $'
snone:	db	'none '
smiss:	db	'missing.$'
	db	'00000'
numbuf:	db	' $'
section	.bss
arr:	resb	40		; a[]
val:	resb	10000		; validation array
seq:	equ	$


with Ada.Text_IO;              use Ada.Text_IO;
with Ada.Strings.Fixed;        use Ada.Strings;
with Ada.Strings.Unbounded;

procedure De_Bruijn_Sequences is

   function De_Bruijn (K, N : Positive) return String
   is
      use Ada.Strings.Unbounded;

      Alphabet : constant String := "0123456789";

      subtype Decimal is Integer range 0 .. 9;
      type Decimal_Array is array (Natural range <>) of Decimal;

      A   : Decimal_Array (0 .. K * N - 1) := (others => 0);
      Seq : Unbounded_String;

      procedure Db (T, P : Positive) is
      begin
         if T > N then
            if N mod P = 0 then
               for E of A (1 .. P) loop
                  Append (Seq, Alphabet (Alphabet'First + E));
               end loop;
            end if;
         else
            A (T) := A (T - P);
            Db (T + 1, P);
            for J in A (T - P) + 1 .. K - 1 loop
               A (T) := J;
               Db (T + 1, T);
            end loop;
         end if;
      end Db;

   begin
      Db (1, 1);
      return To_String (Seq) & Slice (Seq, 1, N - 1);
   end De_Bruijn;

   function Image (Value : Integer) return String
   is (Fixed.Trim (Value'Image, Left));

   function PIN_Image (Value : Integer) return String
   is (Fixed.Tail (Image (Value), Count => 4, Pad => '0'));

   procedure Validate (Db : String)
   is
      Found  : array (0 .. 9_999) of Natural := (others => 0);
      Errors : Natural := 0;
   begin

      --  Check all strings of 4 consecutive digits within 'db'
      --  to see if all 10,000 combinations occur without duplication.
      for A in Db'First .. Db'Last - 3 loop
         declare
            PIN : String renames Db (A .. A + 4 - 1);
         begin
            if (for all Char of PIN => Char in '0' .. '9') then
               declare
                  N : constant Integer := Integer'Value (PIN);
                  F : Natural renames Found (N);
               begin
                  F := F + 1;
               end;
            end if;
         end;
      end loop;

      for I in 0_000 .. 9_999 loop
         if Found (I) = 0 then
            Put_Line ("  PIN number " & PIN_Image (I) & " missing");
            Errors := Errors + 1;
         elsif Found (I) > 1 then
            Put_Line ("  PIN number " & PIN_Image (I) & " occurs "
                        & Image (Found (I)) & " times");
            Errors := Errors + 1;
         end if;
      end loop;

      case Errors is
         when 0 =>  Put_Line ("  No errors found");
         when 1 =>  Put_Line ("  1 error found");
         when others =>
            Put_Line ("  " & Image (Errors) & " errors found");
      end case;
   end Validate;

   function Backwards (S : String) return String is
      R : String (S'Range);
   begin
      for A in 0 .. S'Length - 1 loop
         R (R'Last - A) := S (S'First + A);
      end loop;
      return R;
   end Backwards;

   DB  : constant String := De_Bruijn (K => 10, N => 4);
   Rev : constant String := Backwards (DB);
   Ovl :          String := DB;
begin
   Put_Line ("The length of the de Bruijn sequence is " & DB'Length'Image);
   New_Line;

   Put_Line ("The first 130 digits of the de Bruijn sequence are: ");
   Put_Line ("  " & Fixed.Head (DB, 130));
   New_Line;

   Put_Line ("The last 130 digits of the de Bruijn sequence are: ");
   Put_Line ("  " & Fixed.Tail (DB, 130));
   New_Line;

   Put_Line ("Validating the deBruijn sequence:");
   Validate (DB);
   New_Line;

   Put_Line ("Validating the reversed deBruijn sequence:");
   Validate (Rev);
   New_Line;

   Ovl (4444) := '.';
   Put_Line ("Validating the overlaid deBruijn sequence:");
   Validate (Ovl);
   New_Line;
end De_Bruijn_Sequences;


10 DEFINT A-Z
20 K = 10: N = 4
30 DIM A(K*N), S(K^N+N), T(5), P(5), V(K^N\8)
40 GOSUB 200
50 PRINT "Length: ",S
60 PRINT "First 130:"
70 FOR I=0 TO 129: PRINT USING "#";S(I);: NEXT
80 PRINT: PRINT "Last 130:"
90 FOR I=S-130 TO S-1: PRINT USING "#";S(I);: NEXT
100 PRINT
110 GOSUB 600
120 PRINT "Reversing...": GOSUB 500: GOSUB 600: GOSUB 500
130 PRINT USING "Replacing 4444'th element (#):";S(4443)
140 S(4443) = -1 : REM 0-indexed, and using integers
150 GOSUB 600
160 END
200 REM Generate De Bruijn sequence given K and N
210 T(R) = 1: P(R) = 1
220 IF T(R) > N GOTO 380
230 A(T(R)) = A(T(R)-P(R))
240 R = R+1
250 T(R) = T(R-1)+1
260 P(R) = P(R-1)
270 GOSUB 220
280 R = R-1
290 FOR J = A(T(R)-P(R))+1 TO K-1
300 A(T(R)) = J
310 R = R+1
320 T(R) = T(R-1)+1
330 P(R) = T(R-1)
340 GOSUB 220
350 R = R-1
355 J = A(T(R))
360 NEXT
370 RETURN
380 IF N MOD P(R) THEN RETURN
390 FOR I = 1 TO P(R)
400 S(S) = A(I)
410 S = S+1
420 NEXT
430 RETURN
500 REM Reverse the sequence
510 FOR I=0 TO S\2
520 J = S(I)
530 S(I) = S(S-I)
540 S(S-I) = J
550 NEXT
560 RETURN
600 REM Validate the sequence (uses bit packing to save memory)
610 PRINT "Validating...";
620 FOR I=0 TO N-1: S(S+I)=S(I): NEXT
630 FOR I=0 TO K^N\8-1: V(I)=0: NEXT
640 FOR I=0 TO S
650 P=0
660 FOR J=0 TO N-1
662 D=S(I+J)
663 IF D<0 GOTO 690
665 P=K*P+D
669 NEXT J
670 X=P\8
680 V(X) = V(X) OR 2^(P AND 7)
690 NEXT I
700 M=1
710 FOR I=0 TO K^N\8-1
720 IF V(I)=255 GOTO 760
730 FOR J=0 TO 7
740 IF (V(I) AND 2^J)=0 THEN M=0: PRINT USING " ####";I*8+J;
750 NEXT
760 NEXT
770 IF M THEN PRINT " none";
780 PRINT " missing."
790 RETURN


using System;
using System.Collections.Generic;
using System.Text;

namespace DeBruijn {
    class Program {
        const string digits = "0123456789";

        static string DeBruijn(int k, int n) {
            var alphabet = digits.Substring(0, k);
            var a = new byte[k * n];
            var seq = new List<byte>();
            void db(int t, int p) {
                if (t > n) {
                    if (n % p == 0) {
                        seq.AddRange(new ArraySegment<byte>(a, 1, p));
                    }
                } else {
                    a[t] = a[t - p];
                    db(t + 1, p);
                    var j = a[t - p] + 1;
                    while (j < k) {
                        a[t] = (byte)j;
                        db(t + 1, t);
                        j++;
                    }
                }
            }
            db(1, 1);
            var buf = new StringBuilder();
            foreach (var i in seq) {
                buf.Append(alphabet[i]);
            }
            var b = buf.ToString();
            return b + b.Substring(0, n - 1);
        }

        static bool AllDigits(string s) {
            foreach (var c in s) {
                if (c < '0' || '9' < c) {
                    return false;
                }
            }
            return true;
        }

        static void Validate(string db) {
            var le = db.Length;
            var found = new int[10_000];
            var errs = new List<string>();
            // Check all strings of 4 consecutive digits within 'db'
            // to see if all 10,000 combinations occur without duplication.
            for (int i = 0; i < le - 3; i++) {
                var s = db.Substring(i, 4);
                if (AllDigits(s)) {
                    int.TryParse(s, out int n);
                    found[n]++;
                }
            }
            for (int i = 0; i < 10_000; i++) {
                if (found[i] == 0) {
                    errs.Add(string.Format("    PIN number {0,4} missing", i));
                } else if (found[i] > 1) {
                    errs.Add(string.Format("    PIN number {0,4} occurs {1} times", i, found[i]));
                }
            }
            var lerr = errs.Count;
            if (lerr == 0) {
                Console.WriteLine("  No errors found");
            } else {
                var pl = lerr == 1 ? "" : "s";
                Console.WriteLine("  {0} error{1} found:", lerr, pl);
                errs.ForEach(Console.WriteLine);
            }
        }

        static string Reverse(string s) {
            char[] arr = s.ToCharArray();
            Array.Reverse(arr);
            return new string(arr);
        }

        static void Main() {
            var db = DeBruijn(10, 4);
            var le = db.Length;

            Console.WriteLine("The length of the de Bruijn sequence is {0}", le);
            Console.WriteLine("\nThe first 130 digits of the de Bruijn sequence are: {0}", db.Substring(0, 130));
            Console.WriteLine("\nThe last 130 digits of the de Bruijn sequence are: {0}", db.Substring(le - 130, 130));

            Console.WriteLine("\nValidating the deBruijn sequence:");
            Validate(db);

            Console.WriteLine("\nValidating the reversed deBruijn sequence:");
            Validate(Reverse(db));

            var bytes = db.ToCharArray();
            bytes[4443] = '.';
            db = new string(bytes);
            Console.WriteLine("\nValidating the overlaid deBruijn sequence:");
            Validate(db);
        }
    }
}


#include <algorithm>
#include <functional>
#include <iostream>
#include <iterator>
#include <string>
#include <sstream>
#include <vector>

typedef unsigned char byte;

std::string deBruijn(int k, int n) {
    std::vector<byte> a(k * n, 0);
    std::vector<byte> seq;

    std::function<void(int, int)> db;
    db = [&](int t, int p) {
        if (t > n) {
            if (n % p == 0) {
                for (int i = 1; i < p + 1; i++) {
                    seq.push_back(a[i]);
                }
            }
        } else {
            a[t] = a[t - p];
            db(t + 1, p);
            auto j = a[t - p] + 1;
            while (j < k) {
                a[t] = j & 0xFF;
                db(t + 1, t);
                j++;
            }
        }
    };

    db(1, 1);
    std::string buf;
    for (auto i : seq) {
        buf.push_back('0' + i);
    }
    return buf + buf.substr(0, n - 1);
}

bool allDigits(std::string s) {
    for (auto c : s) {
        if (c < '0' || '9' < c) {
            return false;
        }
    }
    return true;
}

void validate(std::string db) {
    auto le = db.size();
    std::vector<int> found(10000, 0);
    std::vector<std::string> errs;

    // Check all strings of 4 consecutive digits within 'db'
    // to see if all 10,000 combinations occur without duplication.
    for (size_t i = 0; i < le - 3; i++) {
        auto s = db.substr(i, 4);
        if (allDigits(s)) {
            auto n = stoi(s);
            found[n]++;
        }
    }

    for (int i = 0; i < 10000; i++) {
        if (found[i] == 0) {
            std::stringstream ss;
            ss << "    PIN number " << i << " missing";
            errs.push_back(ss.str());
        } else if (found[i] > 1) {
            std::stringstream ss;
            ss << "    PIN number " << i << " occurs " << found[i] << " times";
            errs.push_back(ss.str());
        }
    }

    if (errs.empty()) {
        std::cout << "  No errors found\n";
    } else {
        auto pl = (errs.size() == 1) ? "" : "s";
        std::cout << "  " << errs.size() << " error" << pl << " found:\n";
        for (auto e : errs) {
            std::cout << e << '\n';
        }
    }
}

int main() {
    std::ostream_iterator<byte> oi(std::cout, "");
    auto db = deBruijn(10, 4);

    std::cout << "The length of the de Bruijn sequence is " << db.size() << "\n\n";
    std::cout << "The first 130 digits of the de Bruijn sequence are: ";
    std::copy_n(db.cbegin(), 130, oi);
    std::cout << "\n\nThe last 130 digits of the de Bruijn sequence are: ";
    std::copy(db.cbegin() + (db.size() - 130), db.cend(), oi);
    std::cout << "\n";

    std::cout << "\nValidating the de Bruijn sequence:\n";
    validate(db);

    std::cout << "\nValidating the reversed de Bruijn sequence:\n";
    auto rdb = db;
    std::reverse(rdb.begin(), rdb.end());
    validate(rdb);

    auto by = db;
    by[4443] = '.';
    std::cout << "\nValidating the overlaid de Bruijn sequence:\n";
    validate(by);

    return 0;
}


% Generate the De Bruijn sequence consisiting of N-digit numbers
de_bruijn = cluster is generate
    rep = null
    own k: int := 0
    own n: int := 0
    own a: array[int] := array[int]$[]
    own seq: array[int] := array[int]$[]

    generate = proc (k_, n_: int) returns (string)
        k := k_
        n := n_
        a := array[int]$fill(0, k*n, 0)
        seq := array[int]$[]
        db(1, 1)
        s: stream := stream$create_output()
        for i: int in array[int]$elements(seq) do
            stream$puts(s, int$unparse(i))
        end
        return(stream$get_contents(s))
    end generate

    db = proc (t, p: int)
        if t>n then
            if n//p = 0 then
                for i: int in int$from_to(1, p) do
                    array[int]$addh(seq, a[i])
                end
            end
        else
            a[t] := a[t - p]
            db(t+1, p)
            for j: int in int$from_to(a[t - p] + 1, k-1) do
                a[t] := j
                db(t + 1, t)
            end
        end
    end db
end de_bruijn

% Reverse a string
reverse = proc (s: string) returns (string)
    r: array[char] := array[char]$predict(1, string$size(s))
    for c: char in string$chars(s) do
        array[char]$addl(r, c)
    end
    return(string$ac2s(r))
end reverse

% Find all missing N-digit values
find_missing = proc (db: string, n: int) returns (sequence[string])
    db := db || string$substr(db, 1, n) % wrap
    missing: array[string] := array[string]$[]
    s: stream := stream$create_output()
    for i: int in int$from_to(0, 10**n-1) do
        %s: stream := stream$create_output()
        stream$reset(s)
        stream$putzero(s, int$unparse(i), n)
        val: string := stream$get_contents(s)
        if string$indexs(val, db) = 0 then
            array[string]$addh(missing, val)
        end
    end
    return(sequence[string]$a2s(missing))
end find_missing

% Report all missing values, or 'none'.
validate = proc (s: stream, db: string, n: int)
    stream$puts(s, "Validating...")
    missing: sequence[string] := find_missing(db, n)
    for v: string in sequence[string]$elements(missing) do
        stream$puts(s, " " || v)
    end
    if sequence[string]$size(missing) = 0 then
        stream$puts(s, " none")
    end
    stream$putl(s, " missing.")
end validate

start_up = proc ()
    po: stream := stream$primary_output()

    % Generate the De Bruijn sequence for 4-digit numbers
    db: string := de_bruijn$generate(10, 4)

    % Report length and first and last digits
    stream$putl(po, "Length: " || int$unparse(string$size(db)))
    stream$putl(po, "First 130 characters:")
    stream$putl(po, string$substr(db, 1, 130))
    stream$putl(po, "Last 130 characters:")
    stream$putl(po, string$substr(db, string$size(db)-130, 130))

    % See if there are any missing values in the sequence
    validate(po, db, 4)

    % Reverse and validate again
    stream$putl(po, "Reversing...")
    validate(po, reverse(db), 4)

    % Replace the 4444'th element with '.' and validate again
    stream$putl(po, "Setting the 4444'th character to '.'...")
    db := string$substr(db, 1, 4443) || "." || string$rest(db, 4445)
    validate(po, db, 4)
end start_up


import std.array;
import std.conv;
import std.format;
import std.range;
import std.stdio;

immutable DIGITS = "0123456789";

string deBruijn(int k, int n) {
    auto alphabet = DIGITS[0..k];
    byte[] a;
    a.length = k * n;
    byte[] seq;

    void db(int t, int p) {
        if (t > n) {
            if (n % p == 0) {
                auto temp = a[1..p + 1];
                seq ~= temp;
            }
        } else {
            a[t] = a[t - p];
            db(t + 1, p);
            auto j = a[t - p] + 1;
            while (j < k) {
                a[t] = cast(byte)(j & 0xFF);
                db(t + 1, t);
                j++;
            }
        }
    }
    db(1, 1);
    string buf;
    foreach (i; seq) {
        buf ~= alphabet[i];
    }

    return buf ~ buf[0 .. n - 1];
}

bool allDigits(string s) {
    foreach (c; s) {
        if (c < '0' || '9' < c) {
            return false;
        }
    }
    return true;
}

void validate(string db) {
    auto le = db.length;
    int[10_000] found;
    string[] errs;
    // Check all strings of 4 consecutive digits within 'db'
    // to see if all 10,000 combinations occur without duplication.
    foreach (i; 0 .. le - 3) {
        auto s = db[i .. i + 4];
        if (allDigits(s)) {
            auto n = s.to!int;
            found[n]++;
        }
    }
    foreach (i; 0 .. 10_000) {
        if (found[i] == 0) {
            errs ~= format("    PIN number %04d missing", i);
        } else if (found[i] > 1) {
            errs ~= format("    PIN number %04d occurs %d times", i, found[i]);
        }
    }
    if (errs.empty) {
        writeln("  No errors found");
    } else {
        auto pl = (errs.length == 1) ? "" : "s";
        writeln("  ", errs.length, " error", pl, " found:");
        writefln("%-(%s\n%)", errs);
    }
}

void main() {
    auto db = deBruijn(10, 4);

    writeln("The length of the de Bruijn sequence is ", db.length);
    writeln("\nThe first 130 digits of the de Bruijn sequence are: ", db[0 .. 130]);
    writeln("\nThe last 130 digits of the de Bruijn sequence are: ", db[$ - 130 .. $]);

    writeln("\nValidating the deBruijn sequence:");
    validate(db);

    writeln("\nValidating the reversed deBruijn sequence:");
    validate(db.retro.to!string);

    auto by = db.dup;
    by[4443] = '.';
    db = by.idup;
    writeln("\nValidating the overlaid deBruijn sequence:");
    validate(db);
}


package main

import (
    "bytes"
    "fmt"
    "strconv"
    "strings"
)

const digits = "0123456789"

func deBruijn(k, n int) string {
    alphabet := digits[0:k]
    a := make([]byte, k*n)
    var seq []byte
    var db func(int, int) // recursive closure
    db = func(t, p int) {
        if t > n {
            if n%p == 0 {
                seq = append(seq, a[1:p+1]...)
            }
        } else {
            a[t] = a[t-p]
            db(t+1, p)
            for j := int(a[t-p] + 1); j < k; j++ {
                a[t] = byte(j)
                db(t+1, t)
            }
        }
    }
    db(1, 1)
    var buf bytes.Buffer
    for _, i := range seq {
        buf.WriteByte(alphabet[i])
    }
    b := buf.String()
    return b + b[0:n-1] // as cyclic append first (n-1) digits
}

func allDigits(s string) bool {
    for _, b := range s {
        if b < '0' || b > '9' {
            return false
        }
    }
    return true
}

func validate(db string) {
    le := len(db)
    found := make([]int, 10000)
    var errs []string
    // Check all strings of 4 consecutive digits within 'db'
    // to see if all 10,000 combinations occur without duplication.
    for i := 0; i < le-3; i++ {
        s := db[i : i+4]
        if allDigits(s) {
            n, _ := strconv.Atoi(s)
            found[n]++
        }
    }
    for i := 0; i < 10000; i++ {
        if found[i] == 0 {
            errs = append(errs, fmt.Sprintf("    PIN number %04d missing", i))
        } else if found[i] > 1 {
            errs = append(errs, fmt.Sprintf("    PIN number %04d occurs %d times", i, found[i]))
        }
    }
    lerr := len(errs)
    if lerr == 0 {
        fmt.Println("  No errors found")
    } else {
        pl := "s"
        if lerr == 1 {
            pl = ""
        }
        fmt.Printf("  %d error%s found:\n", lerr, pl)
        fmt.Println(strings.Join(errs, "\n"))
    }
}

func reverse(s string) string {
    bytes := []byte(s)
    for i, j := 0, len(s)-1; i < j; i, j = i+1, j-1 {
        bytes[i], bytes[j] = bytes[j], bytes[i]
    }
    return string(bytes)
}

func main() {
    db := deBruijn(10, 4)
    le := len(db)
    fmt.Println("The length of the de Bruijn sequence is", le)
    fmt.Println("\nThe first 130 digits of the de Bruijn sequence are:")
    fmt.Println(db[0:130])
    fmt.Println("\nThe last 130 digits of the de Bruijn sequence are:")
    fmt.Println(db[le-130:])
    fmt.Println("\nValidating the de Bruijn sequence:")
    validate(db)

    fmt.Println("\nValidating the reversed de Bruijn sequence:")
    dbr := reverse(db)
    validate(dbr)

    bytes := []byte(db)
    bytes[4443] = '.'
    db = string(bytes)
    fmt.Println("\nValidating the overlaid de Bruijn sequence:")
    validate(db)
}


import java.util.function.BiConsumer

class DeBruijn {
    interface Recursable<T, U> {
        void apply(T t, U u, Recursable<T, U> r);
    }

    static <T, U> BiConsumer<T, U> recurse(Recursable<T, U> f) {
        return { t, u -> f.apply(t, u, f) }
    }

    private static String deBruijn(int k, int n) {
        byte[] a = new byte[k * n]
        Arrays.fill(a, (byte) 0)

        List<Byte> seq = new ArrayList<>()

        BiConsumer<Integer, Integer> db = recurse({ int t, int p, f ->
            if (t > n) {
                if (n % p == 0) {
                    for (int i = 1; i < p + 1; ++i) {
                        seq.add(a[i])
                    }
                }
            } else {
                a[t] = a[t - p]
                f.apply(t + 1, p, f)
                int j = a[t - p] + 1
                while (j < k) {
                    a[t] = (byte) (j & 0xFF)
                    f.apply(t + 1, t, f)
                    j++
                }
            }
        })
        db.accept(1, 1)

        StringBuilder sb = new StringBuilder()
        for (Byte i : seq) {
            sb.append("0123456789".charAt(i))
        }

        sb.append(sb.subSequence(0, n - 1))
        return sb.toString()
    }

    private static boolean allDigits(String s) {
        for (int i = 0; i < s.length(); ++i) {
            char c = s.charAt(i)
            if (!Character.isDigit(c)) {
                return false
            }
        }
        return true
    }

    private static void validate(String db) {
        int le = db.length()
        int[] found = new int[10_000]
        Arrays.fill(found, 0)
        List<String> errs = new ArrayList<>()

        // Check all strings of 4 consecutive digits within 'db'
        // to see if all 10,000 combinations occur without duplication.
        for (int i = 0; i < le - 3; ++i) {
            String s = db.substring(i, i + 4)
            if (allDigits(s)) {
                int n = Integer.parseInt(s)
                found[n]++
            }
        }

        for (int i = 0; i < 10_000; ++i) {
            if (found[i] == 0) {
                errs.add(String.format("    PIN number %d is missing", i))
            } else if (found[i] > 1) {
                errs.add(String.format("    PIN number %d occurs %d times", i, found[i]))
            }
        }

        if (errs.isEmpty()) {
            System.out.println("    No errors found")
        } else {
            String pl = (errs.size() == 1) ? "" : "s"
            System.out.printf("  %d error%s found:\n", errs.size(), pl)
            errs.forEach(System.out.&println)
        }
    }

    static void main(String[] args) {
        String db = deBruijn(10, 4)

        System.out.printf("The length of the de Bruijn sequence is %d\n\n", db.length())
        System.out.printf("The first 130 digits of the de Bruijn sequence are: %s\n\n", db.substring(0, 130))
        System.out.printf("The last 130 digits of the de Bruijn sequence are: %s\n\n", db.substring(db.length() - 130))

        System.out.println("Validating the de Bruijn sequence:")
        validate(db)

        StringBuilder sb = new StringBuilder(db)
        String rdb = sb.reverse().toString()
        System.out.println()
        System.out.println("Validating the de Bruijn sequence:")
        validate(rdb)

        sb = new StringBuilder(db)
        sb.setCharAt(4443, '.' as char)
        System.out.println()
        System.out.println("Validating the overlaid de Bruijn sequence:")
        validate(sb.toString())
    }
}


import Data.List
import Data.Map ((!))
import qualified Data.Map as M

-- represents a permutation in a cycle notation
cycleForm :: [Int] -> [[Int]]
cycleForm p = unfoldr getCycle $ M.fromList $ zip [0..] p
  where
    getCycle p
      | M.null p = Nothing
      | otherwise =
          let Just ((x,y), m) = M.minViewWithKey p
              c = if x == y then [] else takeWhile (/= x) (iterate (m !) y)
          in Just (c ++ [x], foldr M.delete m c)

-- the set of Lyndon words generated by inverse Burrows—Wheeler transform
lyndonWords :: Ord a => [a] -> Int -> [[a]]
lyndonWords s n = map (ref !!) <$> cycleForm perm
  where
    ref = concat $ replicate (length s ^ (n - 1)) s
    perm = s >>= (`elemIndices` ref)

-- returns the de Bruijn sequence of order n for an alphabeth s
deBruijn :: Ord a => [a] -> Int -> [a]
deBruijn s n = let lw = concat $ lyndonWords n s
               in lw ++ take (n-1) lw


NB. implement inverse Burrows—Wheeler transform sequence method

repeat_alphabet=:  [: , [: i.&> (^ <:) # [
assert 0 1 0 1 0 1 0 1 0 1 0 1 0 1 0 1 -: 2 repeat_alphabet 4

de_bruijn=: ({~ ([: ; [: C. /:^:2))@:repeat_alphabet     NB. K de_bruijn N

pins=: #&10 #: [: i. 10&^   NB. pins y  generates all y digit PINs
groups=: [ ]\ ] , ({.~ <:)~    NB. length x infixes of sequence y cyclically extended by x-1
verify_PINs=: (/:[email protected]:groups -: [email protected]:[)  NB. LENGTH verify_PINs SEQUENCE


import java.util.ArrayList;
import java.util.Arrays;
import java.util.List;
import java.util.function.BiConsumer;

public class DeBruijn {
    public interface Recursable<T, U> {
        void apply(T t, U u, Recursable<T, U> r);
    }

    public static <T, U> BiConsumer<T, U> recurse(Recursable<T, U> f) {
        return (t, u) -> f.apply(t, u, f);
    }

    private static String deBruijn(int k, int n) {
        byte[] a = new byte[k * n];
        Arrays.fill(a, (byte) 0);

        List<Byte> seq = new ArrayList<>();

        BiConsumer<Integer, Integer> db = recurse((t, p, f) -> {
            if (t > n) {
                if (n % p == 0) {
                    for (int i = 1; i < p + 1; ++i) {
                        seq.add(a[i]);
                    }
                }
            } else {
                a[t] = a[t - p];
                f.apply(t + 1, p, f);
                int j = a[t - p] + 1;
                while (j < k) {
                    a[t] = (byte) (j & 0xFF);
                    f.apply(t + 1, t, f);
                    j++;
                }
            }
        });
        db.accept(1, 1);

        StringBuilder sb = new StringBuilder();
        for (Byte i : seq) {
            sb.append("0123456789".charAt(i));
        }

        sb.append(sb.subSequence(0, n - 1));
        return sb.toString();
    }

    private static boolean allDigits(String s) {
        for (int i = 0; i < s.length(); ++i) {
            char c = s.charAt(i);
            if (!Character.isDigit(c)) {
                return false;
            }
        }
        return true;
    }

    private static void validate(String db) {
        int le = db.length();
        int[] found = new int[10_000];
        Arrays.fill(found, 0);
        List<String> errs = new ArrayList<>();

        // Check all strings of 4 consecutive digits within 'db'
        // to see if all 10,000 combinations occur without duplication.
        for (int i = 0; i < le - 3; ++i) {
            String s = db.substring(i, i + 4);
            if (allDigits(s)) {
                int n = Integer.parseInt(s);
                found[n]++;
            }
        }

        for (int i = 0; i < 10_000; ++i) {
            if (found[i] == 0) {
                errs.add(String.format("    PIN number %d is missing", i));
            } else if (found[i] > 1) {
                errs.add(String.format("    PIN number %d occurs %d times", i, found[i]));
            }
        }

        if (errs.isEmpty()) {
            System.out.println("    No errors found");
        } else {
            String pl = (errs.size() == 1) ? "" : "s";
            System.out.printf("  %d error%s found:\n", errs.size(), pl);
            errs.forEach(System.out::println);
        }
    }

    public static void main(String[] args) {
        String db = deBruijn(10, 4);

        System.out.printf("The length of the de Bruijn sequence is %d\n\n", db.length());
        System.out.printf("The first 130 digits of the de Bruijn sequence are: %s\n\n", db.substring(0, 130));
        System.out.printf("The last 130 digits of the de Bruijn sequence are: %s\n\n", db.substring(db.length() - 130));

        System.out.println("Validating the de Bruijn sequence:");
        validate(db);

        StringBuilder sb = new StringBuilder(db);
        String rdb = sb.reverse().toString();
        System.out.println();
        System.out.println("Validating the de Bruijn sequence:");
        validate(rdb);

        sb = new StringBuilder(db);
        sb.setCharAt(4443, '.');
        System.out.println();
        System.out.println("Validating the overlaid de Bruijn sequence:");
        validate(sb.toString());
    }
}


function debruijn(k::Integer, n::Integer)
    alphabet = b"0123456789abcdefghijklmnopqrstuvwxyz"[1:k]
    a = zeros(UInt8, k * n)
    seq = UInt8[]

    function db(t, p)
        if t > n
            if n % p == 0
                append!(seq, a[2:p+1])
            end
        else
            a[t + 1] = a[t - p + 1]
            db(t + 1, p)
            for j in a[t-p+1]+1:k-1
                a[t + 1] = j
                db(t + 1, t)
            end
        end
    end

    db(1, 1)
    return String([alphabet[i + 1] for i in vcat(seq, seq[1:n-1])])
end

function verifyallPIN(str, k, n, deltaposition=0)
    if deltaposition != 0
        str = str[1:deltaposition-1] * "." * str[deltaposition+1:end]
    end
    result = true
    for i in 1:k^n-1
        pin = string(i, pad=n)
        if !occursin(pin, str)
            println("PIN $pin does not occur in the sequence.")
            result = false
        end
    end
    println("The sequence does ", result ? "" : "not ", "contain all PINs.")
end

const s = debruijn(10, 4)
println("The length of the sequence is $(length(s)). The first 130 digits are:\n",
    s[1:130], "\nand the last 130 digits are:\n", s[end-130:end])
print("Testing sequence: "), verifyallPIN(s, 10, 4)
print("Testing the reversed sequence: "), verifyallPIN(reverse(s), 10, 4)
println("\nAfter replacing 4444th digit with \'.\':"), verifyallPIN(s, 10, 4, 4444)


const val digits = "0123456789"

fun deBruijn(k: Int, n: Int): String {
    val alphabet = digits.substring(0, k)
    val a = ByteArray(k * n)
    val seq = mutableListOf<Byte>()
    fun db(t: Int, p: Int) {
        if (t > n) {
            if (n % p == 0) {
                seq.addAll(a.sliceArray(1..p).asList())
            }
        } else {
            a[t] = a[t - p]
            db(t + 1, p)
            var j = a[t - p] + 1
            while (j < k) {
                a[t] = j.toByte()
                db(t + 1, t)
                j++
            }
        }
    }
    db(1, 1)
    val buf = StringBuilder()
    for (i in seq) {
        buf.append(alphabet[i.toInt()])
    }
    val b = buf.toString()
    return b + b.subSequence(0, n - 1)
}

fun allDigits(s: String): Boolean {
    for (c in s) {
        if (c < '0' || '9' < c) {
            return false
        }
    }
    return true
}

fun validate(db: String) {
    val le = db.length
    val found = MutableList(10_000) { 0 }
    val errs = mutableListOf<String>()
    // Check all strings of 4 consecutive digits within 'db'
    // to see if all 10,000 combinations occur without duplication.
    for (i in 0 until le - 3) {
        val s = db.substring(i, i + 4)
        if (allDigits(s)) {
            val n = s.toInt()
            found[n]++
        }
    }
    for (i in 0 until 10_000) {
        if (found[i] == 0) {
            errs.add("    PIN number %04d missing".format(i))
        } else if (found[i] > 1) {
            errs.add("    PIN number %04d occurs %d times".format(i, found[i]))
        }
    }
    val lerr = errs.size
    if (lerr == 0) {
        println("  No errors found")
    } else {
        val pl = if (lerr == 1) {
            ""
        } else {
            "s"
        }
        println("  $lerr error$pl found:")
        println(errs.joinToString("\n"))
    }
}

fun main() {
    var db = deBruijn(10, 4)
    val le = db.length

    println("The length of the de Bruijn sequence is $le")
    println("\nThe first 130 digits of the de Bruijn sequence are: ${db.subSequence(0, 130)}")
    println("\nThe last 130 digits of the de Bruijn sequence are: ${db.subSequence(le - 130, le)}")

    println("\nValidating the deBruijn sequence:")
    validate(db)

    println("\nValidating the reversed deBruijn sequence:")
    validate(db.reversed())

    val bytes = db.toCharArray()
    bytes[4443] = '.'
    db = String(bytes)
    println("\nValidating the overlaid deBruijn sequence:")
    validate(db)
}


function tprint(tbl)
    for i,v in pairs(tbl) do
        print(v)
    end
end

function deBruijn(k, n)
    local a = {}
    for i=1, k*n do
        table.insert(a, 0)
    end

    local seq = {}
    function db(t, p)
        if t > n then
            if n % p == 0 then
                for i=1, p do
                    table.insert(seq, a[i + 1])
                end
            end
        else
            a[t + 1] = a[t - p + 1]
            db(t + 1, p)

            local j = a[t - p + 1] + 1
            while j < k do
                a[t + 1] = j % 256
                db(t + 1, t)
                j = j + 1
            end
        end
    end

    db(1, 1)

    local buf = ""
    for i,v in pairs(seq) do
        buf = buf .. tostring(v)
    end
    return buf .. buf:sub(1, n - 1)
end

function allDigits(s)
    return s:match('[0-9]+') == s
end

function validate(db)
    local le = string.len(db)
    local found = {}
    local errs = {}

    for i=1, 10000 do
        table.insert(found, 0)
    end

    -- Check all strings of 4 consecutive digits within 'db'
    -- to see if all 10,000 combinations occur without duplication.
    for i=1, le - 3 do
        local s = db:sub(i, i + 3)
        if allDigits(s) then
            local n = tonumber(s)
            found[n + 1] = found[n + 1] + 1
        end
    end

    local count = 0
    for i=1, 10000 do
        if found[i] == 0 then
            table.insert(errs, "    PIN number " .. (i - 1) .. " missing")
            count = count + 1
        elseif found[i] > 1 then
            table.insert(errs, "    PIN number " .. (i - 1) .. " occurs " .. found[i] .. " times")
            count = count + 1
        end
    end

    if count == 0 then
        print("  No errors found")
    else
        tprint(errs)
    end
end

function main()
    local db = deBruijn(10,4)

    print("The length of the de Bruijn sequence is " .. string.len(db))
    print()

    io.write("The first 130 digits of the de Bruijn sequence are: ")
    print(db:sub(0, 130))
    print()

    io.write("The last 130 digits of the de Bruijn sequence are: ")
    print(db:sub(-130))
    print()

    print("Validating the de Bruijn sequence:")
    validate(db)
    print()

    print("Validating the reversed de Bruijn sequence:")
    validate(db:reverse())
    print()

    db = db:sub(1,4443) .. "." .. db:sub(4445)
    print("Validating the overlaid de Bruijn sequence:")
    validate(db)
    print()
end

main()


seq = DeBruijnSequence[Range[0, 9], 4];
seq = seq~Join~Take[seq, 3];
Length[seq]
{seq[[;; 130]], seq[[-130 ;;]]}
Complement[
 StringDrop[ToString[NumberForm[#, 4, NumberPadding -> {"0", "0"}]],
    1] & /@ Range[0, 9999],
 Union[StringJoin /@ Partition[ToString /@ seq, 4, 1]]]
seq = Reverse[seq];
Complement[
 StringDrop[ToString[NumberForm[#, 4, NumberPadding -> {"0", "0"}]],
    1] & /@ Range[0, 9999],
 Union[StringJoin /@ Partition[ToString /@ seq, 4, 1]]]
seq[[4444]] = ".";
Complement[
 StringDrop[ToString[NumberForm[#, 4, NumberPadding -> {"0", "0"}]],
    1] & /@ Range[0, 9999],
 Union[StringJoin /@ Partition[ToString /@ seq, 4, 1]]]


import algorithm, parseutils, strformat, strutils

const Digits = "0123456789"

#---------------------------------------------------------------------------------------------------

func deBruijn(k, n: int): string =
  let alphabet = Digits[0..<k]
  var a = newSeq[byte](k * n)
  var sequence: seq[byte]

  #.................................................................................................

  func db(t, p: int) =
    if t > n:
      if n mod p == 0:
        sequence &= a[1..p]
    else:
      a[t] = a[t - p]
      db(t + 1, p)
      var j = a[t - p] + 1
      while j < k.uint:
        a[t] = j
        db(t + 1, t)
        inc j

    #...............................................................................................

  db(1, 1)
  for i in sequence:
    result &= alphabet[i]
  result &= result[0..(n-2)]

#---------------------------------------------------------------------------------------------------

proc validate(db: string) =

  var found: array[10_000, int]
  var errs: seq[string]

  ## Check all strings of 4 consecutive digits within 'db'
  ## to see if all 10,000 combinations occur without duplication.
  for i in 0..(db.len - 4):
    let s = db[i..(i+3)]
    var n: int
    if s.parseInt(n) == 4:
      inc found[n]

  for n, count in found:
    if count == 0:
      errs &= fmt"    PIN number {n:04d} missing"
    elif count > 1:
      errs &= fmt"    PIN number {n:04d} occurs {count} times"

  if errs.len == 0:
    echo "  No errors found"
  else:
    let plural = if errs.len == 1: "" else: "s"
    echo fmt"  {errs.len} error{plural} found"
    for err in errs: echo err

#———————————————————————————————————————————————————————————————————————————————————————————————————

var db = deBruijn(10, 4)

echo fmt"The length of the de Bruijn sequence is {db.len}"
echo ""
echo fmt"The first 130 digits of the de Bruijn sequence are: {db[0..129]}"
echo ""
echo fmt"The last 130 digits of the de Bruijn sequence are: {db[^130..^1]}"
echo ""

echo "Validating the deBruijn sequence:"
db.validate()
echo ""
echo "Validating the reversed deBruijn sequence:"
reversed(db).join().validate()
echo ""

db[4443] = '.'
echo "Validating the overlaid deBruijn sequence:"
db.validate()


program deBruijnSequence;
uses SysUtils;

// Create a de Bruijn sequence for the given word length and alphabet.
function deBruijn( const n : integer; // word length
                   const alphabet : string) : string;
var
  d, k, m, s, t, seqLen : integer;
  w : array of integer;
begin
  k := Length( alphabet);
  // de Bruijn sequence will have length k^n
  seqLen := 1;
  for t := 1 to n do seqLen := seqLen*k;
  SetLength( result, seqLen);
  d := 0; // index into de Bruijn sequence (will be pre-inc'd)
  // Work through Lyndon words of length <= n, in lexicographic order.
  SetLength( w, n); // w holds array of indices into the alphabet
  w[0] := 1; // first Lyndon word
  m := 1; // m = length of Lyndon word
  repeat
    // If m divides n, append the current Lyndon word to the output
    if (m = n) or (m = 1) or (n mod m = 0) then begin
      for t := 0 to m - 1 do begin
        inc(d);
        result[d] := alphabet[w[t]];
      end;
    end;
    // Get next Lyndon word using Duval's algorithm:
    // (1) Fill w with repetitions of current word
    s := 0; t := m;
    while (t < n) do begin
      w[t] := w[s];
      inc(t);  inc(s);
      if s = m then s := 0;
    end;
    // (2) Repeatedly delete highest index k from end of w, if present
    m := n;
    while (m > 0) and (w[m - 1] = k) do dec(m);
    // (3) If word is now null, stop; else increment end value
    if m > 0 then inc( w[m - 1]);
  until m = 0;
  Assert( d = seqLen); // check that the sequence is exactly filled in
end;

// Check a de Bruijn sequence, assuming that its alphabet consists
//  of the digits '0'..'9' (in any order);
procedure CheckDecimal( const n : integer; // word length
                        const deB : string);
var
  count : array of integer;
  j, L, pin, nrErrors : integer;
  wrap : string;
begin
  L := Length( deB);
  // The de Bruijn sequence is cyclic; make an array to handle wrapround.
  SetLength( wrap, 2*n - 2);
  for j := 1 to n - 1 do wrap[j] := deB[L + j - n  + 1];
  for j := n to 2*n - 2 do wrap[j] := deB[j - n + 1];
  // Count occurrences of each PIN.
  // PIN = -1 if character is not a decimal digit.
  SetLength( count, L);
  for j := 0 to L - 1 do count[L] := 0;
  for j := 1 to L - n + 1 do begin
    pin := SysUtils.StrToIntDef( Copy( deB, j, n), -1);
    if pin >= 0 then inc( count[pin]);
  end;
  for j := 1 to n - 1 do begin
    pin := SysUtils.StrToIntDef( Copy( wrap, j, n), -1);
    if pin >= 0 then inc( count[pin]);
  end;
  // Check that all counts are 1
  nrErrors := 0;
  for j := 0 to L - 1 do begin
    if count[j] <> 1 then begin
      inc( nrErrors);
      WriteLn( SysUtils.Format( '  PIN %d has count %d', [j, count[j]]));
    end;
  end;
  WriteLn( SysUtils.Format( '  Number of errors = %d', [nrErrors]));
 end;

// Main routine
var
  deB, rev : string;
  L, j : integer;
begin
   deB := deBruijn( 4, '0123456789');
//   deB := deBruijn( 4, '7368290514'); // any permutation would do
   L := Length( deB);
   WriteLn( SysUtils.Format( 'Length of de Bruijn sequence = %d', [L]));
   if L >= 260 then begin
     WriteLn;
     WriteLn( 'First and last 130 characters are:');
     WriteLn( Copy( deB, 1, 65));
     WriteLn( Copy( deb, 66, 65));
     WriteLn( '...');
     WriteLn( Copy( deB, L - 129, 65));
     WriteLn( Copy( deB, L - 64, 65));
   end;
   WriteLn;
   WriteLn( 'Checking de Bruijn sequence:');
   CheckDecimal( 4, deB);
   // Check reversed sequence
   SetLength( rev, L);
   for j := 1 to L do rev[j] := deB[L + 1 - j];
   WriteLn( 'Checking reversed sequence:');
   CheckDecimal( 4, rev);
   // Check sequence with '.' instad of decimal digit
   if L >= 4444 then begin
     deB[4444] := '.';
     WriteLn( 'Checking vandalized sequence:');
     CheckDecimal( 4, deB);
   end;
end.


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

my $seq;
for my $x (0..99) {
    my $a = sprintf '%02d', $x;
    next if substr($a,1,1) < substr($a,0,1);
    $seq .= (substr($a,0,1) == substr($a,1,1)) ? substr($a,0,1) : $a;
    for ($a+1 .. 99) {
        next if substr(sprintf('%02d', $_), 1,1) <= substr($a,0,1);
        $seq .= sprintf "%s%02d", $a, $_;
    }
}
$seq .= '000';

sub check {
    my($seq) = @_;
    my %chk;
    for (0.. -1 + length $seq) { $chk{substr($seq, $_, 4)}++ }
    say 'Missing: ' . join ' ', grep { ! $chk{ sprintf('%04d',$_) } } 0..9999;
    say 'Extra:   ' . join ' ', sort grep { $chk{$_} > 1 } keys %chk;
}

my $n = 130;
say "de Bruijn sequence length: " . length $seq;
say "\nFirst $n characters:\n" . substr($seq, 0, $n );
say "\nLast $n characters:\n"  . substr($seq, -$n, $n);
say "\nIncorrect 4 digit PINs in this sequence:";
check $seq;

say "\nIncorrect 4 digit PINs in the reversed sequence:";
check(reverse $seq);

say "\nReplacing the 4444th digit, '@{[substr($seq,4443,1)]}', with '5'";
substr $seq, 4443, 1, 5;
say "Incorrect 4 digit PINs in the revised sequence:";
check $seq;