RetroBASIC
Basicprogramming(.org) => Code and examples => Topic started by: B+ on May 27, 2016, 04:03:50 PM
-
Beat the sub routine for drawing Sierpinski, I don't mean beat this code that demo's that sub's flexibility.
Sierpinski in Space is the title for this demo when I get around to cleaning it up:
' ss3 w RECR sier.bas SmallBASIC 0.12.6 [B+=MGA] 2016-05-20
'from screen saver number 1.bas 2016-02-11 SmallBASIC 0.12.0 [B+=MGA]
' this version replaces solid triangle with Sierpinski
randomize
label restart
ntri=(rnd*5)\1+1
dim x1(ntri),x2(ntri),x3(ntri),y1(ntri),y2(ntri),y3(ntri),ct(ntri)
dim dx1(ntri),dx2(ntri),dx3(ntri),dy1(ntri),dy2(ntri),dy3(ntri)
for i=1 to ntri
x1(i)=(xmax+200)*rnd-100 : x2(i)=(xmax+200)*rnd-100 : x3(i)=(xmax+200)*rnd-100
y1(i)=(ymax+200)*rnd-100 : y2(i)=(ymax+200)*rnd-100 : y3(i)=(ymax+200)*rnd-100
dx1(i)=10*rnd*rdir : dx2(i)=10*rnd*rdir : dx3(i)=10*rnd*rdir
dy1(i)=5*rnd*rdir : dy2(i)=5*rnd*rdir : dy3(i)=5*rnd*rdir
c1=int(rnd*2):c2=int(rnd*2):c3=int(rnd*2)
ct(i)=rgb((55+200*rnd)*c1,(50+200*rnd)*c2,(55+200*rnd)*c3)
if ct(i)=0 then ct(i)=rgb(255,0,0)
next
timesup = rnd*5000+15000
t=ticks
while ticks-t<timesup
if len(inkey) then goto restart
cls
for i=1 to ntri
color ct(i)
SierLineTri x1(i),y1(i),x2(i),y2(i),x3(i),y3(i),0
x1(i)=x1(i)+dx1(i)
if x1(i)<-100 then dx1(i)=dx1(i)*-1
if x1(i)>xmax+100 then dx1(i)=dx1(i)*-1
x2(i)=x2(i)+dx2(i)
if x2(i)<-100 then dx2(i)=dx2(i)*-1
if x2(i)>xmax+100 then dx2(i)=dx2(i)*-1
x3(i)=x3(i)+dx3(i)
if x3(i)<-100 then dx3(i)=dx3(i)*-1
if x3(i)>xmax+100 then dx3(i)=dx3(i)*-1
y1(i)=y1(i)+dy1(i)
if y1(i)<-100 then dy1(i)=dy1(i)*-1
if y1(i)>ymax+100 then dy1(i)=dy1(i)*-1
y2(i)=y2(i)+dy2(i)
if y2(i)<-100 then dy2(i)=dy2(i)*-1
if y2(i)>ymax+100 then dy2(i)=dy2(i)*-1
y3(i)=y3(i)+dy3(i)
if y3(i)<-100 then dy3(i)=dy3(i)*-1
if y3(i)>ymax+100 then dy3(i)=dy3(i)*-1
next
showpage
delay 10
wend
goto restart
func rdir()
if int(rnd*2) then rdir=1 else rdir=-1
end
'first a sub, given 3 points of a triangle draw the traiangle within
'from the midpoints of each line forming the outer triangle
'this is the basic Sierpinski Unit that is repeated at greater depths
'3 points is 6 arguments to function plus a depth level
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
' Beat this!
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
sub SierLineTri(x1, y1, x2, y2, x3, y3, depth)
local mx1, mx2, mx3, my1, my2, my3
if depth = 0 then 'draw outer most "skin"
line x1, y1, x2, y2
line x2, y2, x3, y3
line x1, y1, x3, y3
end if
'find midpoints
if x2 < x1 then mx1 = (x1 - x2)/2 + x2 else mx1 = (x2 - x1)/2 + x1
if y2 < y1 then my1 = (y1 - y2)/2 + y2 else my1 = (y2 - y1)/2 + y1
if x3 < x2 then mx2 = (x2 - x3)/2 + x3 else mx2 = (x3 - x2)/2 + x2
if y3 < y2 then my2 = (y2 - y3)/2 + y3 else my2 = (y3 - y2)/2 + y2
if x3 < x1 then mx3 = (x1 - x3)/2 + x3 else mx3 = (x3 - x1)/2 + x1
if y3 < y1 then my3 = (y1 - y3)/2 + y3 else my3 = (y3 - y1)/2 + y1
'draw inner triangle
line mx1, my1, mx2, my2
line mx2, my2, mx3, my3
line mx1, my1, mx3, my3
'IF YOU WANT DEPTH FLEXIBILITY THEN
'in next line change 4 to MaxDepth and make MaxDepth either a constant or another parameter in call
'END IF
if depth < 4 then ' are we done drawing? no, call me
SierLineTri(x1, y1, mx1, my1, mx3, my3, depth + 1)
SierLineTri(x2, y2, mx1, my1, mx2, my2, depth + 1)
SierLineTri(x3, y3, mx3, my3, mx2, my2, depth + 1)
end if
end sub
Flexible, easy to use and understand. It can draw a Sierpinskiy at a given depth from any 3 points.
-
well yes really nice demo MGA :D
but beat this..it can be done in most of well known interpreter or compilers
-
well yes really nice demo MGA :D
but beat this..it can be done in most of well known interpreter or compilers
Yes, I hope everyone understands I am talking about a coding method and not a dialect challenge.
For any dialect that can do recursive calls, this would be an ideal method to draw Sierpinski triangle with lines.
Here is a SmallBASIC example translated from recent JB post for Memorial Day weekend (for who honor it):
'Unbeatable Sier.bas for SmallBASIC 0.12.6 [B+=MGA] 2016-05-27
'translated from Unbeatable Sier.txt for Just Basic v1.01 [B+=MGA] 2016-05-27
'============================== main code
cx = XMAX /2 : cy = YMAX /2 : cx4 = .25 * XMAX : cy4 = .25 * YMAX
cx34 = .75 * XMAX : cy34 = .75 * YMAX
red
SierLineTri 0, 0, cx, 0, 0, YMAX, 0
white
SierLineTri cx, 0, XMAX, YMAX, 0, YMAX, 0
blue
SierLineTri cx, 0, XMAX, YMAX, XMAX, 0, 0
delay 4000
color 0,15 : cls
blue
ftriangle 0, 0, cx, 0, cx4, cy4
ftriangle 0, cy, cx, cy, cx4, cy4
red
ftriangle cx, cy4, XMAX, 0, XMAX, cy4
ftriangle cx, cy, XMAX, cy4, XMAX, cy
ftriangle 0, cy, 0, cy34, XMAX, cy34
ftriangle 0, cy34, 0, YMAX, XMAX, YMAX
SierLineTri cx, 0, cx, cy4, XMAX, 0, 0
SierLineTri cx, cy4, cx, cy, XMAX, cy4, 0
SierLineTri 0, cy, XMAX, cy, XMAX, cy34, 0
SierLineTri 0, cy34, XMAX, cy34, XMAX, YMAX, 0
white
SierLineTri 0, 0, cx, 0, cx4, cy4, 0
SierLineTri 0, cy, cx, cy, cx4, cy4, 0
SierLineTri cx, cy4, XMAX, 0, XMAX, cy4, 0
SierLineTri cx, cy, XMAX, cy4, XMAX, cy, 0
SierLineTri 0, cy, 0, cy34, XMAX, cy34, 0
SierLineTri 0, cy34, 0, YMAX, XMAX, YMAX, 0
blue
SierLineTri 0, 0, cx4, cy4, 0, cy, 0
SierLineTri cx4, cy4, cx, 0, cx, cy, 0
pause
'procedures ======================================================
'This sub is unbeatable routine for drawing Sierpinski with lines
sub SierLineTri(x1, y1, x2, y2, x3, y3, depth)
local mx1, mx2, mx3, my1, my2, my3
if depth = 0 then 'draw outer most "skin" triangle
line x1, y1, x2, y2
line x2, y2, x3, y3
line x1, y1, x3, y3
end if
'find midpoints
if x2 < x1 then mx1 = (x1 - x2)/2 + x2 else mx1 = (x2 - x1)/2 + x1
if y2 < y1 then my1 = (y1 - y2)/2 + y2 else my1 = (y2 - y1)/2 + y1
if x3 < x2 then mx2 = (x2 - x3)/2 + x3 else mx2 = (x3 - x2)/2 + x2
if y3 < y2 then my2 = (y2 - y3)/2 + y3 else my2 = (y3 - y2)/2 + y2
if x3 < x1 then mx3 = (x1 - x3)/2 + x3 else mx3 = (x3 - x1)/2 + x1
if y3 < y1 then my3 = (y1 - y3)/2 + y3 else my3 = (y3 - y1)/2 + y1
'draw all inner triangles
line mx1, my1, mx2, my2
line mx2, my2, mx3, my3
line mx1, my1, mx3, my3
'to make depth more flexible, change 4 to MaxDepth
'and add MaxDepth to Globals list or as another parameter
if depth < 4 then ' are we done drawing? no, call me
SierLineTri x1, y1, mx1, my1, mx3, my3, depth + 1
SierLineTri x2, y2, mx1, my1, mx2, my2, depth + 1
SierLineTri x3, y3, mx3, my3, mx2, my2, depth + 1
end if
end sub
sub red
color rgb(200, 0, 0)
end sub
sub white
color rgb(255, 255, 255)
end sub
sub blue
color rgb(0, 0, 180)
end sub
'Fast Filled Triangle Sub by AndyAmaya
Sub ftriangle(x1, y1, x2, y2, x3, y3)
local x, y, slope1, slope2, slope3, length
'triangle coordinates must be ordered: where x1 < x2 < x3
If x2 < x1 Then x = x2 : y = y2 : x2 = x1 : y2 = y1 : x1 = x : y1 = y
'swap x1, y1, with x3, y3
If x3 < x1 Then x = x3 : y = y3 : x3 = x1 : y3 = y1 : x1 = x : y1 = y
'swap x2, y2 with x3, y3
If x3 < x2 Then x = x3 : y = y3 : x3 = x2 : y3 = y2 : x2 = x : y2 = y
If x1 <> x3 Then slope1 = (y3 - y1) / (x3 - x1)
'draw the first half of the triangle
length = x2 - x1
If length <> 0 Then
slope2 = (y2 - y1) / (x2 - x1)
For x = 0 To length
Line int(x + x1), int(x * slope1 + y1), int(x + x1), int(x * slope2 + y1)
Next
End If
'draw the second half of the triangle
y = length * slope1 + y1 : length = x3 - x2
If length <> 0 Then
slope3 = (y3 - y2) / (x3 - x2)
For x = 0 To length
Line int(x + x2), int(x * slope1 + y), int(x + x2), int(x * slope3 + y2)
Next
End If
line x1, y1, x2, y2
line x2, y2, x1, y1
line x2, y2, x3, y3
line x3, y3, x2, y2
line x1, y1, x3, y3
line x3, y3, x1, y1
End Sub
Notes to understanding and translating SmallBASIC code to your favorite dialect:
XMAX and YMAX are SmallBASIC constants for Screen Width and Screen Height, there is no adjustable screen to setup.
Also all variables are global unless declared LOCAL in procedures (kind of backwards from what people may be accustomed).
-
of course i see ...well ithink that i have something similar in xblite i will see...
-
Okay, here's the only approach that hasn't been tried:
10 REM Sierpinski
20 n=LEN FCHR$ 0,s$=FCHR$(SCRw/2)+FCHR$(SCRh/2)+FCHR$(SCRh/2)
30 x=FCODE s$( TO n),y=FCODE s$(n+1 TO n*2),l=FCODE s$(n*2+1 TO n*3),l1=l*0.5774,s$=s$(n*3+1 TO): POLYGON x-l1,y TO x+l1,y TO x,y+l: l/=2: IF l>=1 THEN s$=s$+FCHR$(x)+FCHR$(y-l)+FCHR$(l)+FCHR$(x-l1)+FCHR$(y+l)+FCHR$(l)+FCHR$(x+l1)+FCHR$(y+l)+FCHR$(l): GO TO 30 ELSE IF s$<>"" THEN GO TO 30
I'll expand it into a more easy to read format:
10 REM Sierpinski
20 n=LEN FCHR$ 0,s$=FCHR$(SCRw/2)+FCHR$(SCRh/2)+FCHR$(SCRh/2)
30 x=FCODE s$( TO n),y=FCODE s$(n+1 TO n*2),l=FCODE s$(n*2+1 TO n*3),l1=l*0.5574,s$=s$(n*3+1 TO):
POLYGON x-l1,y TO x+l1,y TO x,y+l:
l/=2:
IF l>=1 THEN
s$=s$+FCHR$(x)+FCHR$(y-l)+FCHR$(l)+FCHR$(x-l1)+FCHR$(y+l)+FCHR$(l)+FCHR$(x+l1)+FCHR$(y+l)+FCHR$(l):
GO TO 30
ELSE
IF s$<>"" THEN
GO TO 30
I think that's quite neat, myself.
D.
-
:) D your procedures are so fancy, I can't tell.... well I am sure it is fabulous!
I have a Sampler in sldbas:
'Sierpinski Sampler.sdlbas [B+=MGA] 2016-05-27
const pi = atan(1) * 4
const rad2deg =180 / pi
const deg2rad = pi / 180
randomize
option qbasic
const XMAX = 800
const YMAX = 740
setdisplay(XMAX, YMAX, 32, 1)
setcaption("Sierpinski Sampler")
function rlh(L,H)
rLH= rnd(H+2-L)-1+L
end function
function rrn(real)
rrn = real * rnd(10000)/10000
end function
sub cr(r,g,b)
ink(rgb(r,g,b))
end sub
'This sub is unbeatable routine for drawing Sierpinski with lines
sub SierLineTri(x1, y1, x2, y2, x3, y3, depth)
if depth = 0 then 'draw outer most "skin" triangle
line(x1, y1, x2, y2)
line(x2, y2, x3, y3)
line(x1, y1, x3, y3)
end if
'find midpoints
if x2 < x1 then : mx1 = (x1 - x2)/2 + x2 : else : mx1 = (x2 - x1)/2 + x1 : end if
if y2 < y1 then : my1 = (y1 - y2)/2 + y2 : else : my1 = (y2 - y1)/2 + y1 : end if
if x3 < x2 then : mx2 = (x2 - x3)/2 + x3 : else : mx2 = (x3 - x2)/2 + x2 : end if
if y3 < y2 then : my2 = (y2 - y3)/2 + y3 : else : my2 = (y3 - y2)/2 + y2 : end if
if x3 < x1 then : mx3 = (x1 - x3)/2 + x3 : else : mx3 = (x3 - x1)/2 + x1 : end if
if y3 < y1 then : my3 = (y1 - y3)/2 + y3 : else : my3 = (y3 - y1)/2 + y1 : end if
'draw all inner triangles
line(mx1, my1, mx2, my2)
line(mx2, my2, mx3, my3)
line(mx1, my1, mx3, my3)
'to make depth more flexible, change 4 to MaxDepth
'and add MaxDepth to Globals list or as another parameter
if depth < 4 then ' are we done drawing? no, call me
SierLineTri(x1, y1, mx1, my1, mx3, my3, depth + 1)
SierLineTri(x2, y2, mx1, my1, mx2, my2, depth + 1)
SierLineTri(x3, y3, mx3, my3, mx2, my2, depth + 1)
end if
end sub
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! main
cx = XMAX / 2 : cy = YMAX / 2 : r = cy : ao = 0
cr(150, 200, 250) : text(10, 10, 24, "A Sierpinski Flower")
for j = 1 to 4
r = r - 40 : ao = 1 : cr(63 * j, 255 - 63 * j, 0)
for i = 0 to 2 * pi step pi/6
SierLineTri(cx, cy, cx + r * cos(i + ao), cy +r * sin(i + ao), cx + r * cos(i + pi / 3.3 + ao), cy + r * sin(i + pi / 3.3 + ao), 0)
next
next
wait(10000)
cls
r = cy - 20 : ngon = 3
for j = 1 to 25
stepper = 2 * pi / ngon
cls
cr(150, 200, 250) : text(10, 10, 24, str(ngon) + " - Sierpinsky Polygon:")
for i = 0 to 2 * PI -.01 step stepper
cr(rlh(128, 255), rlh(128, 255) * rlh(0, 1), rlh(128, 255) * rlh(0, 1))
SierLineTri(cx, cy, cx + r * cos(i), cy + r * sin(i), cx + r * cos(i + stepper), cy + r * sin(i + stepper), 0)
next
screenswap
wait(2000)
ngon += 1
next
wait(2000)
cls
r = cy - 20 : ngon = rlh(3, 21)
while key(27) = 0
stepper = 2 * pi / ngon
cls
cr(50, 200, 250) : text(10, 10, 24, "Crazy Polys Press esc...")
for i = 0 to 2 * PI -.01 step stepper
r2 = rrn(r-100) + 100
cr(rlh(128, 255), rlh(128, 255) * rlh(0, 1), rlh(128, 255) * rlh(0, 1))
SierLineTri(cx, cy, cx + r2 * cos(i), cy + r2 * sin(i), cx + r2 * cos(i + stepper), cy + r2 * sin(i + stepper), 0)
next
screenswap
wait(2000)
ngon = rlh(3, 21)
wend
-
Pfft. Procedures?
That one doesn't use any procedures. Or recursion. Or an array... I posted a better version on Aurel's site, which allows you to set the depth.
D.
-
Hi D, sorry I meant your built in routines.
FCHR$
FCODE
POLYGON ... TO ... TO
GO TO ;D