Squares

General FreeBASIC programming questions.
Locked
counting_pine
Site Admin
Posts: 6323
Joined: Jul 05, 2005 17:32
Location: Manchester, Lancs

Post by counting_pine »

Arrays don't take Byval or Byref. But -w pedantic shouldn't complain if you omit them.
rolliebollocks
Posts: 2655
Joined: Aug 28, 2008 10:54
Location: new york

Post by rolliebollocks »

Faster than native square root:

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
Richard
Posts: 3096
Joined: Jan 15, 2007 20:44
Location: Australia

Post by Richard »

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
dodicat
Posts: 7976
Joined: Jan 10, 2006 20:30
Location: Scotland

Post by dodicat »

Hi Richard
Wow, now you will be able to get really fast division.
rolliebollocks
Posts: 2655
Joined: Aug 28, 2008 10:54
Location: new york

Post by rolliebollocks »

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.

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
rolliebollocks
Posts: 2655
Joined: Aug 28, 2008 10:54
Location: new york

Post by rolliebollocks »

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
dodicat
Posts: 7976
Joined: Jan 10, 2006 20:30
Location: Scotland

Post by dodicat »

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.
Hi Rollie~
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
 
Richard
Posts: 3096
Joined: Jan 15, 2007 20:44
Location: Australia

Post by Richard »

@ 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.
rolliebollocks
Posts: 2655
Joined: Aug 28, 2008 10:54
Location: new york

Post by rolliebollocks »

@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.

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)
    
Do you guys know anything about http://en.wikipedia.org/wiki/Binary_space_partitioning ?
rolliebollocks
Posts: 2655
Joined: Aug 28, 2008 10:54
Location: new york

Post by rolliebollocks »

I liked this one so much I made special subroutine for it:

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
Here's another:

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
Richard
Posts: 3096
Joined: Jan 15, 2007 20:44
Location: Australia

Post by Richard »

@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?
rolliebollocks
Posts: 2655
Joined: Aug 28, 2008 10:54
Location: new york

Post by rolliebollocks »

@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.
badidea
Posts: 2586
Joined: May 24, 2007 22:10
Location: The Netherlands

Post by badidea »

Spiderweb with dew droplets, i think i have some code which can do that. Lets try...

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
It needs the file "config.txt" contaning:

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-------------------------
----------------------------------------------
----------------------------------------------
----------------------------------------------
Only no gravity used currently.
dodicat
Posts: 7976
Joined: Jan 10, 2006 20:30
Location: Scotland

Post by dodicat »

badidea wrote:Spiderweb with dew droplets, i think i have some code which can do that. Lets try...
HI Rollie, Richard, badidea

@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



badidea
Posts: 2586
Joined: May 24, 2007 22:10
Location: The Netherlands

spiderweb

Post by badidea »

Ok, this looks like one thread in a web with (atomic sized) dew droplets and gravity:

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
which now needs this as "config.txt":

Code: Select all

----------------------------------------------
----------------------------------------------
----------------------------------------------
----------------------------------------------
----------------------------------------------
----------------------------------------------
----------------------------------------------
----------------------------------------------
----------------------------------------------
----------------------------------------------
----------------------------------------------
----------------333333333333------------------
----------------------------------------------
----------------------------------------------
----------------------------------------------
----------------------------------------------
----------------------------------------------
----------------------------------------------
----------------------------------------------
----------------------------------------------
----------------------------------------------
----------------------------------------------
----------------------------------------------
----------------------------------------------
----------------------------------------------
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.
Locked