Squares
-
- Site Admin
- Posts: 6323
- Joined: Jul 05, 2005 17:32
- Location: Manchester, Lancs
-
- Posts: 2655
- Joined: Aug 28, 2008 10:54
- Location: new york
Faster than native square root:
http://www.freebasic.net/forum/viewtopi ... highlight=
<EDIT>
Here is an optimized version of it:
http://www.freebasic.net/forum/viewtopi ... highlight=
<EDIT>
Here is an optimized version of it:
Code: Select all
' Square Roots!
' by Kristopher Windsor
Function squareroot (Byval number As Double ) As Double
dim As Double r1=1, r2=any
Do
r2 = r1
r1 = (r1 + number / r1) * .5
Loop Until Abs(r1 - r2) < .001
Return r1
End Function
dim as double t
t=timer
? sqr(666666669911)
? timer-t
t=timer
? squareroot (666666669911)
? timer-t
sleep
This avoids timing the print routines...
Code: Select all
' Square Roots!
' by Kristopher Windsor
Function squareroot (Byval number As Double ) As Double
Dim As Double r1=1, r2=Any
Do
r2 = r1
r1 = (r1 + number / r1) * .5
Loop Until Abs(r1 - r2) < .001
Return r1
End Function
Dim As Double t1, t2, r, s = 666666669911
print
t1=Timer
t2=Timer
Print using " ###.### usec. Empty timing "; (t2 - t1) * 1e6
print
t1=Timer
r = Sqr(s)
t2 = Timer
Print using " ###.### usec. Native FB square root"; (t2 - t1) * 1e6
print
t1 = Timer
r = squareroot(s)
t2 = Timer
Print using " ###.### usec. KW's square root"; (t2 - t1) * 1e6
Sleep
-
- Posts: 2655
- Joined: Aug 28, 2008 10:54
- Location: new york
I drew this one up for non-convex poly collisions... Cheap, easy... Just like me.
Question: How do you paint the perfect picture?
Answer: Make yourself perfect and just paint naturally.
Doesn't compile. Treat as pseudo-code. I just thought this would be fun to do after spending so long on SAT. This is so much easier! You can barely tell where it goes screwy.
Question: How do you paint the perfect picture?
Answer: Make yourself perfect and just paint naturally.
Doesn't compile. Treat as pseudo-code. I just thought this would be fun to do after spending so long on SAT. This is so much easier! You can barely tell where it goes screwy.
Code: Select all
function ProcessHardBodyCollision_PiP ( byref p1 as polygon, byref p2 as polygon ) as point2d
for i as integer = 0 to p2.numvertices-1
if p1.InsidePoly2d ( p2.matrix[i] ) then
return ( p2.center - p1.center ).unit
endif
next
for i as integer = 0 to p1.numvertices-1
if p2.InsidePoly2d ( p1.matrix[i] ) then
return ( p2.center - p1.center ).unit
endif
next
return type(0,0)
end function
-
- Posts: 2655
- Joined: Aug 28, 2008 10:54
- Location: new york
Here is Eclipzer's spline slightly faster... Can still be opt'd mo'
Code: Select all
#include once "fbgfx.bi"
#define screen_x 800
#define screen_y 600
type Colour
as ubyte Red
as ubyte Green
as ubyte Blue
as ubyte Alpha
declare Constructor ()
declare Constructor ( byref rhs as colour )
declare Operator Let ( byref rhs as colour )
declare Operator Let ( byval rhs as integer )
declare sub Set ( byref r as ubyte, byref g as ubyte, byref b as ubyte, byref a as ubyte )
declare function GetInteger () as integer
declare sub Darken ( byref amount as integer )
declare sub Lighten ( byref amount as integer )
end Type
Constructor Colour ()
this.red = 255
this.green = 255
this.blue = 255
this.alpha = 255
end Constructor
Constructor Colour ( byref rhs as colour )
this.red = rhs.red
this.green = rhs.green
this.blue = rhs.blue
this.alpha = rhs.alpha
end Constructor
Operator Colour.Let ( byref rhs as colour )
this.red = rhs.red
this.green = rhs.green
this.blue = rhs.blue
this.alpha = rhs.alpha
end Operator
Operator Colour.Let ( byval rhs as integer )
this.red = (rhs shr 16) 'AND 255
this.green = (rhs shr 8) 'AND 255
this.blue = (rhs) 'AND 255
this.alpha = (rhs shr 24) 'AND 255
end Operator
sub Colour.Set ( byref r as ubyte, byref g as ubyte, byref b as ubyte, byref a as ubyte )
Red=r
Blue=b
Green=g
Alpha=a
end sub
function Colour.GetInteger () as integer
return RGBA(Red,Green,Blue,Alpha)
end function
sub Colour.Darken ( byref amount as integer )
Red -= amount
Green -= amount
Blue -= amount
if red < 0 then red = 0
if green < 0 then green = 0
if blue < 0 then blue = 0
end sub
sub Colour.Lighten ( byref amount as integer )
Red += amount
Green += amount
Blue += amount
if red > 0 then red = 255
if green > 0 then green = 255
if blue > 0 then blue = 255
end sub
Sub sub_line ( byref screenbuffer as fb.image ptr, byval x1 As Integer, byval y1 As Integer, byval x2 As Integer, byval y2 As Integer, byval thickness As Integer, Byref clr As colour )
'Original Author: Quinton Roberts (Eclipzer)
'Optimized by: Rollie Bollocks
dim as ubyte ptr pixdata = Cast( Ubyte Ptr, screenbuffer ) + Sizeof( FB.IMAGE )
Dim As Integer alpha=clr.alpha
Dim As Integer t2=thickness/2
Dim As Integer bx(1)={x1,x2}
Dim As Integer by(1)={y1,y2}
Dim As Integer LI=0,RI=1
Dim As Integer TI=0,BI=1
If bx(LI)>bx(RI) Then Swap LI,RI
If by(TI)>by(BI) Then Swap TI,BI
Dim As Single dx=(bx(RI)-bx(LI))
Dim As Single dy=(by(RI)-by(LI))
Dim As Single dydx=dy/dx
Dim As Single dydx2=dydx*dydx
Dim As Single b=y1-dydx*x1,d
Dim As Single ndx=-dy
Dim As Single ndy= dx
Dim As Single length=1/Sqr(dx*dx+dy*dy)
Dim As Single nx=ndx*length
Dim As Single ny=ndy*length
Dim As Single px,py
For y As Integer=by(TI)-t2 To by(BI)+t2
For x As Integer=bx(LI)-t2 To bx(RI)+t2
If dx Then 'non-vertical line
d=(dydx*x-y+b)/Sqr(dydx2+1) 'point-to-line distance equation
px=x+d*nx 'projected x
py=y+d*ny 'projected y
Select Case px
Case Is < bx(LI)
Dim As Single xx=x-bx(LI)
Dim As Single yy=y-by(LI)
d=Sqr(xx*xx+yy*yy)
Case Is > bx(RI)
Dim As Single xx=x-bx(RI)
Dim As Single yy=y-by(RI)
d=Sqr(xx*xx+yy*yy)
Case Else: d=Abs(d)
End Select
Else 'vertical line
Select Case y
Case Is < by(TI)
Dim As Single xx=x-bx(TI)
Dim As Single yy=y-by(TI)
d=Sqr(xx*xx+yy*yy)
Case Is > by(BI)
Dim As Single xx=x-bx(BI)
Dim As Single yy=y-by(BI)
d=Sqr(xx*xx+yy*yy)
Case Else: d=x-x1
End Select
End If
If d<t2 Then
clr.alpha=alpha
if x > 0 and x < screen_x then
if y > 0 and y < screen_y then
Cast( Uinteger Ptr, pixdata + ( x * screenbuffer->Pitch ) )[ y ] = clr.getinteger
endif
endif
Elseif (d-t2)<=1 Then
clr.alpha=alpha*(1-(d-t2))
if x > 0 and x < screen_x then
if y > 0 and y < screen_y then
Cast( Uinteger Ptr, pixdata + ( x * screenbuffer->Pitch ) )[ y ] = clr.getinteger
endif
endif
End If
Next
Next
End Sub
'RANDOMIZE TIMER
'
Screen 19,32,,fb.gfx_ALPHA_PRIMITIVES
''
dim shared as fb.image ptr screenbuffer
screenbuffer = imagecreate(800,600)
dim as double t
dim as colour clr
clr = RGBA(255,0,0,255)
t=timer
for i as integer = 1 to 1000
sub_line( screenbuffer, 100, 100, 200, 200, 10, clr )
next
? timer-t
Put (0,0),screenbuffer,trans
sleep
Hi Rollie~rolliebollocks wrote:I drew this one up for non-convex poly collisions... Cheap, easy... Just like me.
Question: How do you paint the perfect picture?
Answer: Make yourself perfect and just paint naturally.
I'm working on the two poly collisions, nearly there.
I've simplified rotate2d to a function, rotating a point around a pivot.
I'll leave community discussion, I've said my piece.
Anyway, in the meantime I've put together a compendium of past snatches, ghosts of past doodles if you like, for ALBERT.
@RICHARD
I'm pleased you've been chosen as moderator.
I don't mind getting kicked out by you, and there would be no hard feelings.
There's something lost and something gained every day, I think maybe you have lost a degree of freedom to gain an axe.
But never mind, If you feel as trussed up as a turkey at times, just think of Mac Pherson in his farewell rant
"Tak' aff these bands frae roun' my hands,
gae back to me my sword"
Here's the little doodle for Albert.
Code: Select all
Sub ball_not2d(cx As Double,_ 'CENTRES
cy As Double,_
radius As Double,_
col() As Uinteger,_ 'COLOUR ARAY, 2 Dimensions
offsetX As Double=0,_ 'Bright spot (0 to about .9)
offsetY As Double=0,_
e As Double=0,_ 'eccentricity
resolution As Double=32,_ 'number of circles drawn
im As Any Pointer=0)
Dim As Double d',px,py
Dim As Integer red,green,blue,r,g,b
Dim As Double ox,oy,nx,ny 'ox,oy offset centres position, nx,ny New moving centres
Dim As Integer n=col(0,0)
ox=cx+offsetX*radius
oy=cy+offsetY*radius
red=col(n,1)
green=col(n,2)
blue=col(n,3)
For d = radius To 0 Step -radius/resolution
nx=(cx-ox)*(d-radius)/radius + cx 'linear mappings for moving centre
ny=(cy-oy)*(d-radius)/radius + cy
r=-red*(d/radius-1)
g=-green*(d/radius-1)
b=-blue*(d/radius-1)
Circle im,(nx,ny),d,rgb(r,g,b),,,e,F
Next d
End Sub
declare Function r(first As Double, last As Double) As Double
declare sub drawpolygon(x() as double,y() as double,colour as uinteger,im as any pointer=0)
declare sub drawstars(starx as double,stary as double,size as double,col as uinteger)
declare sub paintstring(x as double,_
y as double,_
s as string,_
size as double,_
c as uinteger,_
line_angle as double=0,_
char_angle as double=0,_
thickness_tweak as double=1,_
image as any pointer=0)
Dim Shared np(1 To 4) As Double
dim shared as double next_x,next_y
Dim As Double deg,radians = Atn(1)/45
Dim As Single s, c, mod_s, mod_c
Dim As Integer x, y, xctr, yctr, radius
Dim As Single modifier
Dim As Integer toggle
dim shared as integer xres,yres
xres=1000
yres=700
#include "fbgfx.bi"
Screenres xres,yres,32,1,fb.GFX_ALPHA_PRIMITIVES
dim shared img as any pointer
img=imagecreate(xres,yres,rgb(10,10,20))
dim as uinteger colour(0,3),blue=rgba(85,85,255,50),white=rgb(205,205,205)
#macro galaxy(zz)
dim as double x7,y7,s7
dim as uinteger c7
paintstring(200,50,"ALBERT",3,rgb(100,0,0),0,10,1,img)
paintstring(700,300,"Get|",1,rgb(0,100,0),30,30,1,img)
paintstring(next_x,next_y,"well|",1.5,rgb(0,0,100),30,30,1,img)
paintstring(next_x,next_y,"SOON|",1.7,rgb(100,0,100),30,30,1,img)
paintstring(10,.8*yres,"From Rollie~ and Dodicat",1,rgb(10,50,50),0,0,1,img)
for z as integer=1 to 50
x7=r(0,xres)
y7=r(0,yres)
s7=r(1,2)
c7=rgb(r(200,255),r(100,200),r(100,200))
drawstars(x7,y7,s7,c7)
next z
#endmacro
colour(0,0)=0
colour(0,1)=100
colour(0,2)=50
colour(0,3)=150
xctr=400
yctr=290
radius=250
modifier = -.045
toggle = 0
dim looper as double
dim k as integer=1
galaxy(0)
Do
looper=looper+1*k
screenlock
Cls
put(0,0),img,pset
For deg = 0 To 360 Step .1
s = Sin(deg*radians)
c = Cos(deg*radians)
If deg >= 0 And deg <= 180 Then
mod_s = (180-(deg)) * ((deg)/180) * modifier
mod_c = 0'(180-(deg)) * ((deg)/180) * modifier
If deg >= 45 And deg <= 65 Then
mod_s = mod_s+(20-(deg-45)) * ((deg-45)/20) * modifier/2
mod_c = mod_c+(20-(deg-45)) * ((deg-45)/20) * modifier*2
End If
If deg >= 45 And deg <= 135 Then
mod_s = mod_s+-(90-(deg-45)) * ((deg-45)/90) * (modifier*2)
'mod_c = 0'(180-(deg)) * ((deg)/180) * modifier
End If
If deg >= 115 And deg <= 135 Then
mod_s = mod_s+(20-(deg-115)) * ((deg-115)/20) * modifier/2
mod_c = mod_c+-((20-(deg-115)) * ((deg-115)/20) * modifier*2)
End If
Else
mod_s=0
mod_c=0
End If
y=radius*(s+mod_s)
x=radius*(c+mod_c)
If mod_c<>0 Or mod_s <> 0 Then
' Pset(xctr+x,yctr+y),white'15
circle (xctr+x,yctr+y),5,white,,,,f
Else
'Pset(xctr+x,yctr+y),blue'9
circle (xctr+x,yctr+y),10,blue
End If
Next
colour(0,1)=100
colour(0,2)=100
colour(0,3)=100
ball_not2d(400-100,290-70,50,colour(),0,0,.2)
ball_not2d(400+100,290-70,50,colour(),0,0,.2)
colour(0,1)=100
colour(0,2)=50
colour(0,3)=150
ball_not2d(400-100,290,50,colour(),.8*looper/500,0)
ball_not2d(400+100,290,50,colour(),-.8*looper/500,0)
colour(0,1)=100
colour(0,2)=0
colour(0,3)=0
ball_not2d(400,310,50,colour(),0,.9,3)'
for z as double=400-50 to 400+50 step 20
colour(0,1)=255
colour(0,2)=255
colour(0,3)=200
ball_not2d(z,290+90,10,colour(),,4)
ball_not2d(z+10,290+160-(40*(looper-360)/360),10,colour(),,-4)''
colour(0,1)=0
colour(0,2)=50
colour(0,3)=0
ball_not2d(400-270,290,100,colour(),0,0,3)
ball_not2d(400+270,290,100,colour(),0,0,3)
next z
screenunlock
sleep 1,1
If toggle = 0 Then
modifier+=.0001
If modifier >= .005 Then toggle=1
Else
modifier-=.0001
If modifier <=-.045 Then toggle = 0
End If
if looper>500 then k=-k
if looper<0 then k=-k
Loop Until inkey =chr(27)
Function r(first As Double, last As Double) As Double
Function = Rnd * (last - first) + first
End Function
sub drawpolygon(x() as double,y() as double,colour as uinteger,im as any pointer=0)
dim k as integer=ubound(x)+1
dim as integer index,nextindex
dim as double xc,yc
for n as integer=1 to ubound(x)'+1
xc=xc+x(n):yc=yc+y(n)
index=n mod k:nextindex=(n+1) mod k
if nextindex=0 then nextindex=1
line im,(x(index),y(index))-(x(nextindex),y(nextindex)),colour
next
xc=xc/ubound(x):yc=yc/ubound(y)
paint im,(xc,yc),colour,colour
end sub
sub drawstars(starx as double,stary as double,size as double,col as uinteger)
dim as double xstar(8),ystar(8)
dim l as double=4*size
Xstar(1)=starX : Ystar(1)=starY-l
Xstar(2)=starX+size:Ystar(2)=starY-size
Xstar(3)=starX+l:Ystar(3)=starY
Xstar(4)=starX+size:Ystar(4)=starY+size
Xstar(5)=starX:Ystar(5)=starY+l
Xstar(6)=starX-size:Ystar(6)=starY+size
Xstar(7)=starX-l:Ystar(7)=starY
Xstar(8)=starX-size:Ystar(8)=starY-size
drawpolygon(Xstar(),Ystar(),col,img)
end sub
Sub rotate(Byval pivot_x As Double,_ 'turns about this point
Byval pivot_y As Double,_
Byval first_x As Double,_ 'centre for circles
Byval first_y As Double,_
Byval second_x As Double, _ 'radius for circles
Byval second_y As Double, _ 'aspect
byval arc_1 as double,_ 'arcs only for circle, 0 for lines
byval arc_2 as double,_
Byval angle As Double, _ 'all below for circles and lines
Byval magnifier As Double,_
Byval dilator as double,_
Byval colour As Integer,_
byval thickness as double,_
Byref shape As String,_
image as any pointer=0)
'rotated line is (np(1),np(2))-(np(3),np(4))
'rotated circle centre is np(3),np(4)
'shape:
'line - draws the line
'linepoint - does the calculation, draws nothing
'linepointset - does the calculations, sets a pixel at the line ends
'ALSO circle,circlepoint, circlepointset,box, boxfill, circlefill.
'arcs from horizontal positive x axis in DEGREES
'arc1<arc2 always e.g from 330 to 430
shape=lcase$(shape)
Dim p As Double = 4*Atn(1) '(pi)
Dim radians As Double
Dim line_xvector As Double
Dim line_yvector As Double
Dim pivot_xvector As Double
Dim pivot_yvector As Double
Dim th As Double
th=thickness
Dim sx As Double=second_x
angle=angle mod 360
radians=(2*p/360)*angle 'change from degrees to radians
#Macro thickline(t)
Dim As Double s,h,c
Dim As Uinteger prime=rgb(255,255,255)
h=Sqr(((np(1))-(np(3)))^2+((np(2))-(np(4)))^2)
s=((np(4))-np(2))/h
c=(np(1)-(np(3)))/h
line image, (np(3)+s*t/2,np(4)+c*t/2)-(np(1)+s*t/2,np(2)+c*t/2),prime
line image, (np(3)-s*t/2,np(4)-c*t/2)-(np(1)-s*t/2,np(2)-c*t/2),prime
line image, (np(3)+s*t/2,np(4)+c*t/2)-(np(3)-s*t/2,np(4)-c*t/2),prime
line image, (np(1)+s*t/2,np(2)+c*t/2)-(np(1)-s*t/2,np(2)-c*t/2),prime
paint image,((np(3)+np(1))/2, (np(4)+np(2))/2),prime,prime
line image, (np(3)+s*t/2,np(4)+c*t/2)-(np(1)+s*t/2,np(2)+c*t/2),colour
line image, (np(3)-s*t/2,np(4)-c*t/2)-(np(1)-s*t/2,np(2)-c*t/2),colour
line image, (np(3)+s*t/2,np(4)+c*t/2)-(np(3)-s*t/2,np(4)-c*t/2),colour
line image, (np(1)+s*t/2,np(2)+c*t/2)-(np(1)-s*t/2,np(2)-c*t/2),colour
paint image,((np(3)+np(1))/2, (np(4)+np(2))/2), colour, colour
#EndMacro
#macro thickcircle(t)
Dim As Uinteger prime=rgb(255,255,255)
dim as double xp1,xp2,yp1,yp2
dim arc1 as double=arc_1*p/180
dim arc2 as double=arc_2*p/180
arc1=2*p+(arc1-(radians))
arc2=2*p+(arc2-(radians))
sx=sx*magnifier
if arc1=arc2 then
circle image,(np(3),np(4)),sx+t/2,prime,,,second_y
circle image,(np(3),np(4)),sx-t/2,prime,,,second_y
paint image,(np(3),np(4)+sx),prime,prime
paint image,(np(3)+sx,np(4)),prime,prime
circle image,(np(3),np(4)),sx+t/2,colour,,,second_y
circle image,(np(3),np(4)),sx-t/2,colour,,,second_y
paint image,(np(3),np(4)+sx),colour,colour
paint image,(np(3)+sx,np(4)),colour,colour
end if
if arc1<>arc2 then
xp1=np(3)+(sx)*cos(.5*(arc2+arc1))
yp1=np(4)-(sx)*sin(.5*(arc2+arc1))
circle image,(np(3),np(4)),sx+t/2,prime,arc1,arc2,second_y
circle image,(np(3),np(4)),sx-t/2,prime,arc1,arc2,second_y
line image,(np(3)+(sx+t/2)*cos(arc1),np(4)-(sx+t/2)*sin(arc1))-(np(3)+(sx-t/2)*cos(arc1),np(4)-(sx-t/2)*sin(arc1)),prime
line image,(np(3)+(sx+t/2)*cos(arc2),np(4)-(sx+t/2)*sin(arc2))-(np(3)+(sx-t/2)*cos(arc2),np(4)-(sx-t/2)*sin(arc2)),prime
paint image,(xp1,yp1),prime,prime
circle image,(np(3),np(4)),sx+t/2,colour,arc1,arc2,second_y
circle image,(np(3),np(4)),sx-t/2,colour,arc1,arc2,second_y
line image,(np(3)+(sx+t/2)*cos(arc1),np(4)-(sx+t/2)*sin(arc1))-(np(3)+(sx-t/2)*cos(arc1),np(4)-(sx-t/2)*sin(arc1)),colour
line image,(np(3)+(sx+t/2)*cos(arc2),np(4)-(sx+t/2)*sin(arc2))-(np(3)+(sx-t/2)*cos(arc2),np(4)-(sx-t/2)*sin(arc2)),colour
paint image,(xp1,yp1),colour,colour
end if
#endmacro
magnifier=dilator*magnifier
pivot_xvector=first_x-pivot_x
pivot_yvector=first_y-pivot_y
pivot_xvector=dilator*pivot_xvector
pivot_yvector=dilator*pivot_yvector
Dim mover(1 To 2,1 To 2) As Double
Dim new_pos(1 To 2) As Double
mover(1,1)=Cos(radians)
mover(2,2)=Cos(radians)
mover(1,2)=-Sin(radians)
mover(2,1)=Sin(radians)
line_xvector=magnifier*(second_x-first_x) 'get the vector
line_yvector=magnifier*(second_y-first_y) 'get the vector
new_pos(1)=mover(1,1)*pivot_xvector+mover(1,2)*pivot_yvector +pivot_x
new_pos(2)=mover(2,1)*pivot_xvector+mover(2,2)*pivot_yvector +pivot_y
Dim new_one(1 To 2) As Double 'To hold the turned value
new_one(1)=mover(1,1)*line_xvector+mover(1,2)*line_yvector +first_x
new_one(2)=mover(2,1)*line_xvector+mover(2,2)*line_yvector +first_y
Dim xx As Double 'translation
Dim yy As Double
xx=first_x-new_pos(1)
yy=first_y-new_pos(2)
np(1)=new_one(1)-xx
np(2)=new_one(2)-yy
np(3)=first_x-xx
np(4)=first_y-yy
Select Case shape
Case "line"
If th<2 Then
line image,(np(3),np(4))-(np(1),np(2)),colour
Else
thickline(th)
End If
Case "circle"
dim arc1 as double=arc_1*p/180
dim arc2 as double=arc_2*p/180
if arc1=arc2 then
If th<=3 Then
for n as double=magnifier*sx-1 to magnifier*sx+1 step .5
circle image,(np(3),np(4)),n,colour,,,second_y
'circle image,(np(3),np(4)),magnifier*sx,colour,,,second_y
next n
Else
thickcircle(th)
End If
endif
if arc1<>arc2 then
If th<=3 Then
arc1=2*p+(arc1-(radians))'new
arc2=2*p+(arc2-(radians))'new
for n as double=magnifier*sx-1 to magnifier*sx+1 step .5
circle image,(np(3),np(4)),n,colour,arc1,arc2,second_y
' circle image,(np(3),np(4)),magnifier*sx,colour,arc1,arc2,second_y
next n
else
thickcircle(th)
end if
end if
Case "circlefill"
dim as double xp1,xp2,yp1,yp2
Dim As Uinteger prime=rgb(255,255,255)
dim arc1 as double=arc_1*p/180
dim arc2 as double=arc_2*p/180
if arc1=arc2 then circle image,(np(3),np(4)),magnifier*sx,colour,,,second_y,F
if arc1<>arc2 then
xp1=np(3)+magnifier*sx*cos(.5*(arc2+arc1))*3/4
yp1=np(4)-magnifier*sx*sin(.5*(arc2+arc1))*3/4
circle image,(np(3),np(4)),magnifier*sx,prime,arc1,arc2,second_y
line image,(np(3),np(4))-(np(3)+magnifier*sx*cos(arc2),np(4)-magnifier*sx*sin(arc2)),prime
line image,(np(3),np(4))-(np(3)+magnifier*sx*cos(arc1),np(4)-magnifier*sx*sin(arc1)),prime
paint image,(xp1,yp1),prime,prime
circle image,(np(3),np(4)),magnifier*sx,colour,arc1,arc2,second_y
line image,(np(3),np(4))-(np(3)+magnifier*sx*cos(arc2),np(4)-magnifier*sx*sin(arc2)),colour
line image,(np(3),np(4))-(np(3)+magnifier*sx*cos(arc1),np(4)-magnifier*sx*sin(arc1)),colour
paint image,(xp1,yp1),colour,colour
end if
Case"box"
line image,(np(3),np(4))-(np(1),np(2)),colour,b
Case "boxfill"
line image,(np(3),np(4))-(np(1),np(2)),colour,bf
Case "linepoint","circlepoint"
'nothing drawn
Case "linepointset","circlepointset"
If shape="linepointset" Then
Pset image,(np(1),np(2)),colour
Pset image,(np(3),np(4)),colour
Endif
If shape="circlepointset" Then
Pset image,(np(3),np(4)),colour
End If
Case Else
Print "unknown rotation shape"
End Select
End Sub
'dim shared as double next_x,next_y
sub paintstring(x as double,_
y as double,_
s as string,_
size as double,_
c as uinteger,_
line_angle as double=0,_
char_angle as double=0,_
thickness_tweak as double=1,_
image as any pointer=0)
dim l as integer=len(s)
dim px as double=16*size+x
y=y+16*size
dim py as double=y'16*size+y
dim z as integer=0
dim th as double'=4
th=((.5-size)/4.5+5)*thickness_tweak
dim sp as double=6
dim sp2 as double=6
dim pi as double=4*atn(1)
dim la as double=(line_angle *.5)
dim ca as double=(char_angle*.5)
sp2=sp2+30*abs(sin(ca*pi/180-la*pi/180))
#macro set(x1,y1,x2,y2,sarc,earc,shape,im)
rotate(px,py,x1,y1,x2,y2,sarc,earc,-char_angle,1,size,c,th*size,shape,im)
#endmacro
#macro spaces(xpixels,ypixels)
px=px+(xpixels*size+sp2*size)*cos(line_angle*pi/180)
py=py-(ypixels*size+sp2*size)*sin(line_angle*pi/180)
next_x=px-16*size
next_y=py-16*size
#endmacro
for n as integer=1 to l
select case mid$(s,n,1)
case " "
spaces(30,30)
case "|"
z=z+1
px=(x+16*size+z*16*sin(line_angle*pi/180))+1.3*z*(24*size+size*sp*size)*sin(line_angle*pi/180)
py=(y+z*16*cos(line_angle*pi/180))+1.3*z*(24*size+size*sp*size)*cos(line_angle*pi/180)
next_x=px-16*size
next_y=py-16*size
case "1"
set(px-8,py-18,px-8,py+16,.0,.0,"line",image)'vert
set(px-8,py-16,px-12,py-8,.0,.0,"line",image)
spaces(12,12)
case "2"
set(px-2,py-8,9,1,310,530,"circle",image)'curve
set(px-15,py+14,px+5,py-2,.0,.0,"line",image)
set(px-16,py+14,px+10,py+14,.0,.0,"line",image)'base
spaces(28,28)
case "3"
set(px-2,py-7,9,1,300,530,"circle",image)'curve top
set(px-2,py+6,9,1,190,395,"circle",image)'curve
set(px-3,py,px+5,py,.0,.0,"line",image)
spaces(28,28)
case "4"
set(px-16,py+4,px+12,py+4,.0,.0,"line",image)'horiz
set(px-14,py+4,px+4,py-16,.0,.0,"line",image)'slope
set(px+4,py-18,px+4,py+16,.0,.0,"line",image)
spaces(28,28)
case "5"
set(px-14,py-16,px+6,py-16,.0,.0,"line",image)'top
set(px-12,py-16,px-12,py+1,.0,.0,"line",image)'vert
set(px-4,py+6,9,1,210,500,"circle",image)'curve
spaces(28,28)
case "6"
set(px-2,py+6,9,1,360,360,"circle",image)'curve base
set(px+16,py+4,27,1,130,180,"circle",image)'curve edge
spaces(28,28)
case "7"
set(px-14,py-16,px+6,py-16,.0,.0,"line",image)'top
set(px+5,py-16,px-12,py+16,.0,.0,"line",image)'slope
spaces(26,26)
case "8"
set(px-2,py-7,9,1,320,575,"circle",image)'curve top
set(px-2,py+6,9,1,130,415,"circle",image)'curve
set(px-9,py-1,px+6,py-1,.0,.0,"line",image)
spaces(28,28)
case "9"
set(px-2,py-6,9,1,360,360,"circle",image)'top
set(px-20,py-4,27,1,310,360,"circle",image)
spaces(28,28)
case "0"
set(px,py-1,15,1,360,360,"circle",image)
spaces(36,36)
case "."
set(px-12,py+12,1,1,360,360,"circle",image)
spaces(10,10)
case "A"
set(px,py-16,px-12,py+16,.0,.0,"line",image)
set(px,py-16,px+12,py+16,.0,.0,"line",image)
set(px-8,py+3,px+8,py+3,.0,.0,"line",image)
spaces(30,30)'36
case "a"
set(px-4,py+4,10,1,360,360,"circle",image)
set(px+6,py-8,px+6,py+16,.0,.0,"line",image)
spaces(26,26)
case "B"
set(px-12,py-16,px-12,py+16,.0,.0,"line",image)'vert
set(px-12,py-14,px-5,py-14,.0,.0,"line",image)'top
set(px-12,py+14,px-5,py+14,.0,.0,"line",image)'base
set(px-5,py-6,8,1,290,450,"circle",image)'top loop
set(px-5,py+6,8,1,270,430,"circle",image)'base loop
set(px-12,py,px-2,py,.0,.0,"line",image)'middle
spaces(24,24)
case "b"
set(px-2,py+4,10,1,360,360,"circle",image)
set(px-12,py-16,px-12,py+16,.0,.0,"line",image)
spaces(28,28)
case "C"
set(px,py,14,1,60,300,"circle",image)
spaces(25,25)
case "c"
set(px-4,py+4,10,1,60,300,"circle",image)
spaces(20,20)
case "D"
set(px-12,py-16,px-12,py+16,.0,.0,"line",image)
set(px-5,py,14,1,270,450,"circle",image)
set(px-12,py-14,px-5,py-14,.0,.0,"line",image)
set(px-12,py+14,px-5,py+14,.0,.0,"line",image)
'rotate(px,py,px-24,py+20,px-24,py-20,0,0,-line_angle,1,size,rgb(255,0,0),1,"line",image)
spaces(30,30)
case "d"
set(px-4,py+4,10,1,360,360,"circle",image)
set(px+6,py-16,px+6,py+16,.0,.0,"line",image)
spaces(26,26)
case "E"
set(px-12,py-16,px-12,py+16,.0,.0,"line",image)'vert
set(px-12,py-14,px+6,py-14,.0,.0,"line",image)'top
set(px-12,py+14,px+6,py+14,.0,.0,"line",image)'base
set(px-12,py,px-2,py,.0,.0,"line",image)'middle
spaces(25,25)
case "e"
set(px-4,py+4,10,1,0,320,"circle",image)
set(px-12,py+3,px+8,py+3,.0,.0,"line",image)
spaces(26,26)
case "F"
set(px-12,py-16,px-12,py+16,.0,.0,"line",image)'vert
set(px-12,py-14,px+6,py-14,.0,.0,"line",image)'top
set(px-12,py,px-2,py,.0,.0,"line",image)'middle
spaces(24,24)
case "f"
set(px-2,py-8,10,1,0,170,"circle",image)'curve
set(px-12,py-10,px-12,py+16,.0,.0,"line",image)'vert
set(px-10,py,px-2,py,.0,.0,"line",image)'middle
spaces(28,28)
case "G"
set(px,py,14,1,50,350,"circle",image)
set(px,py,px+16,py,.0,.0,"line",image)
spaces(35,35)
case "g"
set(px-4,py+4,10,1,360,360,"circle",image)
set(px+6,py-6,px+6,py+20,.0,.0,"line",image)
set(px-4,py+17,10,1,230,345,"circle",image)
spaces(26,26)
case "H"
set(px-12,py-16,px-12,py+16,.0,.0,"line",image)'vert
set(px+12,py-16,px+12,py+16,.0,.0,"line",image)'vert
set(px-12,py,px+12,py,.0,.0,"line",image)'middle
spaces(32,32)
case "h"
'set(px-6,py+4,10,1,0,150,"circle",image)
set(px-4,py+2,8,1,0,170,"circle",image)'curve right
set(px-12,py-16,px-12,py+16,.0,.0,"line",image)
set(px+4,py,px+4,py+16,.0,.0,"line",image)
spaces(25,25)
case "I"
set(px,py+16,px,py-16,.0,.0,"line",image)'vert
set(px-12,py+14,px+12,py+14,.0,.0,"line",image)
set(px-12,py-14,px+12,py-14,.0,.0,"line",image)
spaces(30,30)
case "i"
set(px-12,py-6,px-12,py+16,.0,.0,"line",image)
set(px-12,py-14,1,1,360,360,"circle",image)
spaces(10,10)
case "J"
'set(px-2,py+4,12,1,200,270,"circle",image)
set(px-7,py+8,7,1,220,355,"circle",image)
set(px,py-16,px,py+9,.0,.0,"line",image)'vert
set(px-12,py-14,px+12,py-14,.0,.0,"line",image)'top
spaces(30,30)
case "j"
set(px,py-6,px,py+20,.0,.0,"line",image)
set(px-7,py+20,7,1,220,360,"circle",image)
set(px,py-14,1,1,360,360,"circle",image)
spaces(22,22)
case "K"
set(px-12,py-16,px-12,py+16,.0,.0,"line",image)'vert
set(px+6,py-16,px-12,py,.0,.0,"line",image)'upper
set(px+6,py+16,px-6,py-3,.0,.0,"line",image)
spaces(25,25)
case "k"
set(px-12,py-16,px-12,py+16,.0,.0,"line",image)'vert
set(px+3,py-6,px-12,py,.0,.0,"line",image)'upper
set(px,py+16,px-8,py-3,.0,.0,"line",image)'lower
spaces(20,20)
case "L"
set(px-12,py-16,px-12,py+16,.0,.0,"line",image)'vert
set(px-12,py+14,px+6,py+14,.0,.0,"line",image)'base
spaces(25,25)
case "l"
set(px-12,py-16,px-12,py+16,.0,.0,"line",image)'vert
spaces(10,10)
case "M"
set(px-12,py-16,px-12,py+16,.0,.0,"line",image)'vert
set(px+12,py-16,px+12,py+16,.0,.0,"line",image)'vert
set(px-12,py-16,px,py,.0,.0,"line",image)'left arm
set(px+12,py-16,px,py,.0,.0,"line",image)'right arm
spaces(32,32)
case "m"
set(px-6,py+2,6,1,0,170,"circle",image)'curve left
set(px+6,py+2,6,1,0,170,"circle",image)'curve right
set(px-12,py-5,px-12,py+16,.0,.0,"line",image)'vert left
set(px+12,py,px+12,py+16,.0,.0,"line",image)'vert right
set(px,py+16,px,py,.0,.0,"line",image)'mid arm
spaces(32,32)
case "N"
set(px-12,py-16,px-12,py+16,.0,.0,"line",image)'vert
set(px+12,py-16,px+12,py+16,.0,.0,"line",image)'vert
set(px-12,py-16,px+12,py+16,.0,.0,"line",image)'middle
spaces(32,32)
case "n"
set(px-4,py+2,8,1,0,170,"circle",image)'curve right
set(px-12,py-5,px-12,py+16,.0,.0,"line",image)'vert left
set(px+4,py+16,px+4,py,.0,.0,"line",image)'mid arm
spaces(24,24)
case "O"
set(px,py,14,1,360,360,"circle",image)
spaces(36,36)
case "o"
set(px-4,py+4,10,1,360,360,"circle",image)
'set(px+6,py-16,px+6,py+16,.0,.0,"line",image)
spaces(26,26)
case "P"
set(px-12,py-16,px-12,py+16,.0,.0,"line",image)'vert
set(px-12,py-14,px-5,py-14,.0,.0,"line",image)'top
'set(px-12,py+14,px-5,py+14,.0,.0,"line",image)'base
set(px-5,py-6,8,1,280,450,"circle",image)'top loop
'set(px-5,py+6,10,1,270,430,"circle",image)'base loop
set(px-12,py+2,px-2,py+2,.0,.0,"line",image)'middle
spaces(24,24)
case "p"
set(px-5,py+4,10,1,270,435,"circle",image)' loop
set(px-14,py-5,px-2,py-5,.0,.0,"line",image)'top
set(px-12,py+14,px-5,py+14,.0,.0,"line",image)'base
set(px-12,py-6,px-12,py+26,.0,.0,"line",image)'vert
spaces(24,24)
case "Q"
set(px,py,14,1,360,360,"circle",image)
set(px+5,py+20,16,1,400,460,"circle",image)
spaces(36,36)
case "q"
set(px-5,py+6,10,1,110,270,"circle",image)' loop
set(px-9,py-3,px+2,py-3,.0,.0,"line",image)'top
set(px-8,py+16,px,py+16,.0,.0,"line",image)'base
set(px,py-3,px,py+26,.0,.0,"line",image)'vert
spaces(20,20)
case "R"
set(px-12,py-16,px-12,py+16,.0,.0,"line",image)'vert
set(px-12,py-14,px-5,py-14,.0,.0,"line",image)'top
'set(px-12,py+14,px-5,py+14,.0,.0,"line",image)'base
set(px-5,py-6,8,1,290,450,"circle",image)'top loop
'set(px-5,py+6,10,1,270,430,"circle",image)'base loop
set(px-12,py+2,px-2,py+2,.0,.0,"line",image)'middle
set(px-8-1+3,py+1,px+12-8-1,py+16+1-2,.0,.0,"line",image)'slope
spaces(24,24)
case "r"
set(px-4,py+4,10,1,30,130,"circle",image)
set(px-12,py-8,px-12,py+16,.0,.0,"line",image)
spaces(24,24)
case "S"
set(px-2,py-7,8,1,20,240,"circle",image)'curve top
set(px-2,py+6,8,1,200,500,"circle",image)'curve
'set(px-9,py-1,px+6,py-1,.0,.0,"line",image)
spaces(26,26)
case "s"
set(px-4,py+4,10,1,40,140,"circle",image)'top
set(px-1,py-4,10,1,180,240,"circle",image)'topslant
set(px-6,py+14,10,1,20,100,"circle",image)'baseslant
set(px-4,py+4,10,1,220,325,"circle",image)'base
'set(px-12,py-4,px+2,py+12,.0,.0,"line",image)
'set(px+6,py-8,px+6,py+16,.0,.0,"line",image)
spaces(26,26)
case "T"
set(px,py-12,px,py+16,.0,.0,"line",image)'vert
set(px-16,py-12-2,px+16,py-12-2,.0,.0,"line",image)
spaces(34,34)
case "t"
set(px-12,py-16,px-12,py+10,.0,.0,"line",image)'edge
set(px-12,py-4,px-2,py-4,.0,.0,"line",image)
set(px-4,py+4,10,1,210,320,"circle",image)
spaces (24,24)
case "U"
set(px-12,py-16,px-12,py+8,.0,.0,"line",image)'vert
set(px+12,py-16,px+12,py+8,.0,.0,"line",image)'vert
set(px,py,14,1,205,335,"circle",image)
'set(px-12,py,px+12,py,.0,.0,"line",image)'middle
spaces(33,33)
case "u"
set(px-4,py+4,10,1,210,360,"circle",image)
set(px+6,py-6,px+6,py+16,.0,.0,"line",image)
set(px-12,py-6,px-12,py+10,.0,.0,"line",image)'left edge
spaces(26,26)
case "V"
set(px,py+16,px-12,py-16,.0,.0,"line",image)
set(px,py+16,px+12,py-16,.0,.0,"line",image)
'set(px-8,py+3,px+8,py+3,.0,.0,"line",image)
spaces(32,32)'36
Case "v"
set(px-12,py-6,px-4,py+16,.0,.0,"line",image)'left
set(px-4,py+16,px+4,py-6,.0,.0,"line",image)
spaces(24,24)
Case "W"
set(px-12,py-16,px-8,py+16,.0,.0,"line",image)'vert left
set(px+12,py-16,px+8,py+16,.0,.0,"line",image)'vert
set(px-8,py+16,px,py,.0,.0,"line",image)'left arm
set(px+8,py+16,px,py,.0,.0,"line",image)'right arm
spaces(32,32)
Case "w"
set(px-14,py-6,px-8,py+16,.0,.0,"line",image)'vert left
set(px+8,py+16,px+12,py-6,.0,.0,"line",image)'vert right
set(px-8,py+16,px,py,.0,.0,"line",image)'left arm
set(px+8,py+16,px,py,.0,.0,"line",image)'right arm
spaces(33,33)
case "X"
set(px-12,py-16,px+12,py+16,.0,.0,"line",image)
set(px+12,py-16,px-12,py+16,.0,.0,"line",image)
spaces(32,32)
case "x"
set(px-12,py-6,px+2,py+16,.0,.0,"line",image)
set(px+2,py-6,px-12,py+16,.0,.0,"line",image)
spaces(22,22)
case "Y"
set(px-12,py-16,px,py,.0,.0,"line",image)
set(px+12,py-16,px,py,.0,.0,"line",image)
set(px,py,px,py+16,.0,.0,"line",image)
spaces(32,32)
case "y"
set(px-4,py+4,8,1,180,380,"circle",image)'top
set(px+4,py-6,px+4,py+20,.0,.0,"line",image)'right
set(px-6,py+17,10,1,230,345,"circle",image)'base
set(px-12,py-6,px-12,py+4,.0,.0,"line",image)'left
spaces(24,24)
case "Z"
set(px-12,py-14,px+12,py-14,.0,.0,"line",image)'top
set(px-12,py+14,px+12,py+14,.0,.0,"line",image)
set(px+10,py-14,px-10,py+14,.0,.0,"line",image)'slope
spaces(30,30)
case "z"
set(px-16,py-4,px+2,py-4,.0,.0,"line",image)'top
set(px-16,py+14,px+2,py+14,.0,.0,"line",image)'base
set(px+1,py-5,px-14,py+14,.0,.0,"line",image)'slope
spaces(20,20)
'************************************************
case ","
set(px-12,py+12,px-18,py+20,.0,.0,"line",image)
set(px-12,py+12,1,1,360,360,"circle",image)
spaces(10,10)
case"£"
set(px-5,py-5,8,1,40,220,"circle",image)'top
set(px-19-5-5,py+10-5,18,1,320,390,"circle",image)
set(px-16,py+16,px+8,py+16,.0,.0,"line",image)'base
set(px-16,py+2,px,py+2,.0,.0,"line",image)
spaces(28,28)
case "$"
set(px-2,py-7,8,1,20,240,"circle",image)'curve top
set(px-2,py+6,8,1,200,495,"circle",image)'curve
set(px-2,py-17,px-2,py+17,.0,.0,"line",image)
'set(px-9,py-1,px+6,py-1,.0,.0,"line",image)
spaces(26,26)
case "%"
set(px-10,py-10,6,1,360,360,"circle",image)
set(px+10,py+10,6,1,360,360,"circle",image)
set(px+8,py-8,px-8,py+8,.0,.0,"line",image)
spaces(33,33)
case "^"
set(px-14,py,px-7,py-16,.0,.0,"line",image)
set(px-7,py-16,px,py,.0,.0,"line",image)
spaces(20,20)
case"&"
set(px-2,py-7,8,1,70,220,"circle",image)'curve top
set(px-2,py+6,8,1,110,415,"circle",image)'curve
set(px-4-4-2,py-8,px+12-4,py+16,.0,.0,"line",image)
'set(px-9,py-1,px+6,py-1,.0,.0,"line",image)
spaces(28,28)
case "*"
set(px-12,py-6-8,px+2,py+16-8,.0,.0,"line",image)
set(px+2,py-6-8,px-12,py+16-8,.0,.0,"line",image)
set(px-16,py-3,px+6,py-3,.0,.0,"line",image)
spaces(24,24)
case "("
set(px+22,py,38,1,150,210,"circle",image)
spaces(12,12)
case ")"
set(px-22-16-6,py,38,1,330,390,"circle",image)
spaces(12,12)
case "-"
set(px-16,py,px+8,py,.0,.0,"line",image)
spaces(26,26)
case "_"
set(px-16,py+16,px+16,py+16,.0,.0,"line",image)
spaces(34,34)
case "+"
set(px-16,py,px+8,py,.0,.0,"line",image)
set(px-4,py+12,px-4,py-12,.0,.0,"line",image)
spaces(26,26)
case "="
set(px-16,py-4,px+8,py-4,.0,.0,"line",image)
set(px-16,py+4,px+8,py+4,.0,.0,"line",image)
spaces(26,26)
case "!"
set(px-12,py-16,px-12,py+6,.0,.0,"line",image)
set(px-12,py+12,1,1,360,360,"circle",image)
spaces(10,10)
case "¬"
set(px-16,py+4,px+8,py+4,.0,.0,"line",image)
set(px+6,py+4,px+6,py+12,.0,.0,"line",image)
spaces(26,26)
case "`"
set(px-16,py-16,px-12,py-12,.0,.0,"line",image)
spaces(8,8)
case ";"
set(px-12,py-4,1,1,360,360,"circle",image)'top
set(px-12,py+12,px-18,py+20,.0,.0,"line",image)
set(px-12,py+12,1,1,360,360,"circle",image)
spaces(10,10)
case ":"
set(px-12,py-4,1,1,360,360,"circle",image)'top
'set(px-12,py+12,px-18,py+20,.0,.0,"line",image)
set(px-12,py+12,1,1,360,360,"circle",image)
spaces(10,10)
case "@"
set(px,py,14,1,0,290,"circle",image)
set(px+6,py,7,1,100,365,"circle",image)
spaces(36,36)
case "'"
set(px-12,py-12,px-18,py-4,.0,.0,"line",image)
set(px-12,py-12,1,1,360,360,"circle",image)
spaces(10,10)
case "#"
set(px-16,py-4,px+8,py-4,.0,.0,"line",image)
set(px-16,py+4,px+8,py+4,.0,.0,"line",image)
set(px-8,py-12,px-8,py+12,.0,.0,"line",image)
set(px,py-12,px,py+12,.0,.0,"line",image)
spaces(26,26)
case "~"
set(px-8,py+16,14,1,60,120,"circle",image)
set(px+4,py-8,14,1,240,300,"circle",image)
spaces(30,30)
case "/"
set(px+14,py-16,px-14,py+16,.0,.0,"line",image)
spaces(34,34)
case ""
set(px-14,py-16,px+14,py+16,.0,.0,"line",image)
spaces(34,34)
case "["
set(px-12,py-16,px-12,py+16,.0,.0,"line",image)'vert
set(px-12,py-14,px-4,py-14,.0,.0,"line",image)'top
set(px-12,py+14,px-4,py+14,.0,.0,"line",image)
spaces(14,14)
case "]"
set(px-4,py-16,px-4,py+16,.0,.0,"line",image)'vert
set(px-4,py-14,px-12,py-14,.0,.0,"line",image)'top
set(px-12,py+14,px-4,py+14,.0,.0,"line",image)
spaces(16,16)
case "{"
set(px+12,py-8,28,1,160,200,"circle",image)
set(px+12,py+8,28,1,160,200,"circle",image)
spaces(8,8)
case "}"
set(px-12-16-6,py-8,28,1,340,380,"circle",image)
set(px-12-16-6,py+8,28,1,340,380,"circle",image)
spaces(14,14)
case "<"
set(px-16,py,px+4,py-12,.0,.0,"line",image)
set(px-16,py,px+4,py+12,.0,.0,"line",image)
spaces(24,24)
case ">"
set(px+4,py,px-16,py-12,.0,.0,"line",image)
set(px+4,py,px-16,py+12,.0,.0,"line",image)
spaces(24,24)
case "?"
set(px-5,py-6,8,1,280,490,"circle",image)'top loop
set(px-4,py,px-4,py+8,.0,.0,"line",image)
set(px-4,py+15,1,1,360,360,"circle",image)
spaces(24,24)
case """"
set(px-12,py-16,px-18,py-8,.0,.0,"line",image)
set(px-12,py-16,1,1,360,360,"circle",image)
set(px-4,py-16,px-10,py-8,.0,.0,"line",image)
set(px-4,py-16,1,1,360,360,"circle",image)
spaces(16,16)
case else
draw string(px,py),"?",c
spaces(24,24)
end select
next n
end sub
'************************* END OF PAINTSTRING ******************************
imagedestroy img
Sleep
@ dodicat & rolliebollocks.
Someone has to trash the spam that members do not see, so yes, I have accepted a small moderators hat offered by Counting_pine, but I much prefer to wear my more comfortable Tam O'Shanter. I really hope to waste the minimum time moderating as in ...put those bands a roun' his hands an' swing that bloody axe. Once I have climbed the moderately sloped learning curve I will get back to some good ol' FB community square dancing, whoops, I mean programming.
Someone has to trash the spam that members do not see, so yes, I have accepted a small moderators hat offered by Counting_pine, but I much prefer to wear my more comfortable Tam O'Shanter. I really hope to waste the minimum time moderating as in ...put those bands a roun' his hands an' swing that bloody axe. Once I have climbed the moderately sloped learning curve I will get back to some good ol' FB community square dancing, whoops, I mean programming.
-
- Posts: 2655
- Joined: Aug 28, 2008 10:54
- Location: new york
@dodicat
Yeah, I agree with you. I hope Albert gets well soon. That was one of my favorites. The doodle that is.
Anyway, I've been playing with DRAW lately. Here is a square going in circles. I guess draw can rotate. Weird.
Do you guys know anything about http://en.wikipedia.org/wiki/Binary_space_partitioning ?
Yeah, I agree with you. I hope Albert gets well soon. That was one of my favorites. The doodle that is.
Anyway, I've been playing with DRAW lately. Here is a square going in circles. I guess draw can rotate. Weird.
Code: Select all
#include once "fbgfx.bi"
#define XYLOC(x,y) "bm" & x & "," & y
#define DRAWTO(x,y) "m" & x & "," & y
#define SETCOL(c) "c" & c
#define UP(amt) "u" & amt
#define DOWN(amt) "d" & amt
#define DRAWLEFT(amt) "l" & amt
#define DRAWRIGHT(amt) "r" & amt
#define UPRIGHT(amt) "e" & amt
#define DOWNRIGHT(amt) "f" & amt
#define DOWNLEFT(amt) "g" & amt
#define UPLEFT(amt) "h" & amt
#define DPAINT(c,b) "p" & c & "," & b
#define DSCALE(s) "s" & s
#define DROTATERAD(r) "a" & r
#define DROTATEDEG(r) "ta" & r
sub DrawSquare ( screenbuffer as fb.image ptr = 0, byval x as single, byval y as single, byval size as single=1, byval rotang as integer =0, byval clr as uinteger=&hffffff )
Draw screenbuffer, DROTATEDEG(rotang) & SETCOL(clr) & DSCALE(size) & XYLOC(x,y) & DRAWLEFT(5) & DOWN(5) & DRAWRIGHT(5) & UP(5)
end sub
screen 19,32
dim as integer i=360
do
screenlock
cls
DrawSquare ( , 400,300,200, i,RGB(255,0,0) )
screenunlock
sleep 1
i+=1
if i=360 then i=0
loop until multikey(fb.sc_escape)
-
- Posts: 2655
- Joined: Aug 28, 2008 10:54
- Location: new york
I liked this one so much I made special subroutine for it:
Here's another:
Code: Select all
#include once "fbgfx.bi"
#define PI 3.1459
sub AlbertWeb ( byref screenbuffer as fb.image ptr = 0, byval xctr as integer, byval yctr as integer, byval radius as integer, byval clr as uinteger = RGBA(255,255,255,255) )
#define d2r(r) r*(PI/180)
dim as integer span = 30, start_deg = 0
dim as single sine=0.0, cosine=0.0, c_mul, s_mul, x, y
for iRadius as integer = radius to 20 step -(radius*.1)
for iRadians as single = 0 to 360 step .1
sine = Sin(d2r(iRadians))
cosine = Cos(d2r(iRadians))
if iRadians mod span = 0 then
start_deg = iRadians
line screenbuffer, ( xctr, yctr ) - ( xctr + ( radius*Cos(d2r(start_deg)) ), yctr+(radius*Sin(d2r(start_deg))) ), clr
endif
c_mul = -.006
s_mul = -.006
If iRadians >= 45 And iRadians <=135 Then c_mul=c_mul/2
If iRadians >=225 And iRadians <=315 Then c_mul=c_mul/2
If iRadians >= 0 And iRadians <= 45 Then s_mul=s_mul/2
If iRadians >=135 And iRadians <=225 Then s_mul=s_mul/2
If iRadians >=315 And iRadians <=360 Then s_mul=s_mul/2
If iRadians >= 90 And iRadians <= 270 Then c_mul=-c_mul
If iRadians >=180 And iRadians <= 360 Then s_mul=-s_mul
sine = sine + (span-(iRadians-start_deg))*((iRadians-start_deg)/span) * s_mul
cosine = cosine + (span-(iRadians-start_deg))*((iRadians-start_deg)/span) * c_mul
y = iradius * sine
x = iradius * cosine
Line screenbuffer, -(xctr+x,yctr+y), clr
next
next
end sub
screen 19,32
dim as double t
t=timer
AlbertWeb (,400,300,200 )
? timer-t
sleep
Code: Select all
#include once "fbgfx.bi"
sub AlienMicroChip ( byref screenbuffer as fb.image ptr=0, byval xctr as integer, byval yctr as integer, byval radius2 as single )
dim as single x1=any, x2=any, y1=any, y2=any, s=any, c=any, deg1=any, deg2=any, radius1 = 1
Dim As Double radians=Atn(1)/45
Do
For deg2 = 0 To 360 Step 12
For deg1 = 0 To 360 Step 5
c=Cos(deg1*radians)*Sin(Log(deg2*radius2*radians))
s=Sin(deg1*radians)*Cos(Log(deg2*radius2*radians))
x1=radius1*c
y1=radius1*s
Pset(xctr+x1,yctr+y1), RGBA (deg1, deg2, radius1+radius2 mod 255, 255-deg1 )
Next
radius1+=1e-2
radius2-=1e-2
Next
Loop Until radius1>=radius2
end sub
screen 19, 32
AlienMicroChip (,400,300,900)
Sleep
@rolliebollocks; an interesting spiders web, but the curve sag looks wrong.
A spiders web is visible when it caries droplets of dew. It then sags under that weight (until the droplets evaporate or the spider shakes them off). Gravity would cause each individual thread to hang in a catenary. A catenary is a horrible hyperbolic function but could be approximated by a section of an upright parabola. At every node where threads join the sum of all tension vector forces would be zero, but I think it might be possible to quickly fake that. A structural design engineer would build an enormous but sparse stiffness matrix for the structure and then solve that for the final position of all nodes. I assume a spider builds the radial framework first, then adds the spiral starting at the centre and working outwards.
How might a realistic random web be generated on the screen, with or without the spider building it. Pick random points around the screen, plus one random midpoint, then put on a spiral?
How can a web once constructed be quickly given a realistic looking pearl necklace sag due to dew loading?
A spiders web is visible when it caries droplets of dew. It then sags under that weight (until the droplets evaporate or the spider shakes them off). Gravity would cause each individual thread to hang in a catenary. A catenary is a horrible hyperbolic function but could be approximated by a section of an upright parabola. At every node where threads join the sum of all tension vector forces would be zero, but I think it might be possible to quickly fake that. A structural design engineer would build an enormous but sparse stiffness matrix for the structure and then solve that for the final position of all nodes. I assume a spider builds the radial framework first, then adds the spiral starting at the centre and working outwards.
How might a realistic random web be generated on the screen, with or without the spider building it. Pick random points around the screen, plus one random midpoint, then put on a spiral?
How can a web once constructed be quickly given a realistic looking pearl necklace sag due to dew loading?
-
- Posts: 2655
- Joined: Aug 28, 2008 10:54
- Location: new york
@Richard
That was Albert's creation. I dug it up and made it into a sub and through it in the Lib because I thought it was cool. I've been collecting demo's and whatnot, putting them together. I realized I don't have to do this all myself, as long as I'm not making money or taking credit no one will care if I add their examples or anything to my Lib and then explain the usage.
So I added Bezier's and that web, some star curves from one of Rel's demo's he called supershapes...
I tried to add Coder's Jeff's rigid body lib but it broke... Anyway, putting the finishing touches on 2d, and then I'm going to make a game I think.
I want real-ish 2d physics so, I'll probably have to research and do it from scratch...
I went through your primitives Lib, it doesn't compile, some of the files are missing. I noticed you had Holes though...
I want holes. And knots. I'm going to add Knots.
Geometry is fascinating.
That was Albert's creation. I dug it up and made it into a sub and through it in the Lib because I thought it was cool. I've been collecting demo's and whatnot, putting them together. I realized I don't have to do this all myself, as long as I'm not making money or taking credit no one will care if I add their examples or anything to my Lib and then explain the usage.
So I added Bezier's and that web, some star curves from one of Rel's demo's he called supershapes...
I tried to add Coder's Jeff's rigid body lib but it broke... Anyway, putting the finishing touches on 2d, and then I'm going to make a game I think.
I want real-ish 2d physics so, I'll probably have to research and do it from scratch...
I went through your primitives Lib, it doesn't compile, some of the files are missing. I noticed you had Holes though...
I want holes. And knots. I'm going to add Knots.
Geometry is fascinating.
Spiderweb with dew droplets, i think i have some code which can do that. Lets try...
To code i'm am thniking about:
It needs the file "config.txt" contaning:
Only no gravity used currently.
To code i'm am thniking about:
Code: Select all
#lang "fblite"
OPTION EXPLICIT
OPTION BYVAL
#Define MAXATOMS 400
#Define MAXLINKS 1000
#Define THICKLINE 1
'const g as double = 0'9.81 'm/s^2
const kAtom as double = 5 'N/m
const kLink as double = 20 'N/m
const pi as double = 3.14159265359
const atomicMass as double = 1.66e-27 'kg
const mArgon as double = 4 '39.95 'no unit
const mArgonMol as double = mArgon / 1000.0 'kg/mol
const angstrom as double = 1e-10 'm
const rArgon as double = 100e-12 '98e-12
const univGasConst as double = 8.314 'J/mol K
const mol as double = 6.02e+23 'particles
const dIron as double = 2.28 * angstrom 'm
const mIron as double = 55.85 'no unit
type atomType
rho as double 'kg/m^3
r as double
m as double
x as double
y as double
vx as double
vy as double
Fx as double
Fy as double
Cat as integer
end type
type linkType
id1 as integer
id2 as integer
initLength as double
end type
type configType
Id as integer
Cat as integer
end type
type xyType
x as integer
y as integer
end type
declare sub flipScreen()
declare sub plotWorld()
declare sub plotLine (x1 as double, y1 as double, x2 as double, y2 as double, c as integer)
declare sub plotSquare (x1 as double, y1 as double, x2 as double, y2 as double, c as integer)
declare sub plotSquareFilled (x1 as double, y1 as double, x2 as double, y2 as double, c as integer)
declare sub plotAtom (atom as atomType)
declare sub plotlink (link as linkType)
declare sub plotCircle (x as double, y as double, r as double, c as integer)
declare function distAtom(b1 as atomType, b2 as atomType) as double
declare sub powerMeter(p as double)
declare function waitForKey() as string
dim as integer i, j, k, x, y, file
dim as string configText, configChar
dim as configType configArray(100,100)
dim as configType ptr a1ptr, a2ptr
dim as integer configFileXsize, configFileYsize
dim as double volume, temperature, vAverage, alfa
dim shared as atomType atom(MAXATOMS)
dim shared as atomType edge(10)
dim as atomType ptr pAtom
dim shared as linkType link(MAXLINKS)
dim as integer nAtoms, nLinks, id1, id2, iShow = 0
dim shared as integer scrnw, scrnh, scrnh1 'in pixels
dim shared as double ppm 'pixels per meter
dim as double t,dt
dim as string key
dim as double F, edgeDist
dim as xyType linkMatrix(4)
dim shared as double wx1, wx2, wx3, wx4
dim shared as double wy1, wy2, wy3, wy4
dim shared as double x0, y0, y133
dim as double startTime
'---------- Program starts here ----------
linkMatrix(0).x = +1: linkMatrix(0).y = 0
linkMatrix(1).x = -1: linkMatrix(1).y = +1
linkMatrix(2).x = 0: linkMatrix(2).y = +1
linkMatrix(3).x = +1: linkMatrix(3).y = +1
'---------- From file to 2d-array ----------
j = 0
file = freefile
open "config.txt" for input as #file
while not eof(file)
input #file, configText
for i = 1 to len(configText)
configChar = mid(configText,i,1)
if configChar = "-" then
configArray(i,j).cat = 0
print ".";
else
configArray(i,j).cat = val(configChar)
print str(configArray(i,j).cat);
end if
next
print
j+=1
wend
configFileXsize = len(configText)
configFileYsize = j
close file
print "configFileXsize:"; configFileXsize
print "configFileYsize:"; configFileYsize
randomize timer
temperature = 300 'K
'----- set atom number 0 manually -----
i = 0
atom(i).cat = 1
atom(i).r = rArgon * 4
atom(i).m = mArgon * atomicMass * 4
volume = 1.25 * pi * atom(i).r ^ 3
atom(i).rho = atom(i).m / volume
atom(i).x = 99 * angstrom
atom(i).y = 48 * angstrom
vAverage = sqr((3 * univGasConst * temperature) / mArgonMol)
alfa = rnd(1) * 2 * pi
atom(i).vx = cos(alfa) * vAverage
atom(i).vy = sin(alfa) * vAverage
atom(i).Fx = 0
atom(i).Fy = 0
x0 = atom(i).x
y0 = atom(i).y + 20 * angstrom
'---------- 2d-array to list ----------
i = 1 'to count number of balls / atoms
for y = 0 to configFileYsize-1
for x = 0 to configFileXsize-1
if (configArray(x,y).cat <> 0) then
configArray(x,y).id = i
atom(i).cat = configArray(x,y).cat
atom(i).r = rArgon
atom(i).m = mArgon * atomicMass
if (atom(i).cat = 3) then atom(i).m /= 20
volume = 1.25 * pi * atom(i).r ^ 3
atom(i).rho = atom(i).m / volume
atom(i).x = (x - 3) * 3 * angstrom
atom(i).y = (((configFileYsize - 1) - y) + 0) * 3 * angstrom - angstrom * 2
vAverage = sqr((3 * univGasConst * temperature) / mArgonMol)
alfa = rnd(1) * 2 * pi
atom(i).vx = cos(alfa) * vAverage
atom(i).vy = sin(alfa) * vAverage
atom(i).Fx = 0
atom(i).Fy = 0
i+=1
end if
if (i > MAXATOMS) then
print "Error: Too much atoms!"
sleep 3000
end(-1)
end if
next
next
nAtoms = i
print "Number of atoms:"; nAtoms
'atom(133).cat = 1
y133 = atom(133).y
'---------- Make links ----------
i = 0 'to count number of links
for y = 0 to configFileYsize-1
for x = 0 to configFileXsize-1
a1ptr = @configArray(x,y)
if (a1ptr->cat <> 0) then
for k = 0 to 3
a2ptr = @configArray(x+linkMatrix(k).x, y+linkMatrix(k).y)
if (a1ptr->cat = a2ptr->cat) then
link(i).id1 = a1ptr->id
link(i).id2 = a2ptr->id
link(i).initLength = distAtom(atom(a1ptr->id), atom(a2ptr->id))
i+=1
end if
if (i > MAXLINKS) then
print "Error: Too much links!"
sleep 3000
end(-1)
end if
next
end if
next
next
nLinks = i
print "Number of links:"; nLinks
'---------- Setup graphic screen ----------
screen 20,,2 '19=800x600 20=1024x768
screenset 0, 1
screeninfo scrnw, scrnh
scrnh1 = scrnh - 1
ppm = 7e10 'pixels per meter (1e9 = 1 pixel / nm)
color 0,15
line (0,0)-(scrnw-1, scrnh-1),15,bf
'---------- Plot container ----------
' *--------* . . . wy4
' | | |
' *---2 3---4 . wy3
'
' *---0 1------ wy2
' . | | .
' . *--------* . . . wy1
' . . . .
' wx1 wx2 wx3 wx4
wy1 = angstrom * 2
wy2 = wy1 + angstrom * 30
wy3 = wy2 + angstrom * 10
wy4 = wy3 + angstrom * 30
wx1 = angstrom * 5
wx2 = wx1 + angstrom * 5
wx3 = wx2 + angstrom * 50
wx4 = wx3 + angstrom * 7
edge(0).x = wx2 - angstrom: edge(0).y = wy2 - angstrom
edge(1).x = wx3 + angstrom: edge(1).y = wy2 - angstrom
edge(2).x = wx2 - angstrom: edge(2).y = wy3 + angstrom
edge(3).x = wx3 + angstrom: edge(3).y = wy3 + angstrom
edge(4).x = wx4 - angstrom: edge(4).y = wy3 + angstrom
for i = 0 to 4
edge(i).r = angstrom
edge(i).cat = 0 'black
next
'pulley
edge(5).x = wx4 + angstrom * 70
edge(5).y = wy2 + 3 * angstrom
edge(5).r = 2 * angstrom
edge(5).cat = 4
'pulley centre
edge(6).x = edge(5).x
edge(6).y = edge(5).y
edge(6).r = angstrom / 3
edge(6).cat = 4
'pulley weight
edge(7).x = edge(5).x + edge(5).r
edge(7).y = edge(5).y - 20 * angstrom
edge(7).r = angstrom * 3
edge(7).cat = 4
'---------- Plot atoms and links ----------
for i = 0 to nAtoms-1
plotAtom atom(i)
next
for i = 0 to nLinks-1
plotLink link(i)
next
plotWorld
screencopy 0, 1
sleep 1000
'---------- Run loop ----------
startTime = timer
t = 0: dt = 1e-15 'seconds
while(inkey$ = "")
'reset forces, add boundaries later
for i = 1 to nAtoms-1
atom(i).Fx = 0
atom(i).Fy = 0
next
atom(0).Fy = -3e-11
atom(0).Fx = 10 * (x0 - atom(0).x)
atom(133).Fx = +5e-11
atom(133).Fy = 1 * (y133 - atom(133).y)
'check collisions with walls
for i = 0 to nAtoms-1
pAtom = @atom(i)
'check collisions in main chamber
if (pAtom->x > edge(0).x) and (pAtom->x < edge(3).x) then
if (pAtom->y < edge(0).y) then
'lower wall wy1
edgeDist = (pAtom->y - pAtom->r) - wy1
if (edgeDist < 0) then pAtom->Fy -= kAtom * edgeDist
end if
if (pAtom->y > edge(3).y) then
'upper wall wy4
edgeDist = wy4 - (pAtom->y + pAtom->r)
if (edgeDist < 0) then pAtom->Fy += kAtom * edgeDist
end if
if (pAtom->y < edge(0).y) or (pAtom->y > edge(3).y) then
'left wall
edgeDist = (pAtom->x - pAtom->r) - wx2
if (edgeDist < 0) then pAtom->Fx -= kAtom * edgeDist
'right wall
edgeDist = wx3 - (pAtom->x + pAtom->r)
if (edgeDist < 0) then pAtom->Fx += kAtom * edgeDist
end if
'check collisions to outside wall (right area)
elseif (pAtom->x > edge(4).x) then
if (pAtom->y > edge(4).y) then
'left wall of right area
edgeDist = (pAtom->x - pAtom->r) - wx4
if (edgeDist < 0) then pAtom->Fx -= kAtom * edgeDist
end if
'check collisions in connecting tubes
else
'upper wall tubes
edgeDist = wy3 - (pAtom->y + pAtom->r)
if (edgeDist < 0) then pAtom->Fy += kAtom * edgeDist
end if
if (pAtom->x < edge(0).x) or (pAtom->x > edge(3).x) then
'lower wall tubes
edgeDist = (pAtom->y - pAtom->r) - wy2
if (edgeDist < 0) then pAtom->Fy -= kAtom * edgeDist
end if
'check collisions with edges 0...3
if (pAtom->y > edge(0).y) and (pAtom->y < edge(3).y) then
'Main chamber
if (pAtom->x > edge(0).x) and (pAtom->x < edge(3).x) then
for j = 0 to 3
edgeDist = distAtom(edge(j), *pAtom) - (pAtom->r + edge(j).r)
if (edgeDist < 0) then
alfa = atan2( pAtom->y - edge(j).y, pAtom->x - edge(j).x )
F = kAtom * edgeDist
pAtom->Fx -= F * cos(alfa)
pAtom->Fy -= F * sin(alfa)
end if
next
end if
'Right area edges 4
if (pAtom->x > edge(4).x) then
edgeDist = distAtom(edge(4), *pAtom) - (pAtom->r + edge(4).r)
if (edgeDist < 0) then
alfa = atan2( pAtom->y - edge(4).y, pAtom->x - edge(4).x )
F = kAtom * edgeDist
pAtom->Fx -= F * cos(alfa)
pAtom->Fy -= F * sin(alfa)
end if
end if
end if
next
'check for collisions between atoms
for i = 0 to nAtoms-1
for j = i+1 to nAtoms-1
'skip same type / category
if (atom(j).cat <> atom(i).cat) then
edgeDist = distAtom(atom(i), atom(j)) - (atom(i).r + atom(j).r)
if(edgeDist < 0) then
alfa = atan2( atom(i).y - atom(j).y, atom(i).x - atom(j).x )
F = kAtom * edgeDist
atom(i).Fx -= F * cos(alfa)
atom(i).Fy -= F * sin(alfa)
atom(j).Fx -= F * cos(alfa+pi)
atom(j).Fy -= F * sin(alfa+pi)
end if
end if
next
next
'go through forces by links
for i = 0 to nLinks-1
id1 = link(i).id1
id2 = link(i).id2
alfa = atan2( atom(id1).y - atom(id2).y, atom(id1).x - atom(id2).x )
F = kLink * (link(i).initLength - distAtom(atom(id1), atom(id2)))
atom(id1).Fx += F * cos(alfa)
atom(id1).Fy += F * sin(alfa)
atom(id2).Fx += F * cos(alfa+pi)
atom(id2).Fy += F * sin(alfa+pi)
next
'Calculate Velocities
for i = 0 to nAtoms-1
atom(i).vy += (atom(i).Fy / atom(i).m) * dt
atom(i).vx += (atom(i).Fx / atom(i).m) * dt
next
'Calculate Positions
for i = 0 to nAtoms-1
atom(i).x += atom(i).vx * dt
atom(i).y += atom(i).vy * dt
next
if (iShow < 10) then
iShow += 1
else
iShow = 0
'screensync
'erase
line (0,0)-(scrnw-1, scrnh-1),15,bf
locate 12,2: print "Starting temperature [K]:"; temperature;
locate 13,2: print "Time [ps]:"; int(t * 1e12);
plotWorld
'draw new positions
for i = 0 to nAtoms-1
plotAtom atom(i)
next
for i = 0 to nLinks-1
plotLink link(i)
next
flipScreen()
end if
'if (int(t * 1e12) > 10.0) then exit while
t += dt
wend
locate 2,60: print "Time = "; timer - startTime
locate 4,60: print "End!";
flipScreen()
key = waitForKey()
'---------- Subroutines go here ----------
sub flipScreen()
static as integer page1 = 0
static as integer page2 = 1
page1 = page1 xor 1
page2 = page2 xor 1
screenset page1, page2
end sub
sub plotWorld()
dim as integer i
'bottom half
plotLine (wx1, wy2, wx2 - angstrom, wy2, 0)
plotLine (wx2, wy2 - angstrom, wx2, wy1, 0)
plotLine (wx2, wy1, wx3, wy1, 0)
plotLine (wx3, wy1, wx3, wy2 - angstrom, 0)
plotLine (wx3 + angstrom, wy2, wx4 + angstrom * 50, wy2, 0)
'top half
plotLine (wx1, wy3, wx2 - angstrom, wy3, 0)
plotLine (wx2, wy3 + angstrom, wx2, wy4, 0)
plotLine (wx2, wy4, wx3, wy4, 0)
plotLine (wx3, wy4, wx3, wy3 + angstrom, 0)
plotLine (wx3 + angstrom, wy3, wx4 - angstrom, wy3, 0)
plotLine (wx4, wy3 + angstrom, wx4, wy4, 0)
'smooth edges
for i = 0 to 4
plotAtom(edge(i))
next
'rod connecting blocker
plotLine (atom(0).x, atom(0).y, x0, y0, atom(0).cat)
'pulley
plotAtom(edge(5))
plotAtom(edge(6))
plotLine (edge(5).x, edge(5).y + edge(5).r, atom(133).x, atom(133).y, edge(5).cat)
'
edge(7).y = edge(5).y - 40 * angstrom + distAtom(edge(5), atom(133))
plotAtom(edge(7))
plotLine (edge(5).x + edge(5).r, edge(5).y, edge(7).x, edge(7).y, edge(5).cat)
end sub
sub plotLine (x1 as double, y1 as double, x2 as double, y2 as double, c as integer)
line(int(x1*ppm+0.5), scrnh1-int(y1*ppm+0.5))_
-(int(x2*ppm+0.5), scrnh1-int(y2*ppm+0.5)), c
#IFDEF THICKLINE
line(int(x1*ppm+1.5), scrnh1-int(y1*ppm+1.5))_
-(int(x2*ppm+1.5), scrnh1-int(y2*ppm+1.5)), c
#ENDIF
end sub
sub plotSquare (x1 as double, y1 as double, x2 as double, y2 as double, c as integer)
line(int(x1*ppm+0.5), scrnh1-int(y1*ppm+0.5))_
-(int(x2*ppm+0.5), scrnh1-int(y2*ppm+0.5)), c, b
end sub
sub plotSquareFilled (x1 as double, y1 as double, x2 as double, y2 as double, c as integer)
line(int(x1*ppm+0.5), scrnh1-int(y1*ppm+0.5))_
-(int(x2*ppm+0.5), scrnh1-int(y2*ppm+0.5)), c, bf
end sub
sub plotlink (l as linkType)
dim as integer x1, y1, x2, y2, c
x1 = (atom(l.id1).x * ppm + 0.5)
y1 = (atom(l.id1).y * ppm + 0.5)
x2 = (atom(l.id2).x * ppm + 0.5)
y2 = (atom(l.id2).y * ppm + 0.5)
c = atom(l.id1).cat 'use lookuptable for color later
line (x1, (scrnh1) - y1) - (x2, (scrnh - 1) - y2), c
end sub
sub plotAtom (a as atomType)
dim as integer x, y, r, c
x = int(a.x * ppm + 0.5)
y = int(a.y * ppm + 0.5)
r = int(a.r * ppm + 0.5)
c = a.cat 'use lookuptable for color later
circle(x, (scrnh1) - y), r, c,',,,f
#IFDEF THICKLINE
circle(x, (scrnh1) - y), r+1, c,',,,f
#ENDIF
'plot force indicator
'plotLine(a.x, a.y, a.x + a.Fx, a.y + a.Fy, c)
end sub
sub plotCircle (x as double, y as double, r as double, c as integer)
circle(int(x*ppm+0.5), scrnh1-int(y*ppm+0.5)), int(r*ppm+0.5), c,',,,f
end sub
function distAtom(b1 as atomType, b2 as atomType) as double
return sqr( (b1.x-b2.x)*(b1.x-b2.x) + (b1.y-b2.y)*(b1.y-b2.y) )
'return sqr( (b1.x-b2.x)^2 + (b1.y-b2.y)^2 )
end function
sub powerMeter(p as double)
dim i, j as integer
dim pRef as double 'W
j = 2
locate 21+j, 80: print "Power indicator";
for i = j to 10
pRef = 10^(-5-i)
locate 23+i,85: print "[W*10^";-5-i;"]";
if (p > pRef) then
line (650-10,355+i*16)-(650+10,355+10+i*16),4,bf
else
line (650-10,355+i*16)-(650+10,355+10+i*16),14,bf
line (650-10,355+i*16)-(650+10,355+10+i*16),4,b
end if
next
end sub
function waitForKey() as string
dim as string key = ""
while key = ""
key = inkey$
wend
return key
end function
Code: Select all
----------------------------------------------
----------7-7-7-7-7-7-------------------------
---------2-2-2---2----------------------------
-----------44--7---5--------------------------
---------2-44------55-------------------------
----------7-333---7---------------------------
------------333-------------------------------
---------44-333----5-------------3----3-------
---------44-333----55-----------33---33-------
------------333----------------333--333-------
--333333333333333333333333333333333333333-----
--333333333333333333333333333333333333333-----
--333333333333333333333333333333333333333-----
------------333-------------------------------
------------333----2--------------------------
------------333---7-7-------------------------
---------2--333----2--------------------------
----------7-333---7-7-------------------------
---------2---6----6---------------------------
------------666--666--------------------------
---------2-2-6-2--6---------------------------
----------7-7-7-7-7-7-------------------------
----------------------------------------------
----------------------------------------------
----------------------------------------------
HI Rollie, Richard, badideabadidea wrote:Spiderweb with dew droplets, i think i have some code which can do that. Lets try...
@badidea
Nice bit of work, I get 300k temperature.
@Richard
COSH is an important function when towing.
It is assumed that the tow-wire hangs between the tug and tow in a catenery, thus the estimated lowest part of the wire can be calculated.
Tow wire dragging along the seabed is a no no.
@Rollie
This can't compete with Albert's web, or your functionilation of it.
I have simplified rotatepoint2d to the point that I'm surprised it still works.
Must nip back over to community discussion to see if there are any more fors.
I've nearly done the polygons.
Code: Select all
'WEB
type point2d
as double x,y
end type
function rotatepoint2d(pivot As point2d,_
_point as point2d,_
angle As Double,_
dilator as double=1) as point2d
Dim pi As Double=4*Atn(1)
#define rad *pi/180
dim as point2d np
np.x=dilator*(Cos(angle rad)*(_point.x-pivot.x)-Sin(angle rad)*(_point.y-pivot.y)) +pivot.x
np.y=dilator*(Sin(angle rad)*(_point.x-pivot.x)+Cos(angle rad)*(_point.y-pivot.y)) +pivot.y
return np
End function
dim as integer xres,yres
screeninfo xres,yres
screenres xres,yres,32
dim as point2d piv,pt,temp
dim as double dil,k=1
piv.x=xres/2
piv.y=yres/2
pt.x=piv.x+yres/4
pt.y=piv.y
dim pi as double=4*atn(1)
#define rad *pi/180
for z as double=1 to 6000 step 1
if z mod 30=0 then
line(piv.x,piv.y)-(piv.x+1.5*piv.x*cos(z rad),piv.y+1.5*piv.y*sin(z rad)),rgb(100,100,100)
end if
if z mod 30=0 then k=-1.5*.001*z
if z mod 60=0 then k=2.5*.001*z
dil=dil+k*.001
temp= rotatepoint2d(piv,pt,z,dil)
pset(temp.x,temp.y)
if z mod 25=0 then circle(temp.x,temp.y),2,rgb(200,200,200),,,,F 'dew?
next z
sleep
spiderweb
Ok, this looks like one thread in a web with (atomic sized) dew droplets and gravity:
which now needs this as "config.txt":
BTW, the previous example was a simulation of a brownian ratchet: http://en.wikipedia.org/wiki/Brownian_ratchet
The 300K is define in the code, try increasing it and it goes berserk.
Code: Select all
#lang "fblite"
OPTION EXPLICIT
OPTION BYVAL
#Define MAXATOMS 40
#Define MAXLINKS 1000
#Define THICKLINE 1
const g as double = 9.81 'm/s^2
const kAtom as double = 5 'N/m
const kLink as double = 20 / 1000 'N/m
const pi as double = 3.14159265359
const atomicMass as double = 1.66e-27 * 10 'kg
const mArgon as double = 4 '39.95 'no unit
const mArgonMol as double = mArgon / 1000.0 'kg/mol
const angstrom as double = 1e-10 'm
const rArgon as double = 100e-12 '98e-12
const univGasConst as double = 8.314 'J/mol K
const mol as double = 6.02e+23 'particles
const dIron as double = 2.28 * angstrom 'm
const mIron as double = 55.85 'no unit
type atomType
rho as double 'kg/m^3
r as double
m as double
x as double
y as double
vx as double
vy as double
Fx as double
Fy as double
Cat as integer
end type
type linkType
id1 as integer
id2 as integer
initLength as double
end type
type configType
Id as integer
Cat as integer
end type
type xyType
x as integer
y as integer
end type
declare sub flipScreen()
declare sub plotLine (x1 as double, y1 as double, x2 as double, y2 as double, c as integer)
declare sub plotAtom (atom as atomType)
declare sub plotlink (link as linkType)
declare function distAtom(b1 as atomType, b2 as atomType) as double
declare function waitForKey() as string
dim as integer i, j, k, x, y, file
dim as string configText, configChar
dim as configType configArray(100,100)
dim as configType ptr a1ptr, a2ptr
dim as integer configFileXsize, configFileYsize
dim as double volume, temperature, vAverage, alfa
dim shared as atomType atom(MAXATOMS)
dim as atomType ptr pAtom
dim shared as linkType link(MAXLINKS)
dim as integer nAtoms, nLinks, id1, id2, iShow = 0
dim shared as integer scrnw, scrnh, scrnh1 'in pixels
dim shared as double ppm 'pixels per meter
dim as double t,dt
dim as string key
dim as double F, edgeDist
dim as xyType linkMatrix(4)
dim as double startTime
'---------- Program starts here ----------
linkMatrix(0).x = +1: linkMatrix(0).y = 0
linkMatrix(1).x = -1: linkMatrix(1).y = +1
linkMatrix(2).x = 0: linkMatrix(2).y = +1
linkMatrix(3).x = +1: linkMatrix(3).y = +1
'---------- From file to 2d-array ----------
j = 0
file = freefile
open "config.txt" for input as #file
while not eof(file)
input #file, configText
for i = 1 to len(configText)
configChar = mid(configText,i,1)
if configChar = "-" then
configArray(i,j).cat = 0
print ".";
else
configArray(i,j).cat = val(configChar)
print str(configArray(i,j).cat);
end if
next
print
j+=1
wend
configFileXsize = len(configText)
configFileYsize = j
close file
print "configFileXsize:"; configFileXsize
print "configFileYsize:"; configFileYsize
randomize timer
temperature = 3 'K
i = 0 'to count number of balls / atoms
for y = 0 to configFileYsize-1
for x = 0 to configFileXsize-1
if (configArray(x,y).cat <> 0) then
configArray(x,y).id = i
atom(i).cat = configArray(x,y).cat
atom(i).r = rArgon
atom(i).m = mArgon * atomicMass
if (atom(i).cat = 3) then atom(i).m /= 20
volume = 1.25 * pi * atom(i).r ^ 3
atom(i).rho = atom(i).m / volume
atom(i).x = (x - 3) * 3 * angstrom
atom(i).y = (((configFileYsize - 1) - y) + 0) * 3 * angstrom - angstrom * 2
vAverage = sqr((3 * univGasConst * temperature) / mArgonMol)
alfa = rnd(1) * 2 * pi
atom(i).vx = cos(alfa) * vAverage
atom(i).vy = sin(alfa) * vAverage
atom(i).Fx = 0
atom(i).Fy = 0
i+=1
end if
if (i > MAXATOMS) then
print "Error: Too much atoms!"
sleep 3000
end(-1)
end if
next
next
nAtoms = i
print "Number of atoms:"; nAtoms
'---------- Make links ----------
i = 0 'to count number of links
for y = 0 to configFileYsize-1
for x = 0 to configFileXsize-1
a1ptr = @configArray(x,y)
if (a1ptr->cat <> 0) then
for k = 0 to 3
a2ptr = @configArray(x+linkMatrix(k).x, y+linkMatrix(k).y)
if (a1ptr->cat = a2ptr->cat) then
link(i).id1 = a1ptr->id
link(i).id2 = a2ptr->id
link(i).initLength = distAtom(atom(a1ptr->id), atom(a2ptr->id))
i+=1
end if
if (i > MAXLINKS) then
print "Error: Too much links!"
sleep 3000
end(-1)
end if
next
end if
next
next
nLinks = i+1
print "Number of links:"; nLinks
'---------- Setup graphic screen ----------
screen 20,,2 '19=800x600 20=1024x768
screenset 0, 1
screeninfo scrnw, scrnh
scrnh1 = scrnh - 1
ppm = 7e10 'pixels per meter (1e9 = 1 pixel / nm)
color 0,15
line (0,0)-(scrnw-1, scrnh-1),15,bf
'---------- Plot atoms and links ----------
for i = 0 to nAtoms-1
plotAtom atom(i)
next
for i = 0 to nLinks-1
plotLink link(i)
next
screencopy 0, 1
sleep 1000
atom(0).vx = 0
atom(0).vy = 0
atom(nLinks-1).vx = 0
atom(nLinks-1).vy = 0
'---------- Run loop ----------
startTime = timer
t = 0: dt = 1e-14 'seconds
while(inkey$ = "")
'reset forces, add boundaries later
for i = 0 to nAtoms-1
atom(i).Fx = 0
atom(i).Fy = atom(i).m * -g * 1e13
next
'check for collisions between atoms
for i = 0 to nAtoms-1
for j = i+1 to nAtoms-1
'skip same type / category
if (atom(j).cat <> atom(i).cat) then
edgeDist = distAtom(atom(i), atom(j)) - (atom(i).r + atom(j).r)
if(edgeDist < 0) then
alfa = atan2( atom(i).y - atom(j).y, atom(i).x - atom(j).x )
F = kAtom * edgeDist
atom(i).Fx -= F * cos(alfa)
atom(i).Fy -= F * sin(alfa)
atom(j).Fx -= F * cos(alfa+pi)
atom(j).Fy -= F * sin(alfa+pi)
end if
end if
next
next
'go through forces by links
for i = 0 to nLinks-1
id1 = link(i).id1
id2 = link(i).id2
alfa = atan2( atom(id1).y - atom(id2).y, atom(id1).x - atom(id2).x )
F = kLink * (link(i).initLength - distAtom(atom(id1), atom(id2)))
atom(id1).Fx += F * cos(alfa)
atom(id1).Fy += F * sin(alfa)
atom(id2).Fx += F * cos(alfa+pi)
atom(id2).Fy += F * sin(alfa+pi)
next
'add friction
for i = 0 to nLinks-1
atom(i).Fx -= atom(i).vx / 1e15
atom(i).Fy -= atom(i).vy / 1e15
next
atom(0).Fx = 0
atom(0).Fy = 0
atom(nLinks-1).Fx = 0
atom(nLinks-1).Fy = 0
'Calculate Velocities
for i = 0 to nAtoms-1
atom(i).vy += (atom(i).Fy / atom(i).m) * dt
atom(i).vx += (atom(i).Fx / atom(i).m) * dt
next
'Calculate Positions
for i = 0 to nAtoms-1
atom(i).x += atom(i).vx * dt
atom(i).y += atom(i).vy * dt
next
if (iShow < 10) then
iShow += 1
else
iShow = 0
'screensync
'erase
line (0,0)-(scrnw-1, scrnh-1),15,bf
locate 12,2: print "Starting temperature [K]:"; temperature;
locate 13,2: print "Time [ps]:"; int(t * 1e12);
'draw new positions
for i = 0 to nAtoms-1
plotAtom atom(i)
next
for i = 0 to nLinks-1
plotLink link(i)
next
flipScreen()
sleep 1,1
end if
'if (int(t * 1e12) > 10.0) then exit while
t += dt
wend
locate 2,60: print "Time = "; timer - startTime
locate 4,60: print "End!";
flipScreen()
key = waitForKey()
'---------- Subroutines go here ----------
sub flipScreen()
static as integer page1 = 0
static as integer page2 = 1
page1 = page1 xor 1
page2 = page2 xor 1
screenset page1, page2
end sub
sub plotLine (x1 as double, y1 as double, x2 as double, y2 as double, c as integer)
line(int(x1*ppm+0.5), scrnh1-int(y1*ppm+0.5))_
-(int(x2*ppm+0.5), scrnh1-int(y2*ppm+0.5)), c
#IFDEF THICKLINE
line(int(x1*ppm+1.5), scrnh1-int(y1*ppm+1.5))_
-(int(x2*ppm+1.5), scrnh1-int(y2*ppm+1.5)), c
#ENDIF
end sub
sub plotlink (l as linkType)
dim as integer x1, y1, x2, y2, c
x1 = (atom(l.id1).x * ppm + 0.5)
y1 = (atom(l.id1).y * ppm + 0.5)
x2 = (atom(l.id2).x * ppm + 0.5)
y2 = (atom(l.id2).y * ppm + 0.5)
c = atom(l.id1).cat 'use lookuptable for color later
line (x1, (scrnh1) - y1) - (x2, (scrnh - 1) - y2), c
end sub
sub plotAtom (a as atomType)
dim as integer x, y, r, c
x = int(a.x * ppm + 0.5)
y = int(a.y * ppm + 0.5)
r = int(a.r * ppm + 0.5)
c = a.cat 'use lookuptable for color later
circle(x, (scrnh1) - y), r, c,',,,f
#IFDEF THICKLINE
circle(x, (scrnh1) - y), r+1, c,',,,f
#ENDIF
'plot force indicator
'plotLine(a.x, a.y, a.x + a.Fx, a.y + a.Fy, c)
end sub
function distAtom(b1 as atomType, b2 as atomType) as double
return sqr( (b1.x-b2.x)*(b1.x-b2.x) + (b1.y-b2.y)*(b1.y-b2.y) )
end function
function waitForKey() as string
dim as string key = ""
while key = ""
key = inkey$
wend
return key
end function
Code: Select all
----------------------------------------------
----------------------------------------------
----------------------------------------------
----------------------------------------------
----------------------------------------------
----------------------------------------------
----------------------------------------------
----------------------------------------------
----------------------------------------------
----------------------------------------------
----------------------------------------------
----------------333333333333------------------
----------------------------------------------
----------------------------------------------
----------------------------------------------
----------------------------------------------
----------------------------------------------
----------------------------------------------
----------------------------------------------
----------------------------------------------
----------------------------------------------
----------------------------------------------
----------------------------------------------
----------------------------------------------
----------------------------------------------
The 300K is define in the code, try increasing it and it goes berserk.