Ascii Chladni Two Variations

Here are chladni patterns in glorious ASCII.

'Chladni Fractalish Demo3
'http://local.wasp.uwa.edu.au/~pbourke/modelling/chladni/
'Thanks to Taj for the idea and Tan function suggestion
'Jim, Rbraz and Mind @ DBF-GVY for the code help
'Rattrapmax6 for interpolation code
'FB .17b testing (download page, not CVS)
'Chlandi code modified from Mind example code
option explicit

#define chs 64
#define sw 1024
#define sh 768
#define tw 128
#define th 96

'Jofers
Type Pixel_Color
    B As Ubyte
    G As Ubyte
    R As Ubyte
    A As Ubyte
End Type

Union Pixel
    Channel As Pixel_Color
    Value   As Uinteger
End Union

const pi = Atn(1.0) * 4

dim shared tex(0 to tw - 1, 0 to th - 1) as uinteger
dim shared ctex(0 to tw - 1, 0 to th - 1) as uinteger
dim shared ntex(0 to tw - 1, 0 to th - 1) as uinteger
dim shared pal(0 to 255) as uinteger
dim as string key

function GetRandom(lowerbound as integer, upperbound as integer) as integer
   return Int((upperbound - lowerbound + 1) * Rnd + lowerbound)
end function

'Interpolation code by Rattrapmax6
Sub DoPalette(pal() as UInteger, sr as integer, sg as integer, sb as integer, er as integer, eg as integer, eb as integer)
    Dim As Integer i
    Dim iStart(3) As Integer
    Dim iEnd(3) As Integer
    Dim iShow(3) As Integer
    Dim Rend(3) As Double
    Dim InterPol(3) As Double

    InterPol(0) = Ubound(pal)
    iStart(1) = sr
    iStart(2) = sg
    iStart(3) = sb
    iEnd(1) = er
    iEnd(2) = eg
    iEnd(3) = eb
    InterPol(1) = (iStart(1) - iEnd(1)) / InterPol(0)
    InterPol(2) = (iStart(2) - iEnd(2)) / InterPol(0)
    InterPol(3) = (iStart(3) - iEnd(3)) / InterPol(0)       
    Rend(1) = iStart(1)
    Rend(2) = iStart(2)
    Rend(3) = iStart(3)   

    For i = 0 To Ubound(pal)
        iShow(1) = Rend(1)
        iShow(2) = Rend(2)
        iShow(3) = Rend(3)

        pal(i) = Rgb(iShow(1),iShow(2),iShow(3))

        Rend(1) -= InterPol(1)
        Rend(2) -= InterPol(2)
        Rend(3) -= InterPol(3)
    Next

End Sub

sub GeneratePalette(pal() as integer)
    dim as integer rs, gs, bs, re, ge, be

    rs = GetRandom(0, 255)
    gs = GetRandom(0, 255)
    bs = GetRandom(0, 255)
    re = 255
    ge = 255
    be = 255   
    DoPalette pal(), rs, gs, bs, re, ge, be
end sub

