Flower of Justice

[marshawn]

'Blossoming Flower of Justice
global XMAX, YMAX, CX, CY, LC$, HC$, D2R
H$ = "gr"
XMAX = 730  '< actual drawing space needed
YMAX = 600  '< actual drawing space needed
CX = XMAX / 2: CY = YMAX / 2  'screen center
HC$ = "255 255 255"
LC$ = "0 0 0"

nomainwin
WindowWidth = XMAX + 8
WindowHeight = YMAX + 32
UpperLeftX = 300
UpperLeftY = 40

open "Universe" for graphics_nsb_nf as #gr
#gr "trapclose quit"
#gr "down"
#gr "fill ";HC$  ' the field
#gr "COLOR "; LC$  'outline circles in field color

for b=0 to 1e100 step 1
r = 100
for a = 0.1 to 1 step 0.1
   #gr "fill ";HC$  ' the field
   call drawc CX, CY, a*r, a, 3
   call pause 490
next
call pause 490
r = 100
for a = 1 to 0.1 step -0.1
   #gr "fill ";HC$  ' the field
   call drawc CX, CY, a*r, a, 3
   call pause 490
next
next
wait

sub quit Hdl$
   close #Hdl$
   end
end sub

SUB drawc x, y, r, a, n
   if n > 0 then
   for t=0 to 8*atn(1) step 8*atn(1)/6
       xx = x + r*cos(t)
       yy = y + r*sin(t)
       #gr "place ";xx;" ";yy;"; circle ";r
       call drawc xx, yy, a*r, a, n - 1
   next
   end if
END SUB

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


[plus]

Very nice! I recognize that last from Sacred Geometry.

Welcome to the forum!

[marshawn]


'Blossoming Flower of Liberty
global XMAX, YMAX, CX, CY, LC$, HC$, D2R
H$ = "gr"
XMAX = 730  '< actual drawing space needed
YMAX = 600  '< actual drawing space needed
CX = XMAX / 2: CY = YMAX / 2  'screen center
HC$ = "255 255 255"
LC$ = "0 0 0"

nomainwin
WindowWidth = XMAX + 8
WindowHeight = YMAX + 32
UpperLeftX = 300
UpperLeftY = 40

open "Universe" for graphics_nsb_nf as #gr
#gr "trapclose quit"
#gr "down"
#gr "fill ";HC$  ' the field
#gr "COLOR "; LC$  'outline circles in field color

for b=0 to 1e100 step 1
r = 100
for a = 0.1 to 1 step 0.1
   #gr "fill ";HC$  ' the field
   call drawc CX, CY, a*r + (1-a)*150, a, 3
   call pause 2000
next
r = 100
for a = 1 to 0.1 step -0.1
   #gr "fill ";HC$  ' the field
   call drawc CX, CY, a*r + (1-a)*150, a, 3
   call pause 2000
next
'r = 100
'for a = 1 to 0.1 step -0.1
'    #gr "fill ";HC$  ' the field
'    call drawc CX, CY, a*r, a, 3
'    call pause 490
'next
next
wait

sub quit Hdl$
   close #Hdl$
   end
end sub

SUB drawc x, y, r, a, n
   if n > 0 then
   for t=0 to 8*atn(1) step 8*atn(1)/6
       xx = x + r*cos(t)
       yy = y + r*sin(t)
       #gr "place ";xx;" ";yy;"; circle ";r
       call drawc xx, yy, a*r, a, n - 1
   next
   end if
END SUB

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



[Rod]

Nice, a flower field or meadow with random arc based stems and undulating hills disappearing into the distant horizon. Fractals really.

[plus]

Here is a b+ mod: Flower Wheel

Caution too much blinking

global XMAX, YMAX, CX, CY, PI
H$ = "gr"
XMAX = 730  '< actual drawing space needed
YMAX = 600  '< actual drawing space needed
CX = XMAX / 2: CY = YMAX / 2  'screen center
PI = 3.1415

