I did this a year or two ago.
(I stuck the horse on today).
3) Right click anywhere on the screen to delete previous points.
4)The drag mode box (top left) can be clicked to toggle between drawing points or dragging points with the mouse.
6) You may save the points on exit, they are saved in polypoints.txt, which will run directly with freebasic to draw the saved points.
Code: Select all
Dim As String horse = _
"C0BM197,165M+5,-27M+3,-25M+4,-21M+6,-10M+15,-10"_
&"M+5,-4M+11,-4M+8,0M+2,4M+48,1M+15,7"_
&"M+15,7M+12,10M+12,13M+19,27M+7,15M+6,13"_
&"M+7,7M+23,5M+39,-9M+37,-10M+20,-1M+24,3"_
&"M+30,5M+18,-10M+34,-23M+15,-3M+18,6M+15,11"_
&"M+12,15M+2,28M+5,39M+-5,18M+-17,38M+-7,14"_
&"M+-20,34M+-12,21M+-4,9M+-2,3M+-1,37M+4,9"_
&"M+-4,1M+-9,-7M+-7,-17M+-3,-30M+6,-38M+23,-59"_
&"M+4,-29M+-3,-21M+-13,-17M+-10,-6M+-13,-4M+-17,0"_
&"M+-6,3M+5,18M+11,28M+0,27M+-3,15M+-7,13"_
&"M+-10,16M+-12,11M+-9,11M+-9,10M+6,19M+8,13"_
&"M+5,6M+6,12M+-4,11M+-12,17M+-14,13M+-10,13"_
&"M+-8,13M+-7,10M+-4,11M+-12,6M+-8,3M+-5,11"_
&"M+0,6M+-28,-9M+3,-12M+8,-8M+13,-7M+8,-5"_
&"M+12,-10M+9,-16M+10,-15M+12,-15M+0,-10M+-3,-13"_
&"M+-2,-8M+-5,1M+-3,12M+-8,9M+-12,13M+-10,13"_
&"M+-7,16M+-8,15M+-5,8M+-8,11M+-9,9M+-13,12"_
&"M+-3,9M+273,4M+0,13M+-382,-1M+-1,-12M+71,-3"_
&"M+20,-21M+27,-20M+28,-41M+6,-14M+5,-20M+-19,-35"_
&"M+-7,-10M+-8,-7M+-9,-4M+-16,7M+-12,3M+-29,0"_
&"M+-22,1M+-14,21M+-13,27M+-13,19M+-12,30M+-7,22"_
&"M+-4,19M+-7,22M+31,3M+-1,15M+-171,-1M+-2,-13"_
&"M+95,-2M+13,-8M+15,-9M+8,-13M+8,-21M+5,-32"_
&"M+5,-22M+9,-21M+8,-22M+8,-19M+-3,-4M+-17,5"_
&"M+-9,3M+-69,0M+-4,7M+-4,12M+5,17M+9,10"_
&"M+13,14M+11,10M+10,3M+12,4M+4,11M+-2,12"_
&"M+-8,7M+-8,-4M+-20,-14M+-15,-13M+-36,-56M+-2,-19"_
&"M+7,-14M+15,-8M+48,-20M+-7,-26M+5,-11M+1,-11"_
&"M+7,-7M+6,-11M+8,-18M+3,-18M+-1,-14M+-4,-10"_
&"M+-6,-11M+-8,1M+-14,12M+-7,10M+-3,15M+-6,8"_
&"M+-12,-2M+-16,-6M+-4,-17M+1,-16"_
&"BM+191,77P4294967295,0"
Dim As Integer xres,yres
Screeninfo xres,yres
Screenres .9*xres,.9*yres,32
Screeninfo xres,yres
Dim As Any Ptr i=Imagecreate(800,600,Rgb(0,200,0))
Draw i,horse
#define map(a,b,_x_,c,d) ((d)-(c))*((_x_)-(a))/((b)-(a))+(c)
#define onscreen (mx>0) and (mx<xres) and (my>0) and (my<yres)
#define incircle(cx,cy,radius,x,y) (cx-x)*(cx-x) +(cy-y)*(cy-y)<= radius*radius
Type Point
As Long x,y
End Type
Type V2 As Point
Function ShortSpline(p() As V2,t As Single) As V2
#macro set(n)
0.5 *( (2 * P(2).n) +_
(-1*P(1).n + P(3).n) * t +_
(2*P(1).n - 5*P(2).n + 4*P(3).n - P(4).n) * t*t +_
(-1*P(1).n + 3*P(2).n- 3*P(3).n + P(4).n) * t*t*t)
#endmacro
Dim As V2 G
G.x=set(x):G.y=set(y)':G.z=set(z)
Return g
End Function
Sub GetSpline(v() As V2,outarray() As V2,arraysize As Long=1000)
Dim As V2 p(1 To 4)
Redim outarray(0)
Dim As Single stepsize=(Ubound(v)-1)/(arraysize)
If stepsize>1 Then stepsize=1
For n As Long=Lbound(v)+1 To Ubound(v)-2
p(1)=v(n-1):p(2)=v(n):p(3)=v(n+1):p(4)=v(n+2)
For t As Single=0 To 1 Step stepsize
Redim Preserve outarray(1 To Ubound(outarray)+1)
outarray(Ubound(outarray))=ShortSpline(p(),t)
Next t
Next n
End Sub
Sub DrawCurve(a() As V2,ydisp As Long=0,col As Ulong)
Pset(a(Lbound(a)).x,a(Lbound(a)).y+ydisp),col
For z As Long=Lbound(a)+1 To Ubound(a)
Line-(a(z).x,a(z).y+ydisp),col
Next z
End Sub
Sub lineto(x1 As Single,y1 As Single,x2 As Single,y2 As Single,L As Single,Byref ox As Single,Byref oy As Single)
Var dx=x2-x1,dy=y2-y1
ox=x1+dx*L
oy=y1+dy*L
End Sub
Sub Magnify()
#define resetwheel(w,fl) fl=w
#define wheel(w,f) w-f
Dim As Long mx,my,mw,button:Getmouse mx,my,mw,button
Static As Long flag,pmw
mw=(mw/2)
If button=4 Then resetwheel(mw,flag)
Dim As Ulong array(1 To 6561),count
pmw=wheel(mw,flag)
If pmw<=1 Then Exit Sub
For z As Long=1 To 2
For x As Long=mx-40 To mx+40
For y As Long=my-40 To my+40
count+=1
If z=1 Then array(count)=Point(x,y)
If z=2 Then
Var NewX=pmw*(x-mx)+mx:Var NewY=pmw*(y-my)+my
Line(newx-pmw/2,newy-pmw/2)-(newx+pmw/2,newy+pmw/2),array(count),bf
End If
Next y
Next x
count=0
Next z
Line(mx-pmw*40,my-pmw*40)-(mx+pmw*40,my+pmw*40),Rgb(100,0,0),B
End Sub
#macro display()
Screenlock
Cls
Put(100,100),i,Pset
'================= GRID =======================
For x As Long=0 To xres Step 50
Line(x,0)-(x,yres),Rgb(155,155,155)
Next x
For y As Long=0 To yres Step 50
Line(0,y)-(xres,y),Rgb(155,155,155)
Next y
Line(0,0)-(xres,20),Rgb(0,100,200),bf
If dragmode=1 Then
Line(10,0)-(100,20),Rgb(200,0,0),bf
Else
Line(10,0)-(100,20),Rgb(0,200,0),bf
End If
Draw String(15,5),"Drag mode",Rgb(255,255,255)
Draw String(150,5),dragmessage,Rgb(255,255,255)
Draw String(xres/3,20),"mouse " & mx &" " & my & " " & Str(dragmode) ,Rgb(200,200,200)
'firsst point
If Ubound(s) Then Circle(s(1).x,s(1).y),3,Rgb(200,100,0),,,,f
'========== Get the CatMull Rom spline ====================
If Ubound(s)>1 Then
Dim As Single ox,oy
lineto(s(2).x,s(2).y,s(1).x,s(1).y,1,ox,oy)
Redim s2(0 To Ubound(s)+1)
s2(0)=Type<v2>(ox,oy)
For n As Long=1 To Ubound(s)
s2(n)=s(n)
Next n
lineto(s(Ubound(s)-1).x,s(Ubound(s)-1).y,s(Ubound(s)).x,s(Ubound(s)).y,1,ox,oy)
s2(Ubound(s2)).x=ox
s2(Ubound(s2)).y=oy
Dim As Long m
If Ubound(s)<6-3 Then 'after fourth point the spline becomes curved
m=0
Else
m=map(0,100,Ubound(s),0,(Ubound(s)*100))+20
End If
Draw String (10,30),"Number of spline points " +Str(Ubound(cmull)),Rgb(255,255,255)
Draw String (10,40),"Number of mouse points " +Str(Ubound(s2)),Rgb(255,255,255)
GetSpline(s2(),Cmull(),m)
DrawCurve(CMull(),,Rgb(200,0,0))
End If
For n As Long=2 To Ubound(s)
Circle (s(n).x,s(n).y),3,Rgb(200,0,0),,,,f
Next n
magnify()
Screenunlock
Sleep 1,1
#endmacro
#macro mouse(m)
Dim As Long x=mx,y=my,dx,dy
While mb = 1
Display()
Getmouse mx,my,,mb
If onscreen Then
If mx<>x Or my<>y Then
dx = mx - x
dy = my - y
x = mx
y = my
s(m).x=x+dx
s(m).y=y+dy
End If
End If
Wend
#endmacro
Redim As Point s(0),s2()
Redim As V2 Cmull()
Dim As Long mx,my,mb,flag1,counter,flag2,dragmode=-1
Dim As String key,dragmessage
Screencontrol 100,50,50
Do
Getmouse mx,my,,mb
key=Inkey
display()
If my<20 Then
If mx>10 And mx<100 And mb=1 And flag1=0 Then
flag1=1
dragmode=-dragmode
End If
End If
If dragmode =1 Then
For n As Long=Lbound(s) To Ubound(s)
If incircle(s(n).x,s(n).y,10,mx,my) Then
mouse(n)
End If
Next n
End If
'==============================================
'insertion of points
If my>20 And dragmode=-1 Then
If mb=1 And flag1=0 Then
flag1=1:counter+=1
Redim Preserve s(1 To Ubound(s)+1)
s(Ubound(s))=Type<Point>(mx,my)
End If
'deletion of points
If mb=2 And flag2=0 Then
flag2=1
If counter>1 Then Redim Preserve s(1 To Ubound(s)-1):counter-=1
If counter=1 Then Redim s(0):counter=0
End If
End If
flag1=mb
flag2=mb
If dragmode=-1 Then dragmessage="YOU CAN DRAW POINTS"
If dragmode=1 Then dragmessage="YOU CAN DRAG POINTS WITH THE MOUSE"
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Loop Until key =Chr(27)
Draw String(10,100), "Do you want to save this y/n ? ",Rgb(255,255,255)
Var g=Input(1)
If Lcase(g)<>"y" Then End
Open "polypoints.txt" For Output As #1
'====================================
Print #1,"type V2"
Print #1, "As long x,y"
Print #1,"End Type"
'====================================
Print #1," "
Print #1,"X_values:"
Print #1," "
Print #1,"DATA _"
'================
Dim As String accum
Dim As Integer ctr
For n As Integer=Lbound(Cmull) To Ubound(Cmull)
ctr+=1
accum+=Str(Cmull(n).x)+ ","
If ctr Mod 16 =0 Then accum+= " _"+Chr(13) + Chr(10)
Next n
accum=Rtrim(accum,",")
accum=Rtrim(accum,Chr(10))
accum=Rtrim(accum,Chr(13))
accum=Rtrim(accum,"_")
accum=Rtrim(accum," ")
accum=Rtrim(accum,",")
Print #1,accum
accum=""
ctr=0
Print #1," "
Print #1," "
Print #1,"Y_values:"
Print #1," "
Print #1,"DATA _"
For n As Integer=Lbound(Cmull) To Ubound(Cmull)
ctr+=1
accum+=Str(Cmull(n).y)+ ","
If ctr Mod 16 =0 Then accum+= " _"+Chr(13) + Chr(10)
Next n
accum=Rtrim(accum,",")
accum=Rtrim(accum,Chr(10))
accum=Rtrim(accum,Chr(13))
accum=Rtrim(accum,"_")
accum=Rtrim(accum," ")
accum=Rtrim(accum,",")
Dim As Integer numpts=Ubound(cmull)-Lbound(Cmull)+1
Print #1,accum
Print #1," "
Print #1," "
Print #1,"'Number of points ";Ubound(cmull)-Lbound(Cmull)+1
Print #1,"screenres ";xres;",";yres
Print #1,"dim as v2 p(1 to ";numpts;")"
Print #1,"for n as long=lbound(p) to ubound(p)"
Print #1, "read p(n).x"
Print #1,"next n"
Print #1,"for n as long=lbound(p) to ubound(p)"
Print #1,"read p(n).y"
Print #1,"next n"
Print #1,"for n as long=lbound(p) to ubound(p)"
Print #1, "pset(p(n).x,p(n).y)"
Print #1,"next n"
Print #1,"sleep"
Close #1
Shell "type polypoints.txt"
Sleep
sleep
imagedestroy i