Announcement

**Petr Schreiber jr** · 14 May 2008, 07:12 AM

Congratulations on great program,

very nice design and functionality!

In case there is lot of arrows, resizing causes visible flicker.
This is because of sequence:
- background render
- bitmap updated
- arrows render
- bitmap updated.

To avoid this I modified CanvasCleaner to:

SUB CanvasCleaner(ALL AS LONG, wantRedraw AS LONG)
LOCAL j AS LONG
GRAPHIC CLEAR
GRAPHIC WIDTH 1
IF ALL THEN cntarrow = 0 : REDIM arrow()
FOR j = 0 TO 19
GRAPHIC LINE (j*20, 00) - (j*20, 400), RGB(234,234,234)
GRAPHIC LINE (00, j*20) - (500, j*20), RGB(234,234,234)
NEXT
IF wantRedraw THEN GRAPHIC REDRAW
GRAPHIC WIDTH arrowwidth
END SUB

Then complete code becomes the following and flicker is gone:

Code:

'¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
' [u] Flicker free resizing
'¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
' Arrows.bas                   by Jordi Valle`s        version 1a      13/05/2008
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' Sometimes, on application with graphic elements, is necessary include arrows
' to mark or indicate distances, flows, directions, links, trends, etc.
'
' This program shows an small collection of simple arrow shapes and their functions
' to build it dinamically using PB Graphics instead to use prebuilt figures and shapes.
' Some models can be improved and more combinations can be obtained.
'
' Arrows, after created, can be resized and dragged using left mouse button over
' each end (or near) of selected arrow.
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'  - Program developed and tested with PowerBASIC for Windows (PB/Win 8.04) on a
'    PC HP Pavilion m7760 1.80 GHz with Windows Vista Home Premium.
'  - Only PB Graphic package is used to display information generated by program.
'  - Some algorithms has been found on http://vbgraphic.altervista.org/geoalgo.htm
'  - Part of knowledge needed has been found on MSDN technical interesting articles:
'        Use of Two-Dimensional Vectors with Windows NT
'        Win32: Hit Testing Lines and Curves
'  - Part of code used is borrowed from PwrPaint.bas on PB for Windows Samples folder.
'¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
' SED_PBWIN

#COMPILE EXE "Arrows.exe"
#DIM ALL
#INCLUDE "WIN32API.INC"
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
%ID_ARROW1    = 1001
%ID_ARROW2    = 1002
%ID_ARROW3    = 1003
%ID_ARROW4    = 1004
%ID_ARROW5    = 1005
%ID_ARROW6    = 1006
%ID_ARROW7    = 1007
%ID_ARROW8    = 1008
%ID_ARROW9    = 1009
%ID_ARROW10   = 1010
%ID_ARROW11   = 1011
%ID_ARROW12   = 1012
%ID_ARROW13   = 1013
%ID_ARROW14   = 1014
%ID_ARROW15   = 1015
%ID_GRAPHIC   = 1111
%ID_POSIT     = 1112
%ID_CLEAR     = 1113
%ID_EXIT      = 1114
%ID_FRAME     = 1115
%ID_MODETXT   = 1116
%ID_CBOX2     = 1121
%ID_CBOX3     = 1131
%CANVAS       = &hEEFAFA???  'RGB(250,250,238)
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
MACRO Pi        = 3.141592653589793# 'no comments
MACRO NearZero  = 0.000000000000001# 'to avoid problems in some divisions
MACRO MARGIN    = 3.0#   'default pixel miss margin to help when select the line
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
TYPE POLYARRAY
   cnt AS LONG
   xx1 AS SINGLE  :  yy1 AS SINGLE
   xx2 AS SINGLE  :  yy2 AS SINGLE
   xx3 AS SINGLE  :  yy3 AS SINGLE
   xx4 AS SINGLE  :  yy4 AS SINGLE
END TYPE
TYPE ARROWSTORE
   atype AS LONG
   awidth AS LONG
   astyle AS LONG
   arx1 AS DOUBLE  :  ary1 AS DOUBLE
   arx2 AS DOUBLE  :  ary2 AS DOUBLE