sub LoadChladni
    dim as integer x, y, n, m, x2, y2, l, i, nx, ny
    dim as integer clr1, clr2, r, g, b, iterations
    dim as integer rmax
    dim as double hh, h, ambient, dif, spec
    dim as uinteger cc
    dim clr as Pixel

    iterations = 4
    rmax = 10
    'Clear to 255
    for x = 0 to tw - 1
        for y = 0 to th - 1
            tex(x, y) = 255
        next
    next
    'Generate chladni texture filling in 255 areas
    for i = 1 to iterations
        do
            n = rnd * rmax
            m = rnd * rmax
            sleep 1
        loop until (m  n) and (m mod 2 = 0) and (n mod 2 = 0)
        GeneratePalette pal()
        for x = 0 to tw - 1
            for y = 0 to th - 1
                ambient = 0.55
                dif = 5.5
                spec = 2.0
                x2 = ( cos( n*pi*x/chs ) * cos( m*pi*y/chs ) ) * 128
                y2 = ( cos( m*pi*x/chs ) * cos( n*pi*y/chs ) ) * 128
                cc = x2 - y2
                if cc < 0 then cc = 0
                if cc > 255 then cc = 255
                if tex(x, y) = 255 then
                    tex(x, y) = cc
                    ctex(x, y) = pal(cc)
                end if
            next
        next
    next
    'Glassify image
    for x = 0 to tw - 1
        for y = 0 to th - 1
            if (x + 1) = 0 then clr2 = tex(x - 1, y)
            nx = clr1 - clr2
            if (y + 1) = 0 then clr2 = tex(x, y - 1)
            ny = clr1 - clr2
            hh = 1 / sqr(nX * nX + nY * nY + 1)
            'shading = ambient + dif*dot + dot^2 * spec
            h = ambient + (dif * hh) + (hh * hh) * spec
            clr.Value = ctex(x, y)
            r = Int(clr.channel.r * h)
            g = Int(clr.channel.g * h)
            b = Int(clr.channel.b * h)
            if r < 0 then r = 0
            if g < 0 then g = 0
            if b < 0 then b = 0
            if r > 255 then r = 255
            if g > 255 then g = 255
            if b > 255 then b = 255
            ntex(x, y) = RGB(r, g, b)
        next
    next
    'Print Image
    screenlock
    cls   
    for x = 0 to tw - 1
        for y = 0 to th - 1
            color ntex(x, y), RGB(0,0,0)
            locate y, x
            print chr(219);
        next
    next

    screenunlock
end sub

Randomize timer

screenres sw, sh, 32,,1
width tw, th
windowtitle "Ascii Chladni"
setmouse ,,0
LoadChladni
do
    key = inkey
    if key = chr(32) then
        LoadChladni
    end if
    sleep 1
loop until key = chr(27)
setmouse ,,1
end

Alternative version.

'Chladni Fractalish Demo3
'http://local.wasp.uwa.edu.au/~pbourke/modelling/chladni/
'Thanks to Taj for the idea and Tan function suggestion
'Jim, Rbraz and Mind @ DBF-GVY for the code help
'Rattrapmax6 for interpolation code
'FB .17b testing (download page, not CVS)
'Chlandi code modified from Mind example code
option explicit

#define chs 64
#define sw 1024
#define sh 768
#define tw 128
#define th 96

'Jofers
Type Pixel_Color
    B As Ubyte
    G As Ubyte
    R As Ubyte
    A As Ubyte
End Type

Union Pixel
    Channel As Pixel_Color
    Value   As Uinteger
End Union

const pi = Atn(1.0) * 4

dim shared tex(0 to tw - 1, 0 to th - 1) as uinteger
dim shared ctex(0 to tw - 1, 0 to th - 1) as uinteger
dim shared ntex(0 to tw - 1, 0 to th - 1) as uinteger
dim shared pal(0 to 255) as uinteger
dim as string key

function GetRandom(lowerbound as integer, upperbound as integer) as integer
   return Int((upperbound - lowerbound + 1) * Rnd + lowerbound)
end function

'Interpolation code by Rattrapmax6
Sub DoPalette(pal() as UInteger, sr as integer, sg as integer, sb as integer, er as integer, eg as integer, eb as integer)
    Dim As Integer i
    Dim iStart(3) As Integer
    Dim iEnd(3) As Integer
    Dim iShow(3) As Integer
    Dim Rend(3) As Double
    Dim InterPol(3) As Double

    InterPol(0) = Ubound(pal)
    iStart(1) = sr
    iStart(2) = sg
    iStart(3) = sb
    iEnd(1) = er
    iEnd(2) = eg
    iEnd(3) = eb
    InterPol(1) = (iStart(1) - iEnd(1)) / InterPol(0)
    InterPol(2) = (iStart(2) - iEnd(2)) / InterPol(0)
    InterPol(3) = (iStart(3) - iEnd(3)) / InterPol(0)       
    Rend(1) = iStart(1)
    Rend(2) = iStart(2)
    Rend(3) = iStart(3)   

    For i = 0 To Ubound(pal)
        iShow(1) = Rend(1)
        iShow(2) = Rend(2)
        iShow(3) = Rend(3)

        pal(i) = Rgb(iShow(1),iShow(2),iShow(3))

        Rend(1) -= InterPol(1)
        Rend(2) -= InterPol(2)
        Rend(3) -= InterPol(3)
    Next

