XProfan

Def GetBitmapBits(3) !"gdi32","GetBitmapBits"
Def SetDIBitsToDevice(12) !"gdi32","SetDIBitsToDevice"

Proc perlinPrepare

    Declare i&, used&[permutSize&], val&

    WhileLoop 0, permutSize&-1

        i& = &loop

        While 1

            val& = int((Rnd(10001) * 0.0001) * permutSize&)

            If (used&[val&] = 0)

                p&[i&] = val&
                p&[i& + permutSize&] = val&
                used&[val&] = 1
                Break

            EndIf

        EndWhile

    EndWhile

EndProc

Proc perlinGenerate

    Parameters worldsize&, scale!, octaves&, persistence!
    Declare pixels#,bmi#,size&
    Dim pixels#,worldSize&*worldSize&*24
    'Bitmap Header, leider nötig das unhandliche Ding, obwohl die Infos eigentlich alle da sind
    Def &BI_RGB 0
    Def &DIB_RGB_COLORS 0
    Struct BITMAPINFOHEADER = biSize&, biWidth&, biHeight&, biPlanes%, biBitCount%, biCompression&, biSizeImage&, biXPelsPerMeter&, biYPelsPerMeter&, biClrUsed&, biClrImportant&
    Dim bmi#,BITMAPINFOHEADER
    Clear bmi#

    With bmi#

        .biSize&        = sizeof(bmi#)
        .biWidth&       = worldSize&
        .biHeight&      = worldSize&
        .biPlanes%      = 1
        .biBitCount%    = 32
        .biCompression& = &BI_RGB
        .biSizeImage&   = 0

    EndWith

    size& = worldsize& * worldsize& * (bmi#.biBitCount% / 8)
    Dim pixels#, size&
    Declare i!, j!, noiseVal!
    Declare   x!, y!'params
    Declare total!, frequency!, amplitude!, maxValue!, i&
    Declare modX&, modY&, A&, B&, AA&, AB&, BA&, BB&, u!, v!,return!,xt!,yt!
    Declare g1!,g2!,g3!,g4!,u2!,v2!,h&,i1!,i2!,i3!

    WhileLoop 0, worldsize& - 1

        i! = &loop

        WhileLoop 0, worldsize& - 1

            j! = &loop
            x! = i! * scale!
            y! = j! * scale!
            total! = 0
            frequency! = 2
            amplitude! = 1
            maxValue! = 0

            WhileLoop 0, octaves& - 1

                i& = &loop
                xt! = x! * frequency!
                yt! = y! * frequency!
                modX& = int(xt!) & (permutSize& - 1)
                modY& = int(yt!) & (permutSize& - 1)
                xt! = xt! - int(xt!)
                yt! = yt! - int(yt!)
                u! = xt! * xt! * xt! * (xt! * (xt! * 6.0 - 15.0) + 10.0)
                v! = yt! * yt! * yt! * (yt! * (yt! * 6.0 - 15.0) + 10.0)
                A&  = p&[modX&]+modY&
                AA& = p&[A&]
                AB& = p&[A&+1]
                B&  = p&[modX&+1]+modY&
                BA& = p&[B&]
                BB& = p&[B&+1]
                'Gradient 1
                h& = (p&[AA&]) & 7
                u2! = if(h& < 4, xt!, yt!)
                v2! = if(h& < 4, yt!, xt!)
                g1! = (if((h& & 1) <> 0, -u2!, u2!) + if((h& & 2) <> 0, -2.0 * v2!, 2.0 * v2!))
                'Gradient 2
                h& = (p&[BA&]) & 7
                u2! = if(h& < 4, xt!-1, yt!)
                v2! = if(h& < 4, yt!, xt!-1)
                g2! = (if((h& & 1) <> 0, -u2!, u2!) + if((h& & 2) <> 0, -2.0 * v2!, 2.0 * v2!))
                'Gradient 3
                h& = (p&[AB&]) & 7
                u2! = if(h& < 4, xt!, yt!-1)
                v2! = if(h& < 4, yt!-1, xt!)
                g3! = (if((h& & 1) <> 0, -u2!, u2!) + if((h& & 2) <> 0, -2.0 * v2!, 2.0 * v2!))
                'Gradient 4
                h& = (p&[BB&]) & 7
                u2! = if(h& < 4, xt!-1, yt!-1)
                v2! = if(h& < 4, yt!-1, xt!-1)
                g4! = (if((h& & 1) <> 0, -u2!, u2!) + if((h& & 2) <> 0, -2.0 * v2!, 2.0 * v2!))
                'Interpolate
                i1! = g3! + u! * (g4! - g3!)
                i2! = g1! + u! * (g2! - g1!)
                i3! = i2! + v! * (i1! - i2!)
                total! = total! + i3! * amplitude!
                maxValue! = maxValue! + amplitude!
                amplitude! = amplitude! * persistence!
                frequency! = frequency! * 2

            EndWhile

            noiseVal! = total! / maxValue!
            noiseVal! = (noiseVal! + 1) / 2.0 * 255.0' Normalisieren auf 0-255
            'Sollte nicht vorkommen, irgendwo ist noch eine kleine Ungenauigkeit
            Case (noiseVal! > 255) : noiseVal! = 255
            Case (noiseVal! < 0) : noiseVal! = 0
            Byte pixels#,4*(int(j!) * worldSize& + int(i!)) + 2  = noiseVal!'R
            Byte pixels#,4*(int(j!) * worldSize& + int(i!)) + 1  = noiseVal!'G
            Byte pixels#,4*(int(j!) * worldSize& + int(i!))      = noiseVal!'B

        EndWhile

        SetDIBitsToDevice(%hdc, 0, 0,worldsize&, worldsize&, 0, 0, 0,  worldsize&,pixels#, bmi#, &DIB_RGB_COLORS)'DIB_RGB_COLORS = 0

    EndWhile

    SetDIBitsToDevice(%hdc, 0, 0,worldsize&, worldsize&, 0, 0, 0,  worldsize&,pixels#, bmi#, &DIB_RGB_COLORS)'DIB_RGB_COLORS = 0
    Dispose pixels#, bmi#

EndProc

Declare permutSize&, time&
permutSize& = 256
Declare p&[permutSize& * 2]
WindowStyle 27
WindowTitle "Perlin-Noise"
Window 0,0 - 720, 560;0
Cls RGB(236,236,236)
Declare edit_worldsize&,  edit_scale&, edit_octaves&, edit_persistence&, edit_seed&, button&
Declare worldsize&, scale!, octaves&, persistence!, seed&
Create("Text",%hwnd,"Größe (px)",500,10,200,20)
Create("Text",%hwnd,"Skalierung",500,70,200,20)
Create("Text",%hwnd,"Oktaven",500,130,200,20)
Create("Text",%hwnd,"Persistence",500,190,200,20)
Create("Text",%hwnd,"Seed",500,250,200,20)
edit_worldsize&   = Create("Edit", %hWnd, "128", 500, 30, 200, 24)
edit_scale&       = Create("Edit", %hWnd, "0.02", 500, 90, 200, 24)
edit_octaves&     = Create("Edit", %hWnd, "4", 500, 150, 200, 24)
edit_persistence& = Create("Edit", %hWnd, "0.5", 500, 210, 200, 24)
edit_seed& = Create("Edit", %hWnd, "12345", 500, 270, 200, 24)
button& = Create("Button", %hWnd, "Welt erstellen", 500, 330, 200, 24)

WhileNot iskey(27)

    WaitInput

    If Clicked(button&)

        Cls RGB(236,236,236)
        worldsize&   = val(gettext$(edit_worldsize&))
        scale!       = val(gettext$(edit_scale&))
        octaves&     = val(gettext$(edit_octaves&))
        persistence! = val(gettext$(edit_persistence&))
        seed&        = val(gettext$(edit_seed&))
        Set("RandSeed", seed&)
        perlinPrepare()
        time& = &gettickcount
        perlinGenerate(worldsize&, scale!, octaves&, persistence!)
        Set("decimals",0)
        Locate 36, 1
        WindowTitle "Perlin-Noise (" +str$(&gettickcount - time&)+"ms)"

    EndIf

EndWhile

<canvas id="myCanvas" width="480" height="480" style="border:1px solid #d3d3d3;"></canvas>
<script>
let worldsize = 480;
let permutSize = 256;
let canvas = document.getElementById('myCanvas');
let ctx = canvas.getContext('2d');
let imgData = ctx.createImageData(worldsize, worldsize);

function seedRandom(seed) {

    let x = Math.sin(seed) * 10000;
    return x - Math.floor(x);

}

let seed = 1;//  Seed
let p = new Uint8Array(permutSize*2);
let used = new Array(permutSize).fill(false);

for (let i = 0; i < permutSize; ++i) {

    while (true) {

        let val = Math.floor(seedRandom(seed) * permutSize);
        seed++;

        if (!used[val]) {

            p[i] = val;
            p[i + permutSize] = val;
            used[val] = true;
            break;

        }

    }

}

function fade(t) {

    return t * t * t * (t * (t * 6 - 15) + 10);

}

function lerp(t, a, b) {

    return a + t * (b - a);

}

function grad(hash, x, y) {

    let h = hash & 7;
    let u = h<4 ? x : y;
    let v = h<4 ? y : x;
    return ((h&1) !== 0 ? -u : u) + ((h&2) !== 0 ? -2.0*v : 2.0*v);

}

function noise(x, y) {

    let X = Math.floor(x) & (permutSize - 1),
    Y = Math.floor(y) & (permutSize - 1);
    x -= Math.floor(x);
    y -= Math.floor(y);
    let u = fade(x),
    v = fade(y);
    let A = p[X  ]+Y, AA = p[A], AB = p[A+1],
    B = p[X+1]+Y, BA = p[B], BB = p[B+1];
    return lerp(v, lerp(u, grad(p[AA  ], x  , y   ),
    grad(p[BA  ], x-1, y   )),
    lerp(u, grad(p[AB  ], x  , y-1 ),
    grad(p[BB  ], x-1, y-1 )));

}

function fractalNoise(x, y, octaves = 6, persistence = 0.02) {

    let total = 0;
    let frequency = 2;
    let amplitude = 100;
    let maxValue = 0;

    for(let i = 0; i < octaves; i++) {

        total += noise(x * frequency, y * frequency) * amplitude;
        maxValue += amplitude;
        amplitude *= persistence;
        frequency *= 2;

    }

    return total/maxValue;

}

let size = worldsize;
let scale = 0.02;

for (let i = 0; i < size; i++) {

    for (let j = 0; j < size; j++) {

        let noiseVal = fractalNoise(i * scale, j * scale,6,0.7);
        noiseVal = (noiseVal + 1) / 2 * 255;// Normalisieren auf 0-255
        //if (noiseVal <128) { noiseVal = 128}
        //noiseVal = noiseVal -128;
        let idx = 4 * (i * size + j);
        imgData.data[idx] = noiseVal;// rot
        imgData.data[idx + 1] = noiseVal;// grün
        imgData.data[idx + 2] = noiseVal;// blau
        imgData.data[idx + 3] = 255;//  Alpha-Kanal

    }

}

ctx.putImageData(imgData, 0, 0);
</script>