Spline Curve

Source-code only - please, don't post questions here.
Zamaster
Posts: 1020
Joined: Jun 20, 2005 21:40
Contact:

Spline Curve

Postby Zamaster » Dec 09, 2006 22:16

I made it for the water thing, nice way to make polygons look curvy. Idea came from those little sqaure/dot/draw line things I did way back in 6th grade or so, ya know? that thing where all those lines drawn between two other lines make a curve.

Code: Select all

Option Explicit



Sub Curve(byval Ax as integer, Ay as integer, byval Bx as integer, byval By as integer, byval Cx as integer, Cy as integer)
    Dim as double m1x, m1y, m2x, m2y, d1, d2, m, vx1, vy1, vx2, vy2, dx, dy, dm, sm, sam, px1, py1, px2, py2
    Dim as double vpx1, vpy1, vpx2, vpy2
    m1x = (Ax+Bx) SHR 1
    m1y = (Ay+By) SHR 1
    m2x = (Bx+Cx) SHR 1
    m2y = (By+Cy) SHR 1
    vx1 = m1x-Bx: vy1 = m1y-By
    vx2 = m2x-Bx: vy2 = m2y-By
    d1 = SQR(vx1*vx1 + vy1*vy1)
    d2 = SQR(vx2*vx2 + vy2*vy2)
    If d1 >= d2 Then
        m = d1
    Else
        m = d2
    Endif
    vx1 /= m: vy1 /= m
    vx2 /= m: vy2 /= m
    sm = 1/m
    Dim as double i
    For i = 0 To m
        px1 = (m1x-vpx1): py1 = (m1y-vpy1)
        px2 = (Bx+vpx2): py2 = (By+vpy2)
        dx = px2-px1
        dy = py2-py1
        sam += sm
        vpx1 += vx1: vpy1 += vy1
        vpx2 += vx2: vpy2 += vy2
        Pset (px1+dx*sam, py1+dy*sam), &HFFFF00
    Next i
End Sub



'_______________________________________________________________
'__________________________TEST CODE____________________________
Type OPair
    as integer x, y
End Type

Dim as OPair A, B, C



screenres 640,480,32, 2
screenset 1,0
randomize timer
A.x = INT(rnd*640): A.y = int(rnd*480)
B.x = int(rnd*640): B.y = int(rnd*480)
C.x = int(rnd*640): C.y = int(rnd*480)

Dim as integer mx,my,bt,t, s
Dim as double d1,d2,d3
s = 0
Do
cls
getmouse mx,my,,bt

If bt>0 And s = 0 Then
    s = 1
    d1 = SQR((mx-A.x)^2+(my-A.y)^2)
    d2 = SQR((mx-B.x)^2+(my-B.y)^2)
    d3 = SQR((mx-C.x)^2+(my-C.y)^2)
    If d1 < d2 And d1 < d3 Then
        t = 1
        GOTO eo
    Endif
    If d2 < d1 And d2 < d3 Then
        t = 2
        GOTO eo
    Endif
    t = 3
Elseif bt>0 And s = 1 then
    If t=1 Then A.x = mx: A.y = my
    If t=2 Then B.x = mx: B.y = my
    If t=3 Then C.x = mx: C.y = my
Elseif bt=0 And s = 1 Then   
    s = 0
    t = 0
Endif
EO:

screenlock
Line (A.x, A.y)-(B.x, B.y), RGB(32,32,32)
Line (B.x, B.y)-(C.x, C.y), RGB(32,32,32)
Line (C.x, C.y)-(A.x, A.y), RGB(32,32,32)
Curve A.x, A.y, B.x, B.y, C.x, C.y
Curve B.x, B.y, C.x, C.y, A.x, A.y
Curve C.x, C.y, A.x, A.y, B.x, B.y
Line (A.x-2,A.y-2)-(A.x+2, A.y+2), RGB(128,255,128),B
Line (B.x-2,B.y-2)-(B.x+2, B.y+2), RGB(128,255,128),B
Line (C.x-2,C.y-2)-(C.x+2, C.y+2), RGB(128,255,128),B
screenunlock




Flip
Loop until multikey(&H01)

end

Last edited by Zamaster on Dec 10, 2006 19:23, edited 1 time in total.
duke4e
Posts: 717
Joined: Dec 04, 2005 0:16
Location: Varazdin, Croatia, Europe
Contact:

Postby duke4e » Dec 10, 2006 1:25

this looks sexy :)
i like moving things around...
DNAarray
Posts: 29
Joined: May 15, 2006 21:17

looks great

Postby DNAarray » Dec 11, 2006 4:14

awesome
Pritchard
Posts: 5425
Joined: Sep 12, 2005 20:06
Location: Ohio, USA

Postby Pritchard » Dec 11, 2006 9:46

Very awesome. Hahah, create an anti-aliased version of this :D
ytwinky
Posts: 217
Joined: Dec 03, 2005 12:44
Location: MD, Germany

