You are not logged in or registered. Please login or register to use the full functionality of this board...
SIGN IN Join Our Community For FREE


Curve smoother / Signature pad
08-28-2014, 10:05 PM
Post: #1
 (Print Post)
Curve smoother / Signature pad
This short program takes a crudely-drawn curve and converts it into a smooth one using linear interpolation. (Ignore the file IO stuff if you want, it works the same either way.)

Code Snippet: [Select]
targetpoints = 1000

referencerad = 1
zoomfactor = 100
maxcurves = 100
smoothfactor = 100
minimumlength = 0.0025
filewrite$ = "export.dat"
drivewrite$ = "W"
' ********** ********** ********** ********** **********
SCREEN 12
screenwidth = 640
screenheight = 480
centerx = screenwidth / 2
centery = screenheight / 2
start:
REDIM pointchainx(maxcurves, targetpoints)
REDIM pointchainy(maxcurves, targetpoints)
REDIM tempchainx(maxcurves, targetpoints)
REDIM tempchainy(maxcurves, targetpoints)
CLS
GOSUB printbackground
curvenum = 0
xold = 999999
yold = 999999
exitflag = 0
DO
    curvenum = curvenum + 1
    numpoints = 0
    DO
        DO WHILE _MOUSEINPUT
            x = _MOUSEX
            y = _MOUSEY
            IF x > 0 AND x < screenwidth AND y > 0 AND y < screenheight THEN
                IF _MOUSEBUTTON(1) THEN
                    GOSUB unconvert
                    delta = (x - xold) ^ 2 + (y - yold) ^ 2
                    IF delta > minimumlength THEN
                        numpoints = numpoints + 1
                        pointchainx(curvenum, numpoints) = x
                        pointchainy(curvenum, numpoints) = y
                        LOCATE 1, 1: PRINT curvenum
                        LOCATE 2, 1: PRINT numpoints
                        xold = x: yold = y
                        x = x * zoomfactor: y = y * zoomfactor: GOSUB convert
                        PSET (x, y), 14
                    END IF
                ELSE
                    IF _MOUSEBUTTON(2) THEN
                        curvenum = curvenum - 1
                    END IF
                END IF
            END IF
        LOOP
        key$ = INKEY$
        SELECT CASE key$
            CASE " "
                GOTO start
            CASE CHR$(27)
                exitflag = 1
                GOTO quitsequence
        END SELECT
    LOOP UNTIL NOT _MOUSEBUTTON(1) AND numpoints > 1
    DO
        rad2max = -1
        kmax = -1
        FOR k = 1 TO numpoints - 1
            xfac = pointchainx(curvenum, k) - pointchainx(curvenum, k + 1)
            yfac = pointchainy(curvenum, k) - pointchainy(curvenum, k + 1)
            rad2 = xfac ^ 2 + yfac ^ 2
            IF rad2 > rad2max THEN
                kmax = k
                rad2max = rad2
            END IF
        NEXT
        FOR j = numpoints TO kmax + 1 STEP -1
            pointchainx(curvenum, j + 1) = pointchainx(curvenum, j)
            pointchainy(curvenum, j + 1) = pointchainy(curvenum, j)
        NEXT
        pointchainx(curvenum, kmax + 1) = (1 / 2) * (pointchainx(curvenum, kmax) + pointchainx(curvenum, kmax + 2))
        pointchainy(curvenum, kmax + 1) = (1 / 2) * (pointchainy(curvenum, kmax) + pointchainy(curvenum, kmax + 2))
        numpoints = numpoints + 1
    LOOP UNTIL numpoints = targetpoints
    FOR j = 1 TO smoothfactor
        FOR k = 2 TO numpoints - 1
            tempchainx(curvenum, k) = (1 / 2) * (pointchainx(curvenum, k - 1) + pointchainx(curvenum, k + 1))
            tempchainy(curvenum, k) = (1 / 2) * (pointchainy(curvenum, k - 1) + pointchainy(curvenum, k + 1))
        NEXT
        FOR k = 2 TO numpoints - 1
            pointchainx(curvenum, k) = tempchainx(curvenum, k)
            pointchainy(curvenum, k) = tempchainy(curvenum, k)
        NEXT
    NEXT
    CLS
    GOSUB printbackground
    GOSUB drawcurves
LOOP UNTIL exitflag = 1
quitsequence:
OPEN drivewrite$ + ":\" + filewrite$ FOR OUTPUT AS #1
FOR j = 1 TO targetpoints
    PRINT #1, USING "###.###     ###.###"; pointchainx(1, j), pointchainy(1, j)
