Post by B+ on Mar 22, 2019 17:44:26 GMT
Started by tsh73 at the LB Forum, I could not pass up this nice little graphics program.
I mod tsh73 code to split according recursive level depth, forcing a split from level 1 and making splits less probable the deeper the level:
I mod tsh73 code to split according recursive level depth, forcing a split from level 1 and making splits less probable the deeper the level:
'kind of (randomly) (split) square into rectangles
'tsh73 march 2019
'mod b+ 2019-03-22 of LB forum code copy
nomainwin
gosub [getSlack]
cellSize = 128
gap = 20
nx = int((DisplayWidth-gap-200)/(cellSize+gap)) 'my tool bar is on side
ny = int((DisplayHeight-gap-100)/(cellSize+gap)) '-100 for toolbar etc
WindowWidth = gap+nx*(cellSize+gap)+slackX
WindowHeight = gap+ny*(cellSize+gap)+slackY
UpperLeftX = (DisplayWidth-WindowWidth)/2
UpperLeftY = (DisplayHeight-WindowHeight)/2
open "Splitting to random rectangles" for graphics_nsb_nf as #gr
#gr "trapclose [quit]"
#gr "down"
global numR
global maxNumR
global minSize 'split not less then
global probSplit 'probability to split
minSize = 7
probSplit = .95
maxNumR = 10
numR = 0 '???
while 1
scan
for i = 0 to nx-1
for j = 0 to ny -1
scan
call rect gap+i*(cellSize+gap), gap+j*(cellSize+gap), cellSize, cellSize, 1
next
next
call pause 2000
wend
wait
sub rect x, y, w, h, level
#gr "place ";x;" ";y
#gr "backcolor ";rainbow$(rnd(0))
#gr "boxfilled ";x+w+1;" ";y+h+1
'print w, h
'if numR <0 then exit sub
'if not(rnd(0)<probSplit) then exit sub
'mod b+
'numR=numR+1
'if rnd(0)>0.5 then 'horisontal
' 'w1=int(w/2) 'equally
' w1=int(rnd(0)*w)
' w2 = w-w1
' if w1 <minSize or w2 <minSize then exit sub
' call rect x, y, w1, h
' call rect x+w1, y, w2, h
'else 'vertical
' 'h1=int(h/2)
' h1=int(rnd(0)*h)
' h2 = h-h1
' if h1 <minSize or h2 <minSize then exit sub
' call rect x, y, w, h1
' call rect x, y+h1, w, h2
'end if
'forces at least 1 split at level 1
IF RND(0) < 1 / level + .5 THEN 'control just how much splitting according to level .4 to .5??
IF RND(0) < .5 THEN 'splitwidth
IF w >= 2 * minSize THEN 'split as much as possible
w1 = INT(RND(0) * w)
w2 = w - w1
WHILE w1 < minSize OR w2 < minSize
w1 = INT(RND(0) * w)
w2 = w - w1
WEND
call rect x, y, w1, h, level + 1
call rect x + w1, y, w2, h, level + 1
ELSE
EXIT SUB
END IF
ELSE 'split vertical
IF h > 2 * minSize THEN 'splittable
h1 = INT(RND(0) * h)
h2 = h - h1
WHILE h1 < minSize OR h2 < minSize
h1 = INT(RND(0) * h)
h2 = h - h1
WEND
call rect x, y, w, h1, level + 1
call rect x, y + h1, w, h2, level + 1
ELSE
EXIT SUB
END IF
END IF
ELSE
EXIT SUB
END IF
end sub
[quit]
close #gr
end
'------------------------
[getSlack]
WindowWidth=200:WindowHeight=200
open "" for graphics_nsb as #t:#t,"home;posxy x y":close#t
slackX=WindowWidth-2*x:slackY=WindowHeight-2*y
return
function rainbow$(x)
hi = int((x*6) mod 6)+ 5*(x<0) 'fixed to 0..5
f = (x*6) mod 1 + (x<0) 'frac, 0..1
q = (1-f)
select case hi
case 0
r = 1: g = f: b = 0
case 1
r = q: g = 1: b = 0
case 2
r = 0: g = 1: b = f
case 3
r = 0: g = q: b = 1
case 4
r = f: g = 0: b = 1
case 5
r = 1: g = 0: b = q
end select
R = int(r*255)
G = int(g*255)
B = int(b*255)
rainbow$= R;" ";G;" ";B
end function
sub pause mil 'tsh version has scan built-in
t0 = time$("ms")
while time$("ms") < t0 + mil : wend '<<< Oh scan in here causes error when click Window X
end sub