Postby ytwinky » Dec 11, 2006 18:50

hi,
I like this proggram very much but:
..I wanted to get rid of the Goto-Command, which I don't like for some (good) reasons..
..some (not only cosmetical optimizations) followed and here it is, still working as before:

Code: Select all

#define Real Single
Option Explicit

Sub Curve(byVal Ax As Long, byVal Ay As Long, byVal Bx As Long, byVal By As Long, byVal Cx As Long, byVal Cy As Long)
  Dim As Real m1x=(Ax+Bx) Shr 1, m1y=(Ay+By) Shr 1, m2x=(Bx+Cx) Shr 1, m2y=(By+Cy) Shr 1
  Dim As Real vx1=m1x-Bx, vy1=m1y-By, vx2=m2x-Bx, vy2=m2y-By, d1=Sqr(vx1*vx1+vy1*vy1), d2=Sqr(vx2*vx2+vy2*vy2)
  Dim As Real dx, dy, dm, sm, sam, px1, py1, px2, py2, vpx1, vpy1, vpx2, vpy2, m=IIF(d1>=d2, d1, d2)
  Dim As Long i
  vx1/=m
  vy1/=m
  vx2/=m
  vy2/=m
  sm=1/m
  For i=0 To m
    px1=m1x-vpx1
    py1=m1y-vpy1
    px2=Bx+vpx2
    py2=By+vpy2
    dx=px2-px1
    dy=py2-py1
    sam+=sm
    vpx1+=vx1
    vpy1+=vy1
    vpx2+=vx2
    vpy2+=vy2
    PSet (px1+dx*sam, py1+dy*sam), &HFFFF00
  Next i
End Sub

'__________________________TEST CODE____________________________
Type OPair
  As Long x, y
End Type

Dim A(1 To 3) As OPair, d(1 To 3) As Real
Dim As Long mx, my, bt, t, s, lc=RGB(32, 32, 32), sc=RGB(128, 255, 128), sx=640, sy=480, i
ScreenRes sx, sy, 32, 2
ScreenSet 1, 0
Randomize Timer
For i=1 To 3
  A(i).x=Int(Rnd*sx)
  A(i).y=Int(Rnd*sy)
Next

s=0
Do
  Cls
  GetMouse mx, my,, bt
  If bt>0 And s=0 Then
    s=1
    For i=1 To 3
      d(i)=Sqr((mx-A(i).x)^2+(my-A(i).y)^2)
    Next
    t=IIF(d(1)<d(2) And d(1)<d(3), 1, IIF(d(2)<d(1) And d(2)<d(3), 2, 3))
  ElseIf bt>0 And s=1 Then
    A(t).x=mx
    A(t).y=my
  ElseIf bt=0 And s=1 Then
    s=0
    t=0
  EndIf
EO: 'not really needed :D
  ScreenLock
    Line (A(1).x, A(1).y)-(A(2).x, A(2).y), lc
    Line (A(2).x, A(2).y)-(A(3).x, A(3).y), lc
    Line (A(3).x, A(3).y)-(A(1).x, A(1).y), lc
    Curve A(1).x, A(1).y, A(2).x, A(2).y, A(3).x, A(3).y
    Curve A(2).x, A(2).y, A(3).x, A(3).y, A(1).x, A(1).y
    Curve A(3).x, A(3).y, A(1).x, A(1).y, A(2).x, A(2).y
    Line (A(1).x-2, A(1).y-2)-(A(1).x+2, A(1).y+2), sc, B
    Line (A(2).x-2, A(2).y-2)-(A(2).x+2, A(2).y+2), sc, B
    Line (A(3).x-2, A(3).y-2)-(A(3).x+2, A(3).y+2), sc, B
  ScreenUnlock
  Flip
Loop Until MultiKey(&H01)
End
..as you can see, I took the color-evaluation off the loop 'cause it's not necessary
to evaluate constant values permanently. Plz note the 'intensive' use of my dearest command:IIF()
Regards
ytwinky
Zamaster
Posts: 1020
Joined: Jun 20, 2005 21:40
Contact:

Postby Zamaster » Dec 11, 2006 20:35

ah, well... the algorithm was optomized by me! lol. coolio yo. I personally like GOTOs... dont know why
DNAarray
Posts: 29
Joined: May 15, 2006 21:17

alpha blending

Postby DNAarray » Dec 12, 2006 2:22

From the original code, rather than use pset, i used imagecreate and posted to screen twice with alpha blending of 100 sleep 1 was added in loop so you don't take 98% of the systems resources.




Code: Select all

Option Explicit



