QB4.5 fractel [1989]

[bluatigro]

this is a translation of a old program in QB4.5
that i found in a old magazine

i want to know :
are there more recepy's that give nice output
i think they are out there

experiment whit recepy's and report good one's

i have no idea how many recepy's there are


WindowWidth = DisplayWidth
WindowHeight = DisplayHeight
global winx , winy
'' bluatigro 1 may 2018
'' QB4.5 code from 1989
'' translation to JB
winx = WindowWidth
winy = WindowHeight
global pi , golden.ratio
pi = atn( 1 ) * 4
golden.ratio = ( sqr( 5 ) - 1 ) / 2
nomainwin
angle = 360 * golden.ratio
factor = golden.ratio
angle$ = str$( angle )
factor$ = str$( factor )
prompt "angle [ 0 ... 360 ] = " ; angle$
prompt "factor [ 0 ... 1 ] = " ; factor$
angle = val( angle$ )
factor = val( factor$ )
open "fractel from 1989" for graphics as #m
 #m "trapclose [quit]"
 #m "fill black"
 x = rnd(0) * winy - winy / 2
 y = rnd(0) * winy - winy / 2
 #m "size 1"
 #m "color green"
 while tel < 10000
   tel = tel + 1
   ex = winx / 2 + x
   ey = winy / 2 + y
   #m "goto " ; ex ; " " ; ey
   #m "down"
   #m "set " ; ex ; " " ; ey
   #m "up"
''this is the recepy from 1989 there may be other's
''feel free to experiment whit this and report good recepy's
   if rnd(0) < .1 then
     call scale x , y , 1 / 2
     call translate x , y , winy / 4 , winy / 4
   else
     call rotate x , y , angle
     call scale x , y , factor
   end if
''end resepy
 wend
 notice "Ready !!"
wait
[quit]
 close #m
end
function rad( deg )
 rad = deg * pi / 180
end function
sub rotate byref k , byref l , deg
 s = sin( rad( deg ) )
 c = cos( rad( deg ) )
 hk = k * c - l * s
 hl = k * s + l * c
 k = hk
 l = hl
end sub
sub scale byref x , byref y , f
 x = x * f
 y = y * f
end sub
sub translate byref x , byref y , dx , dy
 x = x + dx
 y = y + dy
end sub
function length( x , y )
 length = sqr( x * x + y * y )
end function


[tsh73]

Good ones (really!)
72 85
30 85
made code a bit faster

Ok I went a bit further
Now on finishing it presents PROMPT with angle and factor (via space)
So you can copy angle and factor from there
Like this

130 .85

If you press ESC, it'll juts stop
BUT
if you change numbers and press OK it will go with these numbers!
try small changes and see how it evolves.


WindowWidth = DisplayWidth
WindowHeight = DisplayHeight
global winx , winy
'' bluatigro 1 may 2018
'' QB4.5 code from 1989
'' translation to JB
winx = WindowWidth
winy = WindowHeight
global pi , golden.ratio
pi = atn( 1 ) * 4
golden.ratio = ( sqr( 5 ) - 1 ) / 2
nomainwin
angle = 360 * golden.ratio
factor = golden.ratio
angle$ = str$( angle )
factor$ = str$( factor )
prompt "angle [ 0 ... 360 ] = " ; angle$
prompt "factor [ 0 ... 1 ] = " ; factor$

open "fractel from 1989" for graphics_nsb as #m
 #m "trapclose [quit]"
 #m "fill black"

[OnceMore]
tel =0
angle = val( angle$ )
factor = val( factor$ )
'force it down to 0..1
if factor >1 then factor = factor /10^(int(log(factor)/log(10))+1): factor$=str$(factor)

 x = rnd(0) * winy - winy / 2
 y = rnd(0) * winy - winy / 2
 #m "size 1"
 #m "down"
 #m "color green"
 while tel < 30000
 scan
   tel = tel + 1
   ex = winx / 2 + x
   ey = winy / 2 + y
   '#m "goto " ; ex ; " " ; ey
   '#m "down"
   #m "set " ; int(ex) ; " " ; int(ey)
   '#m "up"
''this is the recepy from 1989 there may be other's
''feel free to experiment whit this and report good recepy's
   if rnd(0) < .1 then
     call scale x , y , 1 / 2
     call translate x , y , winy / 4 , winy / 4
   else
     call rotate x , y , angle
     call scale x , y , factor
   end if