NEXT
CLOSE #1
END
convert:
x0 = x: y0 = y
x = x0 + centerx
y = -y0 + centery
RETURN
unconvert:
x0 = x: y0 = y
x = x0 - centerx
y = -y0 + centery
x = x / zoomfactor
y = y / zoomfactor
RETURN
printbackground:
x = 0: y = 0: GOSUB convert
CIRCLE (x, y), referencerad * zoomfactor, 8
LOCATE 1, 7: PRINT "   Drag the left mouse button to draw a curve. Right click to undo."
LOCATE 2, 7: PRINT "Single left-clicking generates straight lines. Press space to restart."
RETURN
readfile:
OPEN driveread$ + ":\" + partner$ + ".dat" FOR INPUT AS #1
numextpoints = 0
DO
    numextpoints = numextpoints + 1
    INPUT #1, externalpointsx(numextpoints), externalpointsy(numextpoints)
LOOP WHILE EOF(1) = 0
CLOSE #1
RETURN
drawcurves:
FOR w = 1 TO curvenum
    FOR k = 1 TO targetpoints - 1
        x = pointchainx(w, k) * zoomfactor
        y = pointchainy(w, k) * zoomfactor
        GOSUB convert
        xa = x: ya = y
        x = pointchainx(w, k + 1) * zoomfactor
        y = pointchainy(w, k + 1) * zoomfactor
        GOSUB convert
        xb = x: yb = y
        LINE (xa, ya)-(xb, yb), 14
    NEXT
NEXT
RETURN
Find all posts by this user
Like Post
The following 1 user Likes STxAxTIC's post:
Waltersmind (Admin)
09-02-2014, 11:16 AM
Post: #2
 (Print Post)
RE: Curve smoother / Signature pad
Bill,

As always, very nice! This is something that I would like to study sometime in the future.

Thanks for sharing!


Walter Whitman
The Joyful Programmer

Please help support The Joyful Programmer and The QB64 Edition by visiting our online store provided by Amazon.com. We hand-picked books related to computer programming from Amazon.com and added them to our store. When you make a purchase from our store, we do receive a small commission from the sale. Visit our store at: http://www.thejoyfulprogrammer.com/qb64/...azon-store
Find all posts by this user
Like Post



Forum Jump:


User(s) browsing this thread: 1 Guest(s)




QB64 Member Project - Kobolts Monopoly
QB64 Member Project - Algeria Weather
QB64 Member Project - Overboard
QB64 Member Project - Inside Moves
QB64 Member Project - ARB Checkers
QB64 Member Project - MAPTRIANGLE
QB64 Member Project - Connect Four
QB64 Member Project - RGB Color Wheel
QB64 Member Project - Quarto
QB64 Member Project - Dreamy Clock
QB64 Member Project - Foursight
QB64 Member Project - Othello
QB64 Member Project - Qubic
QB64 Member Project - Martin Fractals version three
QB64 Member Project - Spiro Roses
QB64 Member Project - OpenGL Triangles
QB64 Member Project - Martin Fractals version two
QB64 Member Project - Splatter
QB64 Member Project - Swirl
QB64 Member Project - Basic Dithering
QB64 Member Project - Pivot version two
QB64 Member Project - Kings Court
QB64 Member Project - Full Color LED Sign
QB64 Member Project - Color Rotating Text
QB64 Member Project - Pivet version one
QB64 Member Project - Isolation
QB64 Member Project - Amazon
QB64 Member Project - 9 Board
QB64 Member Project - Dakapo
QB64 Member Project - Input
QB64 Member Project - Martin Fractals version one
QB64 Member Project - Martin Fractals version four
QB64 Member Project - Rubix's Magic
QB64 Member Project - Domain
QB64 Member Project - Point Blank
QB64 Member Project - Red Scrolling LED Sign
QB64 Member Project - Color Triangles
QB64 Member Project - Bowditch curve
QB64 Member Project - Kings Valley verion one
QB64 Member Project - Exit
QB64 Member Project - Blokus
QB64 Member Project - Sabotage
QB64 Member Project - STxAxTIC 3D World
QB64 Member Project - Kings Vallery version two
QB64 Member Project - Rotating Background
QB64 Member Project - Line Thickness
QB64 Member Project - Spinning Color Wheel
QB64 Member Project - Touche
QB64 Member Project - Score 4