+- QB64 Phoenix Edition (https://qb64phoenix.com/forum)
+-- Forum: QB64 Rising (https://qb64phoenix.com/forum/forumdisplay.php?fid=1)
+--- Forum: QBJS, BAM, and Other BASICs (https://qb64phoenix.com/forum/forumdisplay.php?fid=50)
+--- Thread: QBJS Hair mod (/showthread.php?tid=3104)
Pages:
1
2
RE: QBJS Hair mod - TerryRitchie - 10-07-2024
Thank you Vince
RE: QBJS Hair mod - vince - 10-07-2024
(10-07-2024, 06:43 PM)TerryRitchie Wrote: Wow! Reminds me of old Chinese writing using a brush.my thoughts exactly, this is going to be the eastern expansion to my Calligraphy Pro 128 Studio project
![[Image: KVWQiHI.png]](https://i.imgur.com/KVWQiHI.png)
![[Image: K36HYTf.png]](https://i.imgur.com/K36HYTf.png)
which you can find here
Code: (Select All)
_title "Calligraphy Pro 128 Studio"
'point type
type pt
x as double
y as double
end type
'shade type (Gaussian)
type st
a as double 'amplitude
v as double 'pseudo-variance
d2 as double '+/- delta t_0.5
end type
dim shared maxm
dim shared maxn
m = 0
n = 0
maxn = 0
maxm = 0
redim shared curve(maxm, maxn) as pt
redim shared curve_n(m)
redim shared shade(m) as st
'gaussian
a = 2
v = 50
d2 = 0
shade(0).a = a
shade(0).v = v
shade(0).d2 = d2
sw = 800
sh = 600
screen _newimage(sw, sh)
final = _newimage(sw, sh)
trace = 0
trace_img = _loadimage("https://i.imgur.com/t9OsDJT.png")
rr = 30
dim shared ss 'step size
ss = 0.003
dim shared fgcolor, bgcolor
fgcolor = _rgb(0,0,0)
bgcolor = _rgb(255,255,255)
'freedraw or edit state
state = 0
'switch curve state
freedraw = 0
'inside edit mode
redraw = 1
do
if _resize then
sw = _resizewidth - 20
sh = _resizeheight - 20
tmp = _copyimage(0)
screen _newimage(sw, sh)
tmp = _copyimage(final)
final = _newimage(sw, sh)
_putimage (0, 0), tmp
line (0,0)-(sw, sh),bgcolor,bf
if trace then
_putimage (0,0), trace_img
end if
end if
select case inkey$
case "a"
state = 1
m = m - 1
if m < 0 then m = maxm - 1
n = curve_n(m)
case "t"
trace = not trace
if trace then
fgcolor = _rgb(255,0,0)
else
fgcolor = _rgb(0,0,0)
end if
'final render
_dest final
'rerender all curves!!!
'render -1
line (0,0)-(sw, sh), bgcolor, bf
if trace then
_putimage (0,0), trace_img
end if
for k=0 to maxm - 1
n = curve_n(k)
preset (curve(k, 0).x, curve(k, 0).y)
for t=0 to 1 step ss
bx = 0
by = 0
'dx = 0
'dy = 0
for i=0 to n
bin = 1
for j=1 to i
bin = bin*(n - j)/j
next
p = bin*((1 - t)^(n - 1 - i))*(t^i)
bx = bx + p*curve(k, i).x
by = by + p*curve(k, i).y
'derivative
'dx = dx + bin*((1 - t)^(n - 2 - i))*(t^(i - 1))*(i - n*t + t)*curve(i).x
'dx = dy + bin*((1 - t)^(n - 2 - i))*(t^(i - 1))*(i - n*t + t)*curve(i).y
next
'line -(bx, by), fgcolor
a = shade(k).a
v = shade(k).v
d2 = shade(k).d2
r = a*exp(-v*(t - 0.5 - d2)*(t - 0.5 - d2))
if r < 0.001 then r = 0.001
preset (bx, by), fgcolor
circle (bx, by), r, fgcolor
next
next
_dest 0
line (0,0)-(sw, sh), bgcolor, bf
_putimage , final
case "b"
s = "dim x("+str$(maxm)+","+str$(maxn)+"),y("+str$(maxm)+","+str$(maxn)+")"
ConsoleLog s
s = "dim n("+str$(maxm)+"),a("+str$(maxm)+"),v("+str$(maxm)+"),d("+str$(maxm)+")"
ConsoleLog s
s = "m="+str(maxm)
ConsoleLog s
for k=0 to maxm - 1
n = curve_n(k)
s = "n("+str$(k)+")="+str$(n)
ConsoleLog s
s = "a("+str$(k)+")="+str$(shade(k).a)
ConsoleLog s
s = "v("+str$(k)+")="+str$(shade(k).v)
ConsoleLog s
s = "d("+str$(k)+")="+str$(shade(k).d2)
ConsoleLog s
for i=0 to n-1
s = "x("+str$(k)+","+str$(i)+")="+str$(curve(k,i).x)
s = s + ":"
s = s + "y("+str$(k)+","+str$(i)+")="+str$(curve(k,i).y)
ConsoleLog s
next
'pset (curve(k, 0).x, curve(k, 0).y)
'for t=0 to 1 step 0.001
' bx = 0
' by = 0
' 'dx = 0
' 'dy = 0
' for i=0 to n
' bin = 1
' for j=1 to i
' bin = bin*(n - j)/j
' next
' bx = bx + bin*((1 - t)^(n - 1 - i))*(t^i)*curve(k, i).x
' by = by + bin*((1 - t)^(n - 1 - i))*(t^i)*curve(k, i).y
' 'derivative
' 'dx = dx + bin*((1 - t)^(n - 2 - i))*(t^(i - 1))*(i - n*t + t)*curve(i).x
' 'dy = dy + bin*((1 - t)^(n - 2 - i))*(t^(i - 1))*(i - n*t + t)*curve(i).y
' next
' 'line -(bx, by), fgcolor
' a = shade(k).a
' v = shade(k).v
' d2 = shade(k).d2
' r = a*exp(-v*(t - 0.5 - d2)*(t - 0.5 - d2))
'
' if r < 0.001 then r = 0.001
' pset (bx, by), fgcolor
' circle (bx, by), r, fgcolor
'next
next
end select
select case state
case 0
mx = _mousex
my = _mousey
mb = -_mousebutton(1)
if mb = 1 then
n = 1
if n > maxn then maxn = n
m = maxm
redim _preserve curve(m, maxn)
curve(m, 0).x = mx
curve(m, 0).y = my
omx = mx
omy = my
circle (mx, my), 3, _rgb(8,88,8)
do while mb = 1
mx = _mousex
my = _mousey
mb = -_mousebutton(1)
line -(mx, my), _rgb(8,88,8)
if (mx - omx)^2 + (my - omy)^2 > rr^2 then
circle (mx, my), 3, _rgb(8,88,8)
omx = mx
omy = my
curve(m, n).x = mx
curve(m, n).y = my
n = n + 1
curve_n(m) = n
if n > maxn then maxn = n
redim _preserve curve(m , maxn)
end if
_limit 50
loop
'maxm = maxm + 1
m = m + 1
redim _preserve curve(m, maxn)
redim _preserve curve_n(m)
redim _preserve shade(m)
shade(m).a = a
shade(m).v = v
shade(m).d2 = d2
maxm = m
m = maxm - 1
state = 1
end if
''''
case 1
'somewhat final render
_dest final
'render m
line (0,0)-(sw, sh), bgcolor, bf
if trace then
_putimage (0,0), trace_img
end if
for k=0 to maxm - 1
if k<> m then
n = curve_n(k)
preset (curve(k, 0).x, curve(k, 0).y)
for t=0 to 1 step ss
bx = 0
by = 0
'dx = 0
'dy = 0
for i=0 to n
bin = 1
for j=1 to i
bin = bin*(n - j)/j
next
p = bin*((1 - t)^(n - 1 - i))*(t^i)
bx = bx + p*curve(k, i).x
by = by + p*curve(k, i).y
'derivative
'dx = dx + bin*((1 - t)^(n - 2 - i))*(t^(i - 1))*(i - n*t + t)*curve(i).x
'dy = dy + bin*((1 - t)^(n - 2 - i))*(t^(i - 1))*(i - n*t + t)*curve(i).y
next
'line -(bx, by), fgcolor
a = shade(k).a
v = shade(k).v
d2 = shade(k).d2
r = a*exp(-v*(t - 0.5 - d2)*(t - 0.5 - d2))
if r < 0.001 then r = 0.001
preset (bx, by), fgcolor
circle (bx, by), r, fgcolor
'else
' pset (bx, by), _rgb(255,0,0)
' circle (bx, by), r, _rgb(255,0,0)
next
end if
next
_dest 0
line (0,0)-(sw, sh), bgcolor, bf
if trace then
_putimage (0,0), trace_img
end if
_putimage , final
n = curve_n(m)
do
mx = _mousex
my = _mousey
mb = -_mousebutton(1)
'nearest point
mini = 0
mind = 100000000
for i=0 to n - 1
d = (curve(m, i).x - mx)^2 + (curve(m, i).y - my)^2
if d < mind then
mind = d
mini = i
end if
next
'keyboard
select case inkey$
case "d" 'remove point
'for i=mini to n - 2
' curve(m, i).x = curve(m, i + 1).x
' curve(m, i).y = curve(m, i + 1).y
'next
'n = n - 1
case "u"
shade(m).a = shade(m).a + 0.3
redraw = 1
case "j"
if shade(m).a > 0.4 then shade(m).a = shade(m).a - 0.3
redraw = 1
case "i"
if shade(m).v > 5 then shade(m).v = shade(m).v - 5
redraw = 1
case "k"
shade(m).v = shade(m).v + 5
redraw = 1
case "o"
shade(m).d2 = shade(m).d2 + 0.05
redraw = 1
case "l"
shade(m).d2 = shade(m).d2 - 0.05
redraw = 1
case "q"
'm = (m - 1) mod maxn
'state = 1
'exit do
case "a"
'm = int(int(m - 1) mod (maxm ))
'm = m - 1
'if m < 0 then m = maxm - 1
'n = curve_n(m)
freedraw = 0
exit do
end select
'_putimage (0,0), trace
line (0,0)-(sw, sh), bgcolor, bf
_putimage , final
'spline
circle (curve(m, 0).x, curve(m, 0).y), 3, _rgb(8,88,8)
for i=1 to n - 1
line -(curve(m, i).x, curve(m, i).y), _rgb(8,88,8)
circle step(0, 0), 3, _rgb(8,88,8)
next
'quick render
preset (curve(m, 0).x, curve(m, 0).y)
for t=0 to 1 step 0.01
bx = 0
by = 0
for i=0 to n
bin = 1
for j=1 to i
bin = bin*(n - j)/j
next
p = bin*((1 - t)^(n - 1 - i))*(t^i)
bx = bx + p*curve(m, i).x
by = by + p*curve(m, i).y
next
line -(bx, by), fgcolor
a = shade(m).a
v = shade(m).v
d2 = shade(m).d2
r = a*exp(-v*(t - 0.5 - d2)*(t - 0.5 - d2))
circle (bx, by), r, _rgb(255,0,0)
next
circle (curve(m, mini).x, curve(m, mini).y), 3, _rgb(255,0,0)
if mb = 1 then
do while mb = 1
mx = _mousex
my = _mousey
mb = -_mousebutton(1)
curve(m, mini).x = mx
curve(m, mini).y = my
'_putimage (0,0), trace
line (0,0)-(sw, sh), bgcolor, bf
if trace then
_putimage (0,0), trace_img
end if
_putimage , final
'spline
circle (curve(m, 0).x, curve(m, 0).y), 3, _rgb(8,88,8)
for i=1 to n - 1
line -(curve(m, i).x, curve(m, i).y), _rgb(8,88,8)
circle step(0, 0), 3, _rgb(8,88,8)
next
'quick render
preset (curve(m, 0).x, curve(m, 0).y)
for t=0 to 1 step 0.01
bx = 0
by = 0
for i=0 to n
bin = 1
for j=1 to i
bin = bin*(n - j)/j
next
p = bin*((1 - t)^(n - 1 - i))*(t^i)
bx = bx + p*curve(m, i).x
by = by + p*curve(m, i).y
next
line -(bx, by), fgcolor
a = shade(m).a
v = shade(m).v
d2 = shade(m).d2
r = a*exp(-v*(t - 0.5 - d2)*(t - 0.5 - d2))
circle (bx, by), r, _rgb(255,0,0)
next
circle (curve(m, mini).x, curve(m, mini).y), 3, _rgb(255,0,0)
_limit 50
loop
end if
_limit 50
if _keyhit = 27 then
freedraw = 0
exit do
end if
loop 'until _keyhit = 27
'''
'final render
_dest final
'rerender all curves!!!
'render -1
line (0,0)-(sw, sh), bgcolor, bf
if trace then
_putimage (0,0), trace_img
end if
for k=0 to maxm - 1
n = curve_n(k)
preset (curve(k, 0).x, curve(k, 0).y)
for t=0 to 1 step ss
bx = 0
by = 0
'dx = 0
'dy = 0
for i=0 to n
bin = 1
for j=1 to i
bin = bin*(n - j)/j
next
p = bin*((1 - t)^(n - 1 - i))*(t^i)
bx = bx + p*curve(k, i).x
by = by + p*curve(k, i).y
'derivative
'dx = dx + bin*((1 - t)^(n - 2 - i))*(t^(i - 1))*(i - n*t + t)*curve(i).x
'dx = dy + bin*((1 - t)^(n - 2 - i))*(t^(i - 1))*(i - n*t + t)*curve(i).y
next
'line -(bx, by), fgcolor
a = shade(k).a
v = shade(k).v
d2 = shade(k).d2
r = a*exp(-v*(t - 0.5 - d2)*(t - 0.5 - d2))
if r < 0.001 then r = 0.001
preset (bx, by), fgcolor
circle (bx, by), r, fgcolor
next
next
_dest 0
line (0,0)-(sw, sh), bgcolor, bf
_putimage , final
'state = 0
state = freedraw
end select
_limit 50
loop until _keyhit = 27
Sub ConsoleLog (msg As String)
$If Javascript Then
var t = document.querySelector("#warning-container table");
var tr = document.createElement("tr");
var td1 = document.createElement("td");
var td2 = document.createElement("td");
var td3 = document.createElement("td");
addWarningCell(tr, "INFO");
addWarningCell(tr, ":");
addWarningCell(tr, "");
addWarningCell(tr, ":");
addWarningCell(tr, msg, "99%");
t.append(tr);
$End If
End Sub
RE: QBJS Hair mod - Sprezzo - 10-08-2024
This is the real sh*t. Everyone take notice.
RE: QBJS Hair mod - TerryRitchie - 10-08-2024
(10-08-2024, 01:31 AM)Sprezzo Wrote: This is the real sh*t. Everyone take notice.Yeah, no kidding. Outstanding work here.
RE: QBJS Hair mod - Dav - 10-08-2024
Wow, this is crazy good!
- Dav