Dark Bit Factory & Gravity
PROGRAMMING => Freebasic => Topic started by: rdc on November 03, 2006
-
Just to show that an old dog can learn a new trick. :) Thanks and karma to Taj, Rbraz and mind.
'Chladni Explorer
'Thanks to RBraz and Mind for the help
'FB .17b testing (not CVS)
'Code modified from Mind example code
option explicit
#define sw 400
#define sh 300
const pi = Atn ( 1.0 ) * 4
dim shared pal(0 to 255) as uinteger
dim as integer x, y, n, m, L, x2, y2
dim as double c1, c2, c3
dim as uinteger cc
dim key as string
function Rand() as double
return rnd * 30
end function
'Interpolation code by Rattrapmax6
Sub DoPalette
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) = 255
iStart(2) = 255
iStart(3) = 255
iEnd(1) = 1
iEnd(2) = 1
iEnd(3) = 1
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
DoPalette
Randomize timer
screen 15, 32
doagain:
cls
do
n = Rand
m = Rand
sleep 1
loop until m <> n
l = 300
for x = 0 to l
for y = 0 to l
x2 = ( cos( n*pi*x/l ) * cos( m*pi*y/l ) ) * 128
y2 = ( cos( m*pi*x/l ) * cos( n*pi*y/l ) ) * 128
cc = x2 - y2
if cc < 0 then cc = 0
if cc > 255 then cc = 255
pset(x + 50, y), pal(cc)
next
next
locate 1,1
print "n=";n;" m=";m
do
key = inkey
if key = chr(32) then goto doagain
sleep 1
loop until key = chr(27)
end
-
I discovered something interesting. Maybe you already know this. I found that when n and m are both even you can tile the texture. If they are both odd, you can tile, but the images are mirrors of each other.
'Chladni Explorer
'http://local.wasp.uwa.edu.au/~pbourke/modelling/chladni/
'Thanks to RBraz and Mind @ DBF-GVY for the help
'FB .17b testing (not CVS)
'Code modified from Mind example code
option explicit
const pi = Atn ( 1.0 ) * 4
const offsetx = 6
const offsety = 18
dim shared pal(0 to 255) as uinteger
dim as integer x, y, n, m, L, x2, y2
dim as double c1, c2, c3
dim as uinteger cc
dim key as string
function Rand() as double
return rnd * 20
end function
'Interpolation code by Rattrapmax6
Sub DoPalette
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) = 255
iStart(2) = 255
iStart(3) = 255
iEnd(1) = 0
iEnd(2) = 0
iEnd(3) = 0
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
DoPalette
Randomize timer
screen 15, 32
doagain:
cls
do
n = Rand
m = Rand
sleep 1
loop until m <> n
l = 128
for x = 0 to l
for y = 0 to l
x2 = ( cos( n*pi*x/l ) * cos( m*pi*y/l ) ) * 128
y2 = ( cos( m*pi*x/l ) * cos( n*pi*y/l ) ) * 128
cc = x2 - y2
if cc < 0 then cc = 0
if cc > 255 then cc = 255
pset(x + offsetx, y + offsety), pal(cc)
pset(x + l + offsetx, y + offsety), pal(cc)
pset(x + (l * 2) + offsetx, y + offsety), pal(cc)
pset(x + offsetx, y + l + offsety), pal(cc)
pset(x + l + offsetx, y + l + offsety), pal(cc)
pset(x + (l * 2) + offsetx, y + l + offsety), pal(cc)
next
next
locate 1,1
print "n =";n;" m =";m
do
key = inkey
if key = chr(32) then goto doagain
sleep 1
loop until key = chr(27)
end
Even on top, odd below:
-
That is very cool, I've done a little bit of learning about procedural textues (mostly celluar). Defintely going to learn about this, thanks for the source.
-
Just to show that an old dog can learn a new trick. :) Thanks and karma to Rbraz and mind.
Just to point out the idea was mine in the first place...would have been nice to be mentioned...
-
I added a mention and karma.
-
Nice work Rick :)
-
Thanks!
-
Wow!!!