Sorry your browser is not supported!

;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