Sub Curve(Byval Ax As Integer, Ay As Integer, Byval Bx As Integer, Byval By As Integer, Byval Cx As Integer, Cy As Integer)
    Dim As Double m1x, m1y, m2x, m2y, d1, d2, m, vx1, vy1, vx2, vy2, dx, dy, dm, sm, sam, px1, py1, px2, py2
    Dim As Double vpx1, vpy1, vpx2, vpy2
    DIM zz AS ANY PTR
    zz=imagecreate(3,3,&hAAAA33)
    m1x = (Ax+Bx) Shr 1
    m1y = (Ay+By) Shr 1
    m2x = (Bx+Cx) Shr 1
    m2y = (By+Cy) Shr 1
    vx1 = m1x-Bx: vy1 = m1y-By
    vx2 = m2x-Bx: vy2 = m2y-By
    d1 = Sqr(vx1*vx1 + vy1*vy1)
    d2 = Sqr(vx2*vx2 + vy2*vy2)
    If d1 >= d2 Then
        m = d1
    Else
        m = d2
    Endif
    vx1 /= m: vy1 /= m
    vx2 /= m: vy2 /= m
    sm = 1/m
    Dim As Double i
    For i = 0 To m
        px1 = (m1x-vpx1): py1 = (m1y-vpy1)
        px2 = (Bx+vpx2): py2 = (By+vpy2)
        dx = px2-px1
        dy = py2-py1
        sam += sm
        vpx1 += vx1: vpy1 += vy1
        vpx2 += vx2: vpy2 += vy2
        Put (px1+dx*sam, py1+dy*sam), zz,ALPHA,100
        Put (px1+dx*sam, py1+dy*sam), zz,ALPHA,100
   Next i
End Sub



'_______________________________________________________________
'__________________________TEST CODE____________________________
Type OPair
    As Integer x, y
End Type
Dim As OPair A, B, C

screenres 640,480,32, 2
screenset 1,0
Randomize Timer
A.x = Int(Rnd*640): A.y = Int(Rnd*480)
B.x = Int(Rnd*640): B.y = Int(Rnd*480)
C.x = Int(Rnd*640): C.y = Int(Rnd*480)

Dim As Integer mx,my,bt,t, s
Dim As Double d1,d2,d3
s = 0
Do
Cls
getmouse mx,my,,bt

If bt>0 And s = 0 Then
    s = 1
    d1 = Sqr((mx-A.x)^2+(my-A.y)^2)
    d2 = Sqr((mx-B.x)^2+(my-B.y)^2)
    d3 = Sqr((mx-C.x)^2+(my-C.y)^2)
    If d1 < d2 And d1 < d3 Then
        t = 1
        Goto eo
    Endif
    If d2 < d1 And d2 < d3 Then
        t = 2
        Goto eo
    Endif
    t = 3
Elseif bt>0 And s = 1 Then
    If t=1 Then A.x = mx: A.y = my
    If t=2 Then B.x = mx: B.y = my
    If t=3 Then C.x = mx: C.y = my
Elseif bt=0 And s = 1 Then   
    s = 0
    t = 0
Endif
EO:

screenlock
Line (A.x, A.y)-(B.x, B.y), RGB(32,32,32)
Line (B.x, B.y)-(C.x, C.y), RGB(32,32,32)
Line (C.x, C.y)-(A.x, A.y), RGB(32,32,32)
Curve A.x, A.y, B.x, B.y, C.x, C.y
Curve B.x, B.y, C.x, C.y, A.x, A.y
Curve C.x, C.y, A.x, A.y, B.x, B.y
Line (A.x-2,A.y-2)-(A.x+2, A.y+2), RGB(128,255,128),B
Line (B.x-2,B.y-2)-(B.x+2, B.y+2), RGB(128,255,128),B
Line (C.x-2,C.y-2)-(C.x+2, C.y+2), RGB(128,255,128),B
screenunlock




Flip
Loop Until multikey(&H01)
sleep 1
End

 
Zamaster
Posts: 1020
Joined: Jun 20, 2005 21:40
Contact:

Postby Zamaster » Dec 12, 2006 2:56

ARGHHHHHHH!!! Everyone is harrassing me about the test code, who CARES?!?!?!?! Its the algorithm that means anything! Yes, I know you can substitute PSET to plot the curve and you can use different test code, but thats totaly not the point. Its the algorithm yo, da math and stuff!
Pritchard
Posts: 5425
Joined: Sep 12, 2005 20:06
Location: Ohio, USA

Postby Pritchard » Dec 12, 2006 8:23

We're not harrassing you. We're making improvements because that's what we do. People care about things other than the algorithm sometimes. Ex: Better test code . . . :D I don't think these are personal attacks. This is tips & tricks so expect someone to play around with your code a bit.

Although, if someone improved the algorithm that'd be best for this kind of post. Ex: Make a faster/better spline curve math.
Zamaster
Posts: 1020
Joined: Jun 20, 2005 21:40
Contact:

Postby Zamaster » Dec 12, 2006 21:08

exaclty, test code is test code. "test". But im all up for improvements on the actual algorithm.

Return to “Tips and Tricks”

Who is online

Users browsing this forum: Bing [Bot] and 0 guests