End Sub

sub GeneratePalette(pal() as integer)
    dim as integer rs, gs, bs, re, ge, be

    rs = GetRandom(0, 255)
    gs = GetRandom(0, 255)
    bs = GetRandom(0, 255)
    re = 255
    ge = 255
    be = 255   
    DoPalette pal(), rs, gs, bs, re, ge, be
end sub

sub LoadChladni
    dim as integer x, y, n, m, x2, y2, l, i, nx, ny
    dim as integer clr1, clr2, r, g, b, iterations
    dim as integer rmax
    dim as double hh, h, ambient, dif, spec
    dim as uinteger cc
    dim clr as Pixel

    iterations = 4
    rmax = 10
    'Clear to 255
    for x = 0 to tw - 1
        for y = 0 to th - 1
            tex(x, y) = 255
        next
    next
    'Generate chladni texture filling in 255 areas
    for i = 1 to iterations
        do
            n = rnd * rmax
            m = rnd * rmax
            sleep 1
        loop until (m  n) and (m mod 2 = 0) and (n mod 2 = 0)
        GeneratePalette pal()
        for x = 0 to tw - 1
            for y = 0 to th - 1
                ambient = 0.55
                dif = 5.5
                spec = 2.0
                x2 = ( cos( n*pi*x/chs ) * cos( m*pi*y/chs ) ) * 128
                y2 = ( cos( m*pi*x/chs ) * cos( n*pi*y/chs ) ) * 128
                cc = x2 - y2
                if cc < 0 then cc = 0
                if cc > 255 then cc = 255
                if tex(x, y) = 255 then
                    tex(x, y) = cc
                    ctex(x, y) = pal(cc)
                end if
            next
        next
    next
    'Glassify image
    for x = 0 to tw - 1
        for y = 0 to th - 1
            if (x + 1) = 0 then clr2 = tex(x - 1, y)
            nx = clr1 - clr2
            if (y + 1) = 0 then clr2 = tex(x, y - 1)
            ny = clr1 - clr2
            hh = 1 / sqr(nX * nX + nY * nY + 1)
            'shading = ambient + dif*dot + dot^2 * spec
            h = ambient + (dif * hh) + (hh * hh) * spec
            clr.Value = ctex(x, y)
            r = Int(clr.channel.r * h)
            g = Int(clr.channel.g * h)
            b = Int(clr.channel.b * h)
            if r < 0 then r = 0
            if g < 0 then g = 0
            if b < 0 then b = 0
            if r > 255 then r = 255
            if g > 255 then g = 255
            if b > 255 then b = 255
            ntex(x, y) = RGB(r, g, b)
        next
    next
    'Print Image
    screenlock
    cls   
    for x = 0 to tw - 1
        for y = 0 to th - 1
            color ntex(x, y), RGB(0,0,0)
            locate y, x
            if tex(x, y) = 7 then
                print chr(178);
            else
                print chr(tex(x, y));
            end if
        next
    next

    screenunlock
end sub

Randomize timer

screenres sw, sh, 32,,1
width tw, th
windowtitle "Ascii Chladni"
setmouse ,,0
LoadChladni
do
    key = inkey
    if key = chr(32) then
        LoadChladni
    end if
    sleep 1
loop until key = chr(27)
setmouse ,,1
end
Unless otherwise stated, the content of this page is licensed under Creative Commons Attribution-Share Alike 2.5 License.