home *** CD-ROM | disk | FTP | other *** search
/ Piper's Pit BBS/FTP: ibm 0010 - 0019 / ibm0010-0019 / ibm0010.tar / ibm0010 / CADKEY_C.ZIP / CADKEY14.ZIP / CDL / LNPPTAN.CDL < prev    next >
Encoding:
Text File  |  1989-03-08  |  3.2 KB  |  140 lines
  1.  
  2. REM     date:     030789 simon izraelevitz
  3.  
  4. REM     task:     creates a line tangent to an arc or circle and
  5. REM               perpendicular to a line. Works from any view
  6.  
  7. REM     restrictions: arc and line must be coplanars.
  8. REM     -----------------------------------------------
  9.  
  10.    CLEAR
  11.    accuracy = 0.00005
  12.    ARRAY  vm[9]
  13.    ARRAY  vm1[9]
  14.  
  15. :ind_ln
  16. REM     *** get base line
  17.    SET mask,2
  18.    GETENT  "Indicate line", etype
  19.    IF (@KEY <= -2)
  20.       GOTO exit
  21.  
  22.    p1wx = @FLTDAT[0]
  23.    p1wy = @FLTDAT[1]
  24.    p1wz = @FLTDAT[2]
  25.    p2wx = @FLTDAT[3]
  26.    p2wy = @FLTDAT[4]
  27.    p2wz = @FLTDAT[5]
  28.  
  29. REM     *** define line unit vector, in world coord.
  30.    dx = p2wx - p1wx
  31.    dy = p2wy - p1wy
  32.    dz = p2wz - p1wz
  33.    magn = sqrt(dx*dx + dy*dy + dz*dz)
  34.    IF (magn <= accuracy)
  35.       GOTO error2
  36.    uwx = dx/magn
  37.    uwy = dy/magn
  38.    uwz = dz/magn
  39.  
  40. :ind_arc
  41. REM     *** get arc
  42. SET mask,3
  43.    GETENT  "Indicate arc or circle", etype
  44.    ON (@KEY + 3) GOTO exit,ind_ln,ind_arc,
  45.    cvx = @FLTDAT[0]
  46.    cvy = @FLTDAT[1]
  47.    cvz = @FLTDAT[2]
  48.    rad = @FLTDAT[3]
  49.    arcview = @INTDAT[8]
  50.  
  51. REM     *** save cursor pick
  52.    crvx = @XCURSOR
  53.    crvy = @YCURSOR
  54.  
  55. REM     *** define arc view 
  56.    GETVIEW arcview,avm
  57.  
  58. REM     *** store present construction view
  59.    CALL memcpy,vm,0,@CVIEWMAT,0,9
  60.  
  61. REM     *** map arc view z-axis to present view
  62.    CALL xfmwv,vm,avm[2],avm[5],avm[8],av,bv,cv
  63.    dv = -cvz
  64. REM     *** calculate intersection of cursor pick and plane of definition
  65. REM         of arc
  66.    crvz = -(av*crvx + bv*crvy + dv)/cv
  67.  
  68. REM     *** map cursor pick to arc view coord.
  69.    CALL xfmvw,vm,crvx,crvy,crvz,crwx,crwy,crwz
  70.    CALL xfmwv,avm,crwx,crwy,crwz,crvx,crvy,crvz
  71.  
  72. REM     *** map line to arc view coord.
  73.    CALL xfmwv,avm,p1wx,p1wy,p1wz,p1vx,p1vy,p1vz
  74.    CALL xfmwv,avm,p2wx,p2wy,p2wz,p2vx,p2vy,p2vz
  75.  
  76. REM     *** check if line and arc are coplanar
  77.    IF ((abs(p1vz-cvz) > accuracy) || (abs(p2vz-cvz) > accuracy))
  78.       GOTO error1
  79.  
  80. REM     *** define line unit vector, arc view coord.
  81.    dx = p2vx - p1vx
  82.    dy = p2vy - p1vy
  83.    dz = p2vz - p1vz
  84.    magn = sqrt(dx*dx + dy*dy + dz*dz)
  85.    uvx = dx/magn
  86.    uvy = dy/magn
  87.    uvz = dz/magn
  88.  
  89. REM     *** line coefficients, arc view coord
  90.    xc = uvy
  91.    yc = -uvx
  92.    ind = p1vy*uvx - p1vx*uvy
  93.  
  94. REM     *** projection from center of arc to line
  95.    val1 = (cvx - p1vx)*uvx + (cvy - p1vy)*uvy 
  96.  
  97. REM     *** projection from cursor pick to line
  98.    val2 = (crvx - p1vx)*uvx + (crvy - p1vy)*uvy 
  99.  
  100. REM     *** define solution direction
  101.    IF (val2 >= val1)
  102.       GOTO flag1
  103.    IF (val2 < val1)
  104.       GOTO flag2
  105.  
  106. :flag1  
  107.    val = val1 + rad
  108.    GOTO make_ln
  109.  
  110. :flag2  
  111.    val = val1 - rad
  112.    rad = -rad
  113.    GOTO make_ln
  114.  
  115. :make_ln
  116. REM     *** map arc center to world
  117.    CALL xfmvw,avm,cvx,cvy,cvz,cwx,cwy,cwz
  118.    s1wx = cwx + rad*uwx
  119.    s1wy = cwy + rad*uwy
  120.    s1wz = cwz + rad*uwz
  121.    s2wx = p1wx + val*uwx
  122.    s2wy = p1wy + val*uwy
  123.    s2wz = p1wz + val*uwz
  124.    LINE  s1wx,s1wy,s1wz,s2wx,s2wy,s2wz
  125.    GOTO ind_arc
  126.  
  127. :error1
  128.    PROMPT  " Base line and arc are not coplanar...Select again "
  129.    WAIT 2
  130.    GOTO ind_ln
  131.  
  132. :error2
  133.    PROMPT  " Zero length line... Select again."
  134.    WAIT 2
  135.    GOTO ind_ln
  136.  
  137. :exit
  138.    SET mask
  139.    EXIT
  140.