END TYPE
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
GLOBAL oldGraphicProc        AS DWORD
GLOBAL candraw, canmove      AS LONG
GLOBAL X1, Y1, X2, Y2        AS DOUBLE
GLOBAL oldX1, oldY1          AS DOUBLE
GLOBAL oldX2, oldY2          AS DOUBLE
GLOBAL arrowtype, savetype   AS LONG
GLOBAL arrowwidth, savewidth AS LONG
GLOBAL arrowstyle, savestyle AS LONG
GLOBAL arrow()               AS ARROWSTORE
GLOBAL cntarrow, curarrow    AS LONG
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
DECLARE FUNCTION Atn2(Y AS DOUBLE, X AS DOUBLE) AS DOUBLE
DECLARE FUNCTION PointToPointDistance(px1 AS DOUBLE, py1 AS DOUBLE, px2 AS DOUBLE, py2 AS DOUBLE) AS DOUBLE
DECLARE FUNCTION PointToLineDistance(mx AS DOUBLE, my AS DOUBLE, x1 AS DOUBLE, y1 AS DOUBLE, _
                                     x2 AS DOUBLE, y2 AS DOUBLE) AS DOUBLE
DECLARE FUNCTION TestPointInLine(mx AS DOUBLE, my AS DOUBLE, x1 AS DOUBLE, y1 AS DOUBLE, _
                                 x2 AS DOUBLE, y2 AS DOUBLE, linew AS LONG) AS LONG
'¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
FUNCTION PBMAIN () AS LONG
   LOCAL hDlg AS DWORD
   LOCAL w, h AS LONG

   DIALOG NEW PIXELS, 0, "Arrow styles with PB Graphics - 1a", , , 556, 414, _
                         %WS_CAPTION OR %WS_SYSMENU, 0 TO hDlg
   CONTROL ADD GRAPHIC,  hDlg, %ID_GRAPHIC,"", 5, 5, 404, 404, %WS_BORDER OR %SS_NOTIFY
   GRAPHIC ATTACH        hDlg, %ID_GRAPHIC, REDRAW
   CONTROL GET CLIENT    hDlg, %ID_GRAPHIC TO w, h   'get client size
   GRAPHIC SCALE (0, 0) - (w, h)                     'scale to pixel coordinate system
   GRAPHIC COLOR %BLUE, %CANVAS                      'canvas colors

   CONTROL ADD BUTTON,   hDlg, %ID_CLEAR,   "Clear",                416, 387,  66, 22
   CONTROL ADD BUTTON,   hDlg, %ID_EXIT,    "Quit",                 484, 387,  66, 22
   CONTROL ADD LABEL,    hDlg, %ID_MODETXT, "Mode :  draw ",        450, 344, 120, 12
   CONTROL ADD LABEL,    hDlg, %ID_POSIT,   "Pos : ",               450, 360, 100, 12
   CONTROL ADD FRAME,    hDlg, %ID_FRAME,   "Arrow Styles",         416,   5, 135, 316

   CONTROL ADD OPTION,   hDlg, %ID_ARROW1,  "A simple arrow",       422,  24, 120, 16, %WS_GROUP
   CONTROL ADD OPTION,   hDlg, %ID_ARROW2,  "Another simple arrow", 422,  40, 120, 16
   CONTROL ADD OPTION,   hDlg, %ID_ARROW3,  "Two ends arrow",       422,  56, 120, 16
   CONTROL ADD OPTION,   hDlg, %ID_ARROW4,  "Arrow at middle",      422,  72, 120, 16
   CONTROL ADD OPTION,   hDlg, %ID_ARROW5,  "Broken arrow",         422,  88, 120, 16
   CONTROL ADD OPTION,   hDlg, %ID_ARROW6,  "Ball arrow",           422, 104, 120, 16
   CONTROL ADD OPTION,   hDlg, %ID_ARROW7,  "Ball arrow filled",    422, 120, 120, 16
   CONTROL ADD OPTION,   hDlg, %ID_ARROW8,  "Diamond arrow",        422, 136, 120, 16
   CONTROL ADD OPTION,   hDlg, %ID_ARROW9,  "Diamond arrow filled", 422, 152, 120, 16
   CONTROL ADD OPTION,   hDlg, %ID_ARROW10, "Box arrow",            422, 168, 120, 16
   CONTROL ADD OPTION,   hDlg, %ID_ARROW11, "Box arrow filled",     422, 184, 120, 16
   CONTROL ADD OPTION,   hDlg, %ID_ARROW12, "Sharp arrow",          422, 200, 120, 16
   CONTROL ADD OPTION,   hDlg, %ID_ARROW13, "Sharp arrow filled",   422, 216, 120, 16
   CONTROL ADD OPTION,   hDlg, %ID_ARROW14, "Sharp arrow at middle",422, 232, 120, 16
   CONTROL ADD OPTION,   hDlg, %ID_ARROW15, "None",                 422, 248, 120, 16
   CONTROL SET OPTION    hDlg, %ID_ARROW1, %ID_ARROW1, %ID_ARROW15

   CONTROL ADD COMBOBOX, hDlg, %ID_CBOX2,, 420, 268, 126, 225, %CBS_DROPDOWNLIST OR %WS_TABSTOP
   COMBOBOX ADD          hDlg, %ID_CBOX2,   "Pen width =   1"
   COMBOBOX ADD          hDlg, %ID_CBOX2,   "Pen width =   2"
   COMBOBOX ADD          hDlg, %ID_CBOX2,   "Pen width =   3"
   COMBOBOX ADD          hDlg, %ID_CBOX2,   "Pen width =   4"
   COMBOBOX ADD          hDlg, %ID_CBOX2,   "Pen width =   5"
   COMBOBOX SELECT       hDlg, %ID_CBOX2, 1

   CONTROL ADD COMBOBOX, hDlg, %ID_CBOX3,, 420, 294, 126, 125, %CBS_DROPDOWNLIST OR %WS_TABSTOP
   COMBOBOX ADD          hDlg, %ID_CBOX3,   "Pen type = Solid"
   COMBOBOX ADD          hDlg, %ID_CBOX3,   "Pen type = Dash"
   COMBOBOX ADD          hDlg, %ID_CBOX3,   "Pen type = Dot"
   COMBOBOX ADD          hDlg, %ID_CBOX3,   "Pen type = DashDot"
   COMBOBOX ADD          hDlg, %ID_CBOX3,   "Pen type = DashDotDot"
   COMBOBOX SELECT       hDlg, %ID_CBOX3, 1

   DIALOG SHOW MODAL hDlg CALL DlgProc