''end resepy
 wend
 #m "flush"
 'notice "Done"+chr$(13)+"Ready !!"
 dummy$=angle$+" "+factor$
 prompt "Change numbers and press OK"+chr$(13)+"angle factor (keep space)";dummy$
 if dummy$ = "" then wait 'ESC pressed
 'else restart with values changed
 angle$= word$(dummy$, 1)
 factor$= word$(dummy$, 2)
 #m "cls"
 #m "fill black"
 goto [OnceMore]
wait
[quit]
 close #m
end
function rad( deg )
 rad = deg * pi / 180
end function
sub rotate byref k , byref l , deg
'  s = sin( rad( deg ) )
'  c = cos( rad( deg ) )
 s = sin(deg * pi / 180 )
 c = cos(deg * pi / 180 )
 hk = k * c - l * s
 hl = k * s + l * c
 k = hk
 l = hl
end sub
sub scale byref x , byref y , f
 x = x * f
 y = y * f
end sub
sub translate byref x , byref y , dx , dy
 x = x + dx
 y = y + dy
end sub
function length( x , y )
 length = sqr( x * x + y * y )
end function


[B+]

Nice here is 45 85

[B+]

I have modified code to systematically explore fractals through incrementing angle and factors, I've also added color that will bring out more pattern sometimes, I've tried to slow down incrementing around interesting areas:

'bluatigro fractal mod by tsh and bplus.txt for JB v2 by bplus 2018-05-05
'' mod by bplus forget getting angle and factor from user, systematically change these
'' mod by tsh73 for getting angle and factor post May 3
'' bluatigro 1 may 2018
''   this is the recepy from 1989 there may be other's
''   feel free to experiment whit this and report good recepy's
'' QB4.5 code from 1989
'' translation to JB

nomainwin
global xmax, ymax, pi, rrr, ggg, bbb, ccc
xmax = 900 : ymax = 700 : pi = acs(-1)
WindowWidth = xmax + 8
WindowHeight = ymax + 32
UpperLeftX = 250
UpperLeftY = 40
open "QB4.5 Fractal from 1989 for JB v2 trans bluatigro mod tsh and MOD bplus" for graphics_nsb as #m
#m "trapclose quit"
#m "fill black"
#m "down"
#m "color green"
#m "backcolor black"
angle = 35 : factor = .6 'initilize
while 1
   scan
   if factor >= .75 then factor = factor + .025 else factor = factor + .1
   if factor >= .96 then
       factor = .7
       if angle < 45 then angle = angle + 10 else angle = angle + 5
   end if
   #m "discard"
   #m "fill black"
   #m "place 10 20"
   #m "color white"
   #m "| angle = ";angle;"  factor = ";factor
   call setRGB
   ccc = 0
   tel = 0
   x = rnd(0) * xmax - xmax / 2
   y = rnd(0) * ymax - ymax / 2
   while tel < 10000
       scan
       tel = tel + 1
       ex = xmax / 2 + x
       ey = ymax / 2 + y
       call changeRGB
       #m "set " ; int(ex) ; " " ; int(ey)
       if rnd(0) < .1 then
           call scale x , y , 1 / 2
           call translate x , y , ymax / 4 , ymax / 4
       else
           call rotate x , y , angle
           call scale x , y , factor
       end if
   wend
   'call pause 1000
   #m "flush"
wend
wait

sub quit h$
   close #m
   end
end sub

function rad( deg )
 rad = deg * pi / 180
end function

sub rotate byref k , byref l , deg
 s = sin(deg * pi / 180 )
 c = cos(deg * pi / 180 )
 hk = k * c - l * s
 hl = k * s + l * c
 k = hk
 l = hl
end sub

sub scale byref x , byref y , f
 x = x * f
 y = y * f
end sub

sub translate byref x , byref y , dx , dy
 x = x + dx
 y = y + dy
end sub

function length( x , y )
 length = sqr( x * x + y * y )
end function

sub pause mil   'tsh version has scan built-in
   t0 = time$("ms")
   while time$("ms") < t0 + mil : scan : wend
end sub

sub setRGB 'mod
   rrr = rnd(0)^2 : ggg = rnd(0)^2 : bbb = rnd(0)^2
end sub

sub changeRGB 'mod
   ccc = ccc + .5
   c$ = 127 + int(127 * sin(rrr * ccc));" ";127 + int(127 * sin(ggg * ccc));" ";127 + int(127 * sin(bbb * ccc))
   #m "color ";c$
   '#gr "backcolor ";c$
end sub


[tsh73]

Long watch
Somehow color initially shows some swirls (often about factor 925) that later got completely masked by noise