Here is the new code with your changes.
I've found this forgotten code looking for a response to yesterday Trond's ask for Filled Bezier shapes:
http://www.purebasic.fr/english/viewtop ... 72c0b8700f
This don't resolve his question, but the code seems better than the 4 years old original.
Obviously th 200 points limit is arbitrary.
A better code could allow the change of point positions and unlimited number of points.
1) With LinkedLists instead of Arrays, at cost of slow calculations.
2) Redimming the arrays when the number of points reaches the maximum limit.
Luckyly the maths on procedure Splin(n) seems to work fairly well.
Code: Select all
;Cubic Splines - by einander with improvements by Demivec
;PB 4.20 beta 5
;May 18 2008
Define Title$ = "Left MouseButton to set points ; Right MuseButton to draw spline - Deflect (MouseWheel) = "
Define.l hwnd, Wi, He, TB, BtnClear, BtnDefault, Num, OldNum, Ev, Stat
#r175=1.75 : #O5=0.5: #O25=0.25 :#e6=0.000001
Global _Img,_ImGad ,Step_Max,_DRAWING,_MW
Global _MaxPoints=200 ; set your points limit
Global _Steps=100 ; steps between points ; increase to smooth curves
Global _Deflect.f
Structure VERTEX
A.D : b.D : c.D
EndStructure
Global Dim _X.l(_MaxPoints )
Global Dim _Y.l(_MaxPoints )
Global Dim _xSPL.l(_MaxPoints*_MaxPoints)
Global Dim _ySPL.l(_MaxPoints*_MaxPoints)
Macro ArrayCopy(SRC,Dest) ;- ArrayCopy(@SRC(),@DEST())
CopyMemory(SRC,Dest, PeekL( SRC-8 ) *4)
EndMacro
Macro STOPDRAW ;- StopDraw
If _DRAWING:StopDrawing():_DRAWING=0:EndIf
EndMacro
Macro DrawIMG(IMG) ;- DrawIMG(IMG)
If _DRAWING:StopDrawing():EndIf
_DRAWING=StartDrawing(ImageOutput(IMG))
EndMacro
Macro GadIMG(ImGad=_ImGad,IMG=_Img,FreeIMG=0) ;-Gadimg(ImGad=_ImGad,IMG=_Img,FreeIMG=0)
STOPDRAW
SetGadgetState(ImGad,ImageID(IMG))
If FreeIMG :FreeImage(IMG):EndIf
EndMacro
Procedure ClsImg(IMG,RGB=0) ;-ClsImg(IMG,RGB=0)
DrawIMG(IMG)
Box(0,0,ImageWidth(IMG),ImageHeight(IMG),RGB)
EndProcedure
Macro MMx : WindowMouseX(EventWindow()) : EndMacro
Macro MMy : WindowMouseY(EventWindow()) : EndMacro
Macro MMK
Abs(GetAsyncKeyState_(#VK_LBUTTON) +GetAsyncKeyState_(#VK_RBUTTON)*2+GetAsyncKeyState_(#VK_MBUTTON)*3)/$8000
EndMacro
Procedure MW(STP=1) ;Ret MouseWheel y Hace _MW
_MW= -EventwParam()>>16/100*STP ; a menor divisor, mayor step
ProcedureReturn _MW
EndProcedure
Procedure Splin(n)
Hsteps.D=1/_Steps
Num=n
*Supp=@_X()
*Spli=@_xSPL()
nPoints=_MaxPoints*_MaxPoints
Dim Vec.VERTEX(_MaxPoints)
Dim Supp(_MaxPoints)
Dim Spli(nPoints )
S.D : Dr.D : T.D
DEFL.f=_Deflect+6
For Loop=0 To 1 ; first loop for X, second for Y
ArrayCopy(*Supp,@Supp())
ArrayCopy(*Spli,@Spli())
N1 =n-1
Vec(0)\A = (Supp(1) - Supp(0)) * DEFL
For i = 1 To N1
Vec(i)\A = (Supp(1+i ) - Supp(i ) * 2 + Supp(i -1)) * DEFL/2
Next i
Vec(n)\A = (Supp(N1) - Supp(n )) * DEFL
Vec(0)\b = Vec(0)\A * #O5
Vec(1)\A -Vec(0)\A * #O25
Dr = 1 /#r175
Vec(1)\b = Vec(1)\A / #r175
For i = 2 To N1
S = -#O5 * Dr
Vec(i)\A+Vec(i-1)\A * S
Dr = 1 / (S * #O5 + 2)
Vec(i)\b =Vec(i)\A * Dr
Next i
Vec(n)\A + Vec(N1)\A * -Dr
Vec(n)\b = Vec(n)\A / (-Dr * #O5 + 2)
i=N1
Repeat
If Vec(i)\A = 0 : T = #e6
Else : T = Vec(i)\A
EndIf
Vec(i)\b*(1 - Vec(i+1)\b / T * #O5)
i-1
Until i=0
If Vec(0)\A = 0 : T = #e6
Else : T = Vec(0)\A
EndIf
Vec(0)\b * (1 - Vec(1)\b / T)
For i = 1 To n
Vec(i)\A = Supp(i ) - Supp(i-1) + (Vec(i)\b * 2 + Vec(i-1)\b) /6
Vec(i)\c = (Vec(i)\b -Vec(i-1)\ b) /6
Next i
For i = 1 To n
Vec(i)\b*#O5
Next i
K = 0
For i = 1 To n
T = -1
For j = 0 To _Steps - 1
Spli(K ) = ((Vec(i)\c * T + Vec(i)\b) * T + Vec(i)\A) * T + Supp(i )
T+Hsteps
K+1
Next j
Next i
Spli(K) = Supp(n )
ArrayCopy(@Spli(),*Spli)
ArrayCopy(@Supp(),*Supp)
*Supp=@_Y()
*Spli=@_ySPL()
n=Num
Next
Dim Supp(0) :Dim Spli(0):Dim Vec.VERTEX(0)
EndProcedure
Macro GetPoints(Num)
If MMK = 1
If Num=-1
ClsImg(_Img) : GadIMG()
EndIf
DrawIMG(_Img)
Circle (MMx ,MMy ,5,#Red)
Num+1
_X(Num ) = MMx : _Y(Num ) = MMy
DrawText( MMx,MMy+ 6,Str(Num),#White,0)
GadIMG()
While MMK : WaitWindowEvent() : Wend
EndIf
If Num = _MaxPoints Or MMK=2 : Stat=1 : EndIf
EndMacro
;-----------------------------
Procedure DrawSplin(Num,*Stat)
Protected i.l
If Num < 2
MessageRequester("","Not enough Points Selected",0)
ProcedureReturn Num
ElseIf Num >= _MaxPoints
MessageRequester("","Maximum points reached",0)
Num = _MaxPoints - 1
EndIf
Splin(Num)
DrawIMG(_Img)
ClsImg(_Img)
For i = 1 To Num * _Steps
LineXY(_xSPL(i - 1),_ySPL(i - 1),_xSPL(i),_ySPL(i),#Yellow)
Next i
For i = 0 To Num
Circle (_X(i) ,_Y(i) ,5,#Red)
Next
GadIMG()
ProcedureReturn Num
EndProcedure
;_________________________________________________________________________________________
Title$="Left MouseButton to set points ; Right MuseButton to draw spline - Deflect (MouseWheel) = "
hwnd=OpenWindow(0,50,50,800,600,Title$,#PB_Window_MinimizeGadget |#PB_Window_Maximize)
SetWindowColor(0,0)
Wi=WindowWidth(0):He=WindowHeight(0)
CreateGadgetList(hwnd)
_Img=CreateImage(#PB_Any,Wi,He-30,32)
_ImGad=ImageGadget(#PB_Any,0,0,0,0,ImageID(_Img))
TB=TrackBarGadget(#PB_Any,0,He-25,Wi-200,22,1,600)
BtnClear=ButtonGadget(#PB_Any,Wi-190,He-25,80,22,"Clear")
BtnDefault=ButtonGadget(#PB_Any,Wi-100,He-25,80,22,"Reset Deflect")
_Deflect=0
SetGadgetState(TB,260)
SetWindowTitle(0,Title$+StrF(_Deflect,1))
Num=#PB_Any
Repeat
If GetAsyncKeyState_(#VK_ESCAPE):End:EndIf
Ev = WindowEvent()
Select Ev
Case #PB_Event_Gadget
If EventGadget()=TB
_Deflect=GetGadgetState(TB)/10.0-26
If Num>1: Stat=2:EndIf
SetWindowTitle(0,Title$+StrF(_Deflect,1))
ElseIf EventGadget()=BtnClear
ClsImg(_Img) : GadIMG()
Stat=0 : Num=-1
ElseIf EventGadget()=BtnDefault
_Deflect=0
SetGadgetState(TB,260)
SetWindowTitle(0,Title$+StrF(_Deflect,1))
If Num>1:Stat=2:EndIf
EndIf
Case #WM_MOUSEWHEEL
SetGadgetState(TB,GetGadgetState(TB)+MW())
_Deflect=GetGadgetState(TB)/10.0-26
SetWindowTitle(0,Title$+StrF(_Deflect,1))
If Num>1: Stat=2:EndIf
Case 0:Delay(10)
EndSelect
If Stat=0 And MMy<He-30
GetPoints(Num)
ElseIf Stat =1 Or Stat=2
OldNum=Num
Num = DrawSplin(Num,@Stat) ;DrawSplin(Num,@Stat)
Stat=0
While MMK : WaitWindowEvent() : Wend
EndIf
Until Ev= #PB_Event_CloseWindow
End