nomainwin
WindowWidth = XMAX + 8
WindowHeight = YMAX + 32
UpperLeftX = 200
UpperLeftY = 40

open "Flower Wheel" for graphics_nsb_nf as #gr
#gr "trapclose quit"
#gr "down"
#gr "fill white"
#gr "COLOR darkblue"  'outline circles in field color

while 1
   scan
   #gr "fill white"
   o = o + PI / 45
   call drawc CX, CY, 150, .25, 3, o
   call pause 30
wend
wait

sub quit Hdl$
   close #gr
   end
end sub

Sub drawc x, y, r, a, n, o
   If n > 0 Then
       For t = 0 To PI*2 Step PI*(1 / 3)
           scan
           xx = x + r * Cos(t + o)
           yy = y + r * Sin(t + o)
           #gr "place ";xx;" ";yy;"; circle ";r
           call drawc xx, yy, a * r, a, n - 1, o*-2
       Next
   End If
End Sub

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



[tsh73]

playing with wheels (smaller lines-no flicker for me)

global XMAX, YMAX, CX, CY, PI
H$ = "gr"
XMAX = 730  '< actual drawing space needed
YMAX = 600  '< actual drawing space needed
CX = XMAX / 2: CY = YMAX / 2  'screen center
PI = 3.1415

nomainwin
WindowWidth = XMAX + 8
WindowHeight = YMAX + 32
UpperLeftX = 200
UpperLeftY = 40

open "Flower Wheel" for graphics_nsb_nf as #gr
#gr "trapclose quit"
#gr "down"
#gr "fill white"
#gr "COLOR darkblue"  'outline circles in field color

while 1
   scan
   #gr "fill white"
   o = o + PI / 45
'    call drawc CX, CY, 150, .25, 2, o
   call drawc CX, CY, 150, .5, 3, o
   call pause 30
wend
wait

sub quit Hdl$
   close #gr
   end
end sub

Sub drawc x, y, r, a, n, o
   If n > 0 Then
       For t = 0 To PI*2 Step PI*(1 / 3)*n
           scan
           xx = x + r * Cos(t + o)
           yy = y + r * Sin(t + o)
           #gr "place ";xx;" ";yy;"; circle ";r
           call drawc xx, yy, a * r, a, n - 1, o*-2
       Next
   End If
End Sub

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



[plus]

Well that's an interesting mod, have no idea why 2 main wheels now?

[marshawn]

Feb 20, 2022 15:01:07 GMT plus said:

no idea why 2 main wheels now?

bplus got outbplussed!

[plus]

Feb 20, 2022 21:28:23 GMT marshawn said:

Feb 20, 2022 15:01:07 GMT plus said:

no idea why 2 main wheels now?

bplus got outbplussed!

LOL! yeah, tsh73 and Rod will do that!

[marshawn]

meaningless lines


H$ = "gr"
'z = x + iy
'w = f(z) = u + iv
global pi, u, v, mx, my, sw2, sh2, zoom
pi = 4*atn(1)

zoom = 100

nomainwin
sw = 640
sh = 480
sw2 = sw/2
sh2 = sh/2
WindowWidth = sw
WindowHeight = sh
'it doesnt have to work
'it has to look pretty
UpperLeftX = 0
UpperLeftY = 0

open "Just Universe" for graphics_nsb_nf as #gr
#gr "trapclose quit"
#gr "down"

'for a=0 to 2*pi step 2*pi/16
'    x = 0*cos(a)
'    y = 0*sin(a)
'    #gr "place ";x*zoom + sw/2;" ";sh/2 - y*zoom

'    for t=0 to 5 step 0.01
'        x = t*cos(a)
'        y = t*sin(a)
'        #gr "goto ";x*zoom + sw/2;" ";sh/2 - y*zoom
'    next
'next

'for m=0 to 3 step 0.5
'    for t=0 to 2*pi step 0.01
'        x = m*cos(t)
'        y = m*sin(t)
'        #gr "goto ";x*zoom + sw/2;" ";sh/2 - y*zoom
'    next
'next