END FUNCTION

'¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
CALLBACK FUNCTION DlgProc() AS LONG
   LOCAL hGraphic AS DWORD

   SELECT CASE AS LONG CBMSG
      CASE %WM_INITDIALOG
         CONTROL HANDLE CBHNDL, %ID_GRAPHIC TO hGraphic
         oldGraphicProc = SetWindowLong(hGraphic, %GWL_WNDPROC, CODEPTR(GraphicProc))
         arrowtype = 1  :  arrowwidth = 1  :  arrowstyle = 0
         savetype  = 1  :  savewidth  = 1  :  savestyle  = 0
         CALL CanvasCleaner(%TRUE, %TRUE)
      CASE %WM_SETCURSOR
         IF CBWPARAM <> hGraphic THEN  CONTROL SET TEXT CBHNDL, %ID_POSIT, "Pos :"
      CASE %WM_COMMAND
         SELECT CASE CBCTL
            CASE %ID_ARROW1 TO %ID_ARROW15         'arrow type
               arrowtype = CBCTL - 1000
               savetype = arrowtype
            CASE %ID_CBOX2                         'pen width
               IF CBCTLMSG = %CBN_SELENDOK THEN
                  CONTROL SEND CBHNDL, %ID_CBOX2, %CB_GETCURSEL, 0, 0 TO arrowwidth
                  arrowwidth = MAX(1, arrowwidth +1)
                  savewidth = arrowwidth
                  IF arrowwidth = 1 THEN CONTROL ENABLE CBHNDL, %ID_CBOX3 _
                                    ELSE CONTROL DISABLE CBHNDL, %ID_CBOX3
               END IF
            CASE %ID_CBOX3                         'pen type
               IF CBCTLMSG = %CBN_SELENDOK THEN
                  CONTROL SEND CBHNDL, %ID_CBOX3, %CB_GETCURSEL, 0, 0 TO arrowstyle
                  savestyle = arrowstyle
               END IF
            CASE %ID_EXIT
               IF CBCTLMSG = %BN_CLICKED THEN DIALOG END CBHNDL
            CASE %ID_CLEAR
               IF CBCTLMSG = %BN_CLICKED THEN CALL CanvasCleaner(%TRUE, %TRUE)
         END SELECT
      CASE %WM_DESTROY
         IF oldGraphicProc THEN SetWindowLong hGraphic, %GWL_WNDPROC, oldGraphicProc
   END SELECT
END FUNCTION

'¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
' Subclass procedure
FUNCTION GraphicProc(BYVAL hWnd AS DWORD, BYVAL wMsg AS LONG, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG
   SELECT CASE wMsg
      CASE %WM_MOUSEMOVE    :  CALL MouseMove      (hWnd, wParam, lParam)
      CASE %WM_LBUTTONDOWN  :  CALL LeftButtonDown (hWnd, wParam, lParam)
      CASE %WM_LBUTTONUP    :  CALL LeftButtonUp   (hWnd, wParam, lParam)
   END SELECT
   FUNCTION = CallWindowProc(oldGraphicProc, hWnd, wMsg, wParam, lParam)
END FUNCTION

'¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
SUB MouseMove(BYVAL hWnd AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG)
   LOCAL i AS LONG
   LOCAL pt AS POINTAPI
   LOCAL dx, dy, d1, d2 AS DOUBLE

   X2 = LO(INTEGER, lParam)  :  Y2 = HI(INTEGER, lParam)
   CONTROL SET TEXT GetParent(hWnd), %ID_POSIT, "Pos : " + STR$(X2) + "," + STR$(Y2)

   IF canmove AND (wParam AND %MK_LBUTTON) THEN
    
      CALL CanvasCleaner(%FALSE, %FALSE)
      
      GetCursorPos pt
      ScreenToClient hWnd, pt
      dx = pt.x  :  dy = pt.y    'convert to double
      d1 = PointToPointDistance(dx, dy, arrow(curarrow).arx1, arrow(curarrow).ary1)
      d2 = PointToPointDistance(dx, dy, arrow(curarrow).arx2, arrow(curarrow).ary2)
      IF d1 < d2 THEN            'check wich end is more near to mouse pointer
         arrow(curarrow).arx1 = dx
         arrow(curarrow).ary1 = dy
      ELSE
         arrow(curarrow).arx2 = dx
         arrow(curarrow).ary2 = dy
      END IF
      FOR i = 1 TO cntarrow      'redraw all arrows
         arrowwidth = arrow(i).awidth
         arrowtype  = arrow(i).atype
         arrowstyle = arrow(i).astyle
         CALL DrawArrows(arrow(i).arx1, arrow(i).ary1, arrow(i).arx2, arrow(i).ary2)
      NEXT i
      GRAPHIC REDRAW
   ELSEIF candraw AND (wParam AND %MK_LBUTTON) THEN
      IF oldX1 > -1 THEN CALL DrawArrows(oldX1, oldY1, oldX2, oldY2)
      CALL DrawArrows(X1, Y1, X2, Y2)
      oldX1 = X1  :  oldY1 = Y1
      oldX2 = X2  :  oldY2 = Y2
      GRAPHIC REDRAW
   END IF
END SUB

'¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
SUB LeftButtonDown(BYVAL hWnd AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG)
   LOCAL i, dist AS LONG

   SetCapture hWnd
   SetFocus hWnd
   GRAPHIC ATTACH GetParent(hWnd), %ID_GRAPHIC, REDRAW
   X1 = MAX(0, LO(INTEGER, lParam))  :  Y1 = MAX(0, HI(INTEGER, lParam))

   IF cntarrow > 0 THEN
      curarrow = 0
      FOR i = 1 TO cntarrow
         dist = TestPointInLine(X1, Y1, arrow(i).arx1, arrow(i).ary1, arrow(i).arx2, arrow(i).ary2, arrow(i).awidth)
         IF dist THEN
            canmove = i         'set in resize state
            curarrow = i
            CONTROL SET TEXT GetParent(hWnd), %ID_MODETXT, "Mode :  resize"
            EXIT SUB
         END IF
      NEXT i
   END IF

   arrowstyle = savestyle
   arrowwidth = savewidth
   arrowtype  = savetype
   oldX1 = X1  :  oldY1 = Y1
   oldX2 = X1  :  oldY2 = Y1
   GRAPHIC SET MIX %R2_NOTXORPEN
   CALL DrawArrows(X1, Y1, X1, Y1)
   GRAPHIC REDRAW
   candraw = 1                  'set in creation state
   CONTROL SET TEXT GetParent(hWnd), %ID_MODETXT, "Mode :  draw"
END SUB

'¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
SUB LeftButtonUp(BYVAL hWnd AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG)
   IF canmove THEN              'finish mouse resize state
      canmove = 0
      GRAPHIC SET MIX %R2_COPYPEN
      CALL DrawArrows(oldX1, oldY1, oldX2, oldY2)
      GRAPHIC REDRAW
      oldX1  = -1  :  oldY1  = 0
      oldX2  = 0   :  oldY2  = 0
      ReleaseCapture
   ELSEIF candraw THEN          'finish arrow creation state
      candraw = 0
      GRAPHIC SET MIX %R2_COPYPEN
      CALL DrawArrows(oldX1, oldY1, oldX2, oldY2)
      GRAPHIC REDRAW
      INCR cntarrow             'store arrow info on arrow array, arrrgh!
      REDIM PRESERVE arrow(1 TO cntarrow)
      arrow(cntarrow).atype  = arrowtype
      arrow(cntarrow).awidth = arrowwidth
      arrow(cntarrow).astyle = arrowstyle
      arrow(cntarrow).arx1   = oldX1
      arrow(cntarrow).ary1   = oldY1
      arrow(cntarrow).arx2   = oldX2
      arrow(cntarrow).ary2   = oldY2
      oldX1  = -1  :  oldY1  = 0
      oldX2  = 0   :  oldY2  = 0
      ReleaseCapture
   END IF
   CONTROL SET TEXT GetParent(hWnd), %ID_MODETXT, "Mode :  draw"
END SUB

'¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
SUB DrawArrows(frX AS DOUBLE, frY AS DOUBLE, toX AS DOUBLE, toY AS DOUBLE)
   '--- this procedure can be optimized a lot, in size and speed
   '--- here is "as is" in benefit of clarity in code
   LOCAL sharp, slopy, cosy, siny, shcosy, shsiny, dist AS DOUBLE
   LOCAL mdX, mdY, hlX, hlY, hrX, hrY AS DOUBLE
   LOCAL headangle AS DOUBLE
   LOCAL poly AS POLYARRAY

   SELECT CASE AS LONG arrowtype    'arrow side size
      CASE 8 TO 9    :  sharp = 6
      CASE 10 TO 11  :  sharp = 5
      CASE 12 TO 14  :  sharp = 16
      CASE ELSE      :  sharp = 8
   END SELECT

   dist   = PointToPointDistance(frX, frY, toX, toY)
   IF dist <= sharp THEN EXIT SUB
   slopy  = Atn2(frY-toY, frX-toX)
   cosy   = COS(slopy)
   siny   = SIN(slopy)
   shcosy = sharp*cosy
   shsiny = sharp*siny

   GRAPHIC WIDTH arrowwidth
   SELECT CASE AS LONG arrowtype
      CASE 1   '--- one end arrow, very simple ---
         GRAPHIC STYLE arrowstyle
         GRAPHIC LINE (frX,frY) - (toX,toY)
         GRAPHIC STYLE 0
         GRAPHIC LINE           - (toX+(shcosy-shsiny),toY+(shsiny+shcosy))
         GRAPHIC LINE (toX,toY) - (toX-(shcosy+shsiny),toY+(shcosy-shsiny))
      CASE 2   '--- another simple arrow in wireframe style ---
         GRAPHIC STYLE arrowstyle
         GRAPHIC LINE (frX,frY) - (toX,toY)
         GRAPHIC STYLE 0
         GRAPHIC LINE           - (toX+(shcosy-shsiny),toY+(shsiny+shcosy))
         GRAPHIC LINE           - (toX-(shcosy+shsiny),toY+(shcosy-shsiny))
         GRAPHIC LINE           - (toX,toY)
      CASE 3   '--- two ends arrow in wireframe style ---
         GRAPHIC STYLE 0
         GRAPHIC LINE (frX,frY) - (frX-(shcosy-shsiny),frY-(shsiny+shcosy))
         GRAPHIC LINE           - (frX+(shcosy+shsiny),frY-(shcosy-shsiny))
         GRAPHIC LINE           - (frX,frY)
         GRAPHIC STYLE arrowstyle
         GRAPHIC LINE           - (toX,toY)
         GRAPHIC STYLE 0
         GRAPHIC LINE           - (toX+(shcosy-shsiny),toY+(shsiny+shcosy))
         GRAPHIC LINE           - (toX-(shcosy+shsiny),toY+(shcosy-shsiny))
         GRAPHIC LINE           - (toX,toY)
      CASE 4   '--- middle arrow in wireframe style ---
         GRAPHIC STYLE arrowstyle
         GRAPHIC LINE (frX,frY) - (toX,toY)
         GRAPHIC STYLE 0
         mdX = (frX+toX)/2  :  mdY = (frY+toY)/2
         GRAPHIC LINE (mdX,mdY) - (mdX+(shcosy-shsiny),mdY+(shsiny+shcosy))
         GRAPHIC LINE           - (mdX-(shcosy+shsiny),mdY+(shcosy-shsiny))
         GRAPHIC LINE           - (mdX,mdY)
      CASE 5   '--- broken arrow, in wireframe style ---
         GRAPHIC STYLE 0
         GRAPHIC LINE (frX,frY) - (frX-(shcosy-shsiny),frY-(shsiny+shcosy))
         GRAPHIC LINE           - (frX+(shcosy+shsiny),frY-(shcosy-shsiny))
         GRAPHIC LINE           - (frX,frY)
         GRAPHIC STYLE arrowstyle
         GRAPHIC LINE           - (toX,toY)
         GRAPHIC STYLE 0
         GRAPHIC LINE           - (toX+(shcosy-shsiny),toY+(shsiny+shcosy))
         GRAPHIC LINE           - (toX-(shcosy+shsiny),toY+(shcosy-shsiny))
         GRAPHIC LINE           - (toX,toY)
         mdX = (frX+toX)/2  :  mdY = (frY+toY)/2
         hlX = mdX+(shcosy-shsiny)  :  hlY = mdY+(shsiny+shcosy)
         hrX = mdX-(shcosy-shsiny)  :  hrY = mdY-(shsiny+shcosy)
         GRAPHIC LINE (hlX,hlY) - (hrX, hry)
         hlX = mdX+(shcosy+shsiny)  :  hlY = mdY+(shsiny-shcosy)
         hrX = mdX-(shcosy+shsiny)  :  hrY = mdY-(shsiny-shcosy)
         GRAPHIC LINE (hlX,hlY) - (hrX, hry)
      CASE 6   '--- balls arrow in wireframe style ---
         GRAPHIC LINE (frX,frY) - (toX,toY)
         GRAPHIC ELLIPSE (toX-(shsiny)-sharp,toY+(shcosy)-sharp) - (toX-(shsiny)+sharp,toY+(shcosy)+sharp)
         GRAPHIC LINE (toX+(shcosy-shsiny),toY+(shsiny+shcosy)) - (toX-(shcosy+shsiny),toY+(shcosy-shsiny))
      CASE 7   '--- balls arrow filled, solid ---
         GRAPHIC LINE (frX,frY) - (toX,toY)
         GRAPHIC ELLIPSE (frX-2,frY-2) - (frX+2,frY+2), %BLUE, %WHITE
         GRAPHIC ELLIPSE (toX-7,toY-7) - (toX+7,toY+7), %BLUE, %WHITE
      CASE 8   '--- diamond arrow, in wireframe style ---
         GRAPHIC STYLE arrowstyle
         GRAPHIC LINE (frX,frY) - (toX,toY)
         GRAPHIC STYLE 0
         poly.cnt = 4
         poly.xx1 = toX                       :  poly.yy1 = toY
         poly.xx2 = ABS(toX+(shcosy-shsiny))  :  poly.yy2 = ABS(toY+(shsiny+shcosy))
         poly.xx3 = ABS(toX-(2*shsiny))       :  poly.yy3 = ABS(toY+(2*shcosy))
         poly.xx4 = ABS(toX-(shcosy+shsiny))  :  poly.yy4 = ABS(toY+(shcosy-shsiny))
         GRAPHIC POLYGON poly
         GRAPHIC LINE (toX+(shcosy-shsiny),toY+(shsiny+shcosy)) - (toX-(shcosy+shsiny),toY+(shcosy-shsiny))
      CASE 9   '--- diamond arrow solid fill ---
         GRAPHIC STYLE arrowstyle
         GRAPHIC LINE (frX,frY) - (toX,toY)
         GRAPHIC STYLE 0
         poly.cnt = 4
         poly.xx1 = toX                       :  poly.yy1 = toY
         poly.xx2 = ABS(toX+(shcosy-shsiny))  :  poly.yy2 = ABS(toY+(shsiny+shcosy))
         poly.xx3 = ABS(toX-(2*shsiny))       :  poly.yy3 = ABS(toY+(2*shcosy))
         poly.xx4 = ABS(toX-(shcosy+shsiny))  :  poly.yy4 = ABS(toY+(shcosy-shsiny))
         GRAPHIC POLYGON poly, %BLUE, %BLUE
      CASE 10 TO 11   '--- Box arrows ---
         LOCAL hzX, hzY AS DOUBLE
         poly.cnt = 4
         hlX = ABS(toX+sharp*COS(slopy+Pi))
         hlY = ABS(toY+sharp*SIN(slopy+Pi))
         hrX = ABS(toX-sharp*COS(slopy+Pi))
         hrY = ABS(toY-sharp*SIN(slopy+Pi))
         poly.xx1 = hlX  :  poly.yy1 = hlY
         poly.xx2 = hrX  :  poly.yy2 = hrY
         hzX = toX-(2*shsiny) : hzY = toY+(2*shcosy)
         hlX = ABS(hzX+sharp*COS(slopy+Pi))
         hlY = ABS(hzY+sharp*SIN(slopy+Pi))
         hrX = ABS(hzX-sharp*COS(slopy+Pi))
         hrY = ABS(hzY-sharp*SIN(slopy+Pi))
         poly.xx3 = hrX  :  poly.yy3 = hrY
         poly.xx4 = hlX  :  poly.yy4 = hlY
         GRAPHIC STYLE arrowstyle
         GRAPHIC LINE (frX,frY) - (toX, toY)
         GRAPHIC STYLE 0
         SELECT CASE AS LONG arrowtype
            CASE 10
               GRAPHIC POLYGON poly, -1, %CANVAS
               GRAPHIC LINE (poly.xx1,poly.yy1) - (poly.xx3,poly.yy3)
               GRAPHIC LINE (poly.xx2,poly.yy2) - (poly.xx4,poly.yy4)
            CASE 11  :  GRAPHIC POLYGON poly, %BLUE, %YELLOW
         END SELECT
      CASE 12 TO 13   '--- sharp arrows ---
         headangle = Pi/2.5
         hlX = ABS(toX+sharp*COS(slopy+Pi-headangle))
         hlY = ABS(toY+sharp*SIN(slopy+Pi-headangle))
         hrX = ABS(toX-sharp*COS(slopy+Pi+headangle))
         hrY = ABS(toY-sharp*SIN(slopy+Pi+headangle))
         poly.cnt = 3
         poly.xx1 = toX  :  poly.yy1 = toY
         poly.xx2 = hlX  :  poly.yy2 = hlY
         poly.xx3 = hrX  :  poly.yy3 = hrY
         GRAPHIC STYLE arrowstyle
         GRAPHIC LINE (frX,frY) - (toX, toY)
         GRAPHIC STYLE 0
         SELECT CASE AS LONG arrowtype
            CASE 12  :  GRAPHIC POLYGON poly
            CASE 13  :  GRAPHIC POLYGON poly, %BLUE, %BLUE
         END SELECT
      CASE 14   '---sharp arrow at middle ---
         headangle = Pi/2.5
         mdX = (frX+toX)/2  :  mdY = (frY+toY)/2
         hlX = ABS(mdX+sharp*COS(slopy+Pi-headangle))
         hlY = ABS(mdY+sharp*SIN(slopy+Pi-headangle))
         hrX = ABS(mdX-sharp*COS(slopy+Pi+headangle))
         hrY = ABS(mdY-sharp*SIN(slopy+Pi+headangle))
         poly.cnt = 3
         poly.xx1 = mdX  :  poly.yy1 = mdY
         poly.xx2 = hlX  :  poly.yy2 = hlY
         poly.xx3 = hrX  :  poly.yy3 = hrY
         GRAPHIC STYLE arrowstyle
         GRAPHIC LINE (frX,frY) - (toX, toY)
         GRAPHIC STYLE 0
         GRAPHIC POLYGON poly, %BLUE, %WHITE
      CASE 15   '--- line only --- (should be the first)
         GRAPHIC STYLE arrowstyle
         GRAPHIC LINE (frX,frY) - (toX, toY)
   END SELECT
END SUB

'¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
SUB CanvasCleaner(ALL AS LONG, wantRedraw AS LONG)
   LOCAL j AS LONG
   GRAPHIC CLEAR
   GRAPHIC WIDTH 1
   IF ALL THEN cntarrow = 0  :  REDIM arrow()
   FOR j = 0 TO 19
      GRAPHIC LINE (j*20, 00) - (j*20, 400), RGB(234,234,234)
      GRAPHIC LINE (00, j*20) - (500, j*20), RGB(234,234,234)
   NEXT
   IF wantRedraw THEN GRAPHIC REDRAW
   GRAPHIC WIDTH arrowwidth
END SUB

'¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
FUNCTION Atn2(X AS DOUBLE, Y AS DOUBLE) AS DOUBLE
   'Atn2 optimized version. Simple but sufficient for this purpose.
   'Range of the result is 0 to 2pi radians.
   IF Y = 0 THEN Y = NearZero
   FUNCTION = (ATN(ABS(X)/ABS(Y)) * SGN(X) - Pi/2) * SGN(Y)
END FUNCTION

'¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
FUNCTION PointToPointDistance(px1 AS DOUBLE, py1 AS DOUBLE, px2 AS DOUBLE, py2 AS DOUBLE) AS DOUBLE
   FUNCTION = SQR((px1-px2)*(px1-px2) + (py1-py2)*(py1-py2))
END FUNCTION

'¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
FUNCTION PointToLineDistance(mx AS DOUBLE, my AS DOUBLE, vx1 AS DOUBLE, vy1 AS DOUBLE, _
                      vx2 AS DOUBLE, vy2 AS DOUBLE) AS DOUBLE
   LOCAL dx, dy AS DOUBLE
   'mx, my are the mouse points
   IF (vx1 = vx2) THEN
      FUNCTION = ABS(vx1 - mx)
   ELSEIF vy1 = vy2 THEN
      FUNCTION = ABS(vy1 - my)
   ELSE
      dx = vx2 - vx1  :  dy = vy2 - vy1
      FUNCTION = ABS(dy*mx - dx*my + vx2*vy1 - vx1*vy2) / SQR(dx*dx + dy*dy)
   END IF
END FUNCTION

'¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
FUNCTION TestPointInLine(mx AS DOUBLE, my AS DOUBLE, vx1 AS DOUBLE, vy1 AS DOUBLE, _
                      vx2 AS DOUBLE, vy2 AS DOUBLE, linew AS LONG) AS LONG
   'return true if the distance from point to line is within the width of line plus Margin.
   'linew is the existing line width.
   LOCAL distance, halflinew AS DOUBLE
   'exit if the mouse click is past the endpoints of the line
   halflinew = linew/2
   IF (vx1 < vx2) THEN
      IF (mx < vx1 - MARGIN) OR (mx > vx2 + MARGIN) THEN EXIT FUNCTION
   ELSE
      IF (mx > vx1 + MARGIN) OR (mx < vx2 - MARGIN) THEN EXIT FUNCTION
   END IF
   IF (vy1 < vy2) THEN
      IF (my < vy1 - MARGIN) OR (my > vy2 + MARGIN) THEN EXIT FUNCTION
   ELSE
      IF (my > vy1 + MARGIN) OR (my < vy2 - MARGIN) THEN EXIT FUNCTION
   END IF
   distance = ABS(PointToLineDistance(mx, my, vx1, vy1, vx2, vy2))
   FUNCTION = (distance >= -halflinew-MARGIN) AND (distance <= halflinew+MARGIN)
END FUNCTION

'¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
'eof

**Jordi Vallès** · 14 May 2008, 12:28 PM

Thanks Petr.
You are right. With more than twenty arrows starts some flicker.
Modification you suggested solves the problem.

Kind regards.
Jordi

Announcement

Forum Guidelines

Arrows with PB Graphics

Arrows with PB Graphics

Comment

Comment