#gr "fill white"
#gr "color black"

for a=0 to 8*pi step 2*pi/16
   st = 0-0.07
   call fz 5*cos(a), 5*sin(a), 1
   #gr "place ";sw2 + u*zoom;" ";sh2 - v*zoom
   for t=5 to 0 step st
       call fz t*cos(a), t*sin(a), 1
       p = sw2 + u*zoom
       q = sh2 - v*zoom
       if p<0  then exit for
       if p>sw then exit for
       if q<0  then exit for
       if q>sh then exit for
       #gr "goto ";p;" ";q
   next

   call fz 5*cos(a), 5*sin(a), -1
   #gr "place ";sw2 + u*zoom;" ";sh2 - v*zoom
   for t=5 to 0 step st
       call fz t*cos(a), t*sin(a), -1
       p = sw2 + u*zoom
       q = sh2 - v*zoom
       if p<0  then exit for
       if p>sw then exit for
       if q<0  then exit for
       if q>sh then exit for
       #gr "goto ";p;" ";q
   next
next

for m=0 to 2 step 0.5
   st = pi/8
   call fz m*cos(0), m*sin(0), -1
   #gr "place ";sw2 + u*zoom;" ";sh2 - v*zoom
   for t=0 to pi step st
       call fz m*cos(t), m*sin(t), -1
       #gr "goto ";sw2 + u*zoom;" ";sh2 - v*zoom
   next
   for t=pi+st to 3*pi step st
       call fz m*cos(t), m*sin(t), 1
       #gr "goto ";sw2 + u*zoom;" ";sh2 - v*zoom
   next
   for t=pi+st to 2*pi+st step st
       call fz m*cos(t), m*sin(t), -1
       #gr "goto ";sw2 + u*zoom;" ";sh2 - v*zoom
   next
next
#gr "flush"

wait

sub quit Hdl$
   close #Hdl$
   end
end sub

'u + iv = (x + iy)(a + ib)
sub cmul xx, yy, aa, bb
   x = xx
   y = yy
   a = aa
   b = bb
   u = x*a - y*b
   v = x*b + y*a
end sub

'u + iv = (x + iy)/(a + ib)
sub cdiv xx, yy, aa, bb
   x = xx
   y = yy
   a = aa
   b = bb
   d = a*a + b*b
   if d<>0 then
       u = (x*a + y*b)/d
       v = (y*a - x*b)/d
   else
       u = 0
       v = 0
   end if
end sub

function sgn(x)
   if x >= 0 then
       sgn = 1
   else
       sgn = -1
   end if
end function

'u + iv = sqrt(x + iy)
sub sqrtz xx, yy
   x = xx
   y = yy
   d = sqr(x*x + y*y)
   u = sqr((d + x)/2)
   v = sgn(y)*sqr((d - x)/2)
end sub

'w = f(z) = (z + 1)/((z - 1 + i)(z - 1 - i))
'z = f^{-1}(w) = -(w*mx - w - 1) - i*w*(my + 1)
'                +- sqrt{((w*mx - w - 1) + i*w*(my + 1))^2 - 4*w*(-w*mx - w*my - 1 + i*w*(mx - my))}
'                ----------------
'                    2*w
sub fz x, y, s
   call cmul -2*x - 1, -2*y, -2*x - 1, -2*y
   uu = u
   vv = v
   call cmul 4*x, 4*y, 2*x - 1, 2*y
   call sqrtz uu - u, vv - v
   call cdiv 2*x + 1 + s*u, 2*y + s*v, 2*x, 2*y

   'bx = mx*x - my*y - x - y - 1
   'by = mx*y + my*x + x + y
   'call cmul bx, by, bx, by
   'uu = u
   'vv = v
   'cx = 0-mx*(x + y) - my*(x - y) - 1
   'cy = 0-mx*(y - x) - my*(y + x)
   'call cmul 4*x, 4*y, cx, cy
   'call sqrtz uu - u, vv - v

   'pp = 0-bx + s*u
   'qq = 0-by + s*v
   'call cdiv pp, qq, 2*x, 2*y
end sub


[tenochtitlanuk]

Not meaningless! Immediately said to me 'Fields and Potentials'. Jack Ord had lots of stuff like this a decade and a half ago. Inspired me!

Originally coded in JAVA from 1995, he then moved to LB. Later he moved to another BASIC- easily alterable to LB if you want to. I suspect I downloaded many of his original LB versions to add to my own or inspire me.



EDIT The Wayback Machine has much of the original LB stuff. Try web.archive.org/web/20120121084942/http://www.kw.igs.net/~jackord/j6.html#p1

.. and a late addition at www.kw.igs.net/~jackord/

[plus]

+! Not meaningless, wow what a great link John!

[tenochtitlanuk]

Jack Ord's code-
' ga1lib.bas - [e-mail] - updated 28 Feb 08 - Liberty Basic v4.02
' fieldlines and equipotentials for an equilateral mass array

' Initialize Window
 nomainwin
 WindowWidth=426    ' pixel scale 0-408
 WindowHeight=374   ' pixel scale 0-336
 UpperLeftX=100: UpperLeftY=50
 button#1, "Plot", [plot], UL, 6, 6, 40, 18
 open "Fieldlines and Equipotentials" for graphics_nsb as #1
 #1 "trapclose [quit]"

' Initialize and Plot Equilateral Array
 dim m(4): dim p(4): dim q(4)
 d=1: pi=4*atn(1)
 m(1)=1: m(2)=1: m(3)=1
 p(1)=121: q(1)=216: p(2)=204: q(2)=72: p(3)=287: q(3)=216
 #1 "down ; backcolor pink"
 for i=1 to 3
   #1 "place "; p(i); " "; q(i)
   #1 "circlefilled 12"
   #1 "place "; p(i)-6; " "; q(i)+5: #1 "\M"
 next i

[waitHere]
 wait

[plot]
' Plot Fieldlines
 #1 "color blue"
 for j=1 to 3
   for i=1 to 24
     t=(2*i-1)*pi/24: x=p(j)+12*cos(t): y=q(j)+12*sin(t)
     gosub [fdln]
   next i
 next j

' Plot Equipotentials
 #1 "color red"
 for i=1 to 11
   x=204: y=162+14*i
   gosub [eqpt]
 next i
goto [waitHere]

[quit]
 close#1
end

[fdln] ' Fieldline Subroutine
 #1 "place "; int(x); " "; int(y)
 tst=0: dx=0: dy=0: gosub [grav]
 dx=0-gx*d: dy=0-gy*d
 while tst=0
   dxo=dx: dyo=dy: gosub [grav]
   dx=0-gx*d: dy=0-gy*d: x=x+dx: y=y+dy
   #1 "goto "; int(x); " "; int(y)
   if x<0 or y<0 or x>408 or y>336 then tst=1
   if dxo*dx<0 and dyo*dy<0 then tst=1
 wend
return

[eqpt] ' Equipotential Subroutine
 #1 "place "; int(x); " "; int(y)
 dx=0: dy=0: gosub [grav]
 dx=gy*d: dy=0-gx*d: dxi=dx: xold=x
 while (xold-204)*dxi>=0 or (x-204)*dxi<0
   gosub [grav]
   dx=gy*d: dy=0-gx*d: xold=x: x=x+dx: y=y+dy
   #1 "goto "; int(x); " "; int(y)
 wend
return

[grav] ' Field Subroutine
 xx=x+dx/2: yy=y+dy/2: gx=0: gy=0
 for k=1 to 3
   r(k)=((xx-p(k))*(xx-p(k))+(yy-q(k))*(yy-q(k)))^1.5
   gx=gx+m(k)*(p(k)-xx)/r(k): gy=gy+m(k)*(q(k)-yy)/r(k)
 next k
 gg=(gx*gx+gy*gy)^.5: gx=gx/gg: gy=gy/gg
return


[marshawn]

wow nice, you JB guys are on another level!