Bezier

Einige Funktionen um Kubische Bezier-Kurven. Eine Bezier-Kurve hat zwei Richtungs- und zwei Endpunkte. Sie wird repräsentiert durch eine Liste von acht Fließkommazahlen. Schnittpunkte werden repräsentiert durch eine Fließkommazahl zwischen 0 und 1.

Einrichtung

• Quelltext unten kopieren
• einfügen in eine leere Textdatei
• Textdatei speichern unter Dateinamen in oberster Textzeile, hier: Bezier-0.2.tm
• Textdatei einstellen in das lokale Verzeichnis für Module, beim Autor etwa: ~/bin/TM

Anwendung

package require Bezier

lädt das Paket, macht dieses Prozeduren verfügbar:

bezier bbox (Kurve)

übergibt Koordinaten des umgebenden Rechtecks

bezier tangens2 (Kurve1) (Kurve2)

ermittelt die gemeinsam verbindende Tangente zweier Kurven, übergibt die Berührpunkte der Kurven

bezier segment (Kurve) (Start) (Ende)

übergibt das Segment im Bereich Start, Ende

bezier cut (Kurve1) (Kurve2)

übergibt ein Schnittpunktpaar der Kurven

bezier cuts (Kurve1) (Kurve2)

übergibt alle Schnittpunktpaare der Kurven als unsortierte Liste

bezier help

gibt eine kurze Übersicht über verfügbare Prozeduren

Anmerkungen

• Die Bounding Box wird numerisch ermittelt durch erste Ableitung der kubischen Gleichung, folgt also der Schulmathematik und ist – anders als Näherung durch Intervallschachtelung – auf natürlichem Weg präzise.
• Die Neigung der verbindenden Tangente bei bezier tangens2 wird angenähert durch Intervallschachtelung.
• Die Schnittpunkte werden angenähert durch Intervallschachtelung.
• Die begrenzende Intervallgröße ist auf 1e-5 voreingestellt. Sie kann den Funktionen cut und cuts als optionaler dritter Parameter übergeben werden, etwa bezier cut (Kurve1) (Kurve2) 1e-6.
• Schnittpunkte genau auf Endpunkten werden veworfen.
• Als Schnittpunkt zählt nur echte Kreuzung, nicht tangentialer Berührpunkt.
• Einfache optische Überlegung zeigt, dass Kubische Bezier-Kurven zwischen null und neun Schnittpunkte haben können.
• Schnittpunktpaare können nach Bedarf sortiert werden. Eine bestimmte Sortierung vorzugeben ist wenig sinnvoll, weil die Kurven gegenläufig sein können.

---

# file: Bezier-0.2.tm

package provide Bezier 0.2

namespace eval bezier namespace import\
 ::tcl::mathfunc::*\
 ::tcl::mathop::*

proc bezier::Extrema {a b c d} {
  # taken a, b, c, d as x-coords of bezier dots,
  # return list of fractions where the appropriate function has extrema
  set factor2 [expr {3.0 * (-$a + (3.0 * $b) + (-3.0 * $c) + $d)}]
  set factor1 [expr {2.0 * ((3.0 * $a) + (-6.0 * $b) + (3.0 * $c))}]
  set factor0 [expr {(-3.0 * $a) + (3.0 * $b)}]
  if {$factor2 != 0} then {
    set p [expr { $factor1 / $factor2 / 2 }]
    set q [expr { $factor0 / $factor2 }]
    set p2q [expr { ($p * $p) - $q }]
    if {$p2q > 0} then {
      set sqrtp2q [expr {sqrt($p2q)}]
      list [expr { -$p - $sqrtp2q }] [expr { -$p + $sqrtp2q }] 
    } elseif {$p2q == 0} then {
      expr {-$p}
    }
  } elseif { $factor1 != 0 } then {
    expr { -$factor0 / $factor1 }
  }
}

proc bezier::bbox coords {
  lassign $coords ax ay bx by cx cy dx dy
  lappend allX $ax $dx
  lappend allY $ay $dy
  foreach frac [Extrema $ax $bx $cx $dx] {
    if {$frac > 0.0 && $frac < 1.0} then {
      foreach {x y} [At $coords $frac] {
        lappend allX $x
        lappend allY $y
      }
    }
  }
  foreach frac [Extrema $ay $by $cy $dy] {
    if {$frac > 0.0 && $frac < 1.0} then {
      foreach {x y} [At $coords $frac] {
        lappend allX $x
        lappend allY $y
      }
    }
  }
  list [min {*}$allX] [min {*}$allY] [max {*}$allX] [max {*}$allY]
}

proc bezier::Rotate {x y phi {cX 0.0} {cY 0.0}} {
  # coords x, y rotated by phi around cX, cY
  set c [cos $phi]
  set s [sin $phi]
  list\
    [expr {($x - $cX) * $c - ($y - $cY) * $s + $cX}]\
    [expr {($y - $cY) * $c + ($x - $cX) * $s + $cY}]
}

proc bezier::RotateCoords {coords phi {cX 200.0} {cY 150.0}} {
  concat {*}[lmap {x y} $coords {
      Rotate $x $y $phi $cX $cY
    }]
}

proc bezier::ScaleCoords {coords fx fy {cx 200} {cy 150}} {
  concat {*}[lmap {x y} $coords {
      list\
        [expr {($x - $cx) * $fx + $cx}]\
        [expr {($y - $cy) * $fy + $cy}]
    }]
}

# === updated ===

# outdated version returned rotated copies of beziers
# new version TangensAngle below returns just the angle

proc bezier::AngleOfTwoCurves {curve1 curve2 {side top}} {
  # angle of bounding boxes on top, bottom, or alternating
  switch -exact -- $side {
    top {
      lassign [bbox $curve1] x0  y0  -  -
      lassign [bbox $curve2]  -  y1  x1 -
    }
    bottom {
      lassign [bbox $curve1] x0   -   -  y0
      lassign [bbox $curve2]  -   -  x1  y1
    }
    topBottom {
      lassign [bbox $curve1] x0  y0  -  -
      lassign [bbox $curve2]  -   -  x1  y1
    }
    bottomTop {
      lassign [bbox $curve1] x0   -   -  y0
      lassign [bbox $curve2]  -  y1  x1 -
    }
  }
  atan2 [- $y1 $y0] [- $x1 $x0]
}

proc bezier::CurveCenter coords {
  # center of bounding box
  lassign [bbox $coords] x0 y0 x1 y1
  list [/ [+ $x0 $x1] 2.0] [/ [+ $y0 $y1] 2.0]
}

proc bezier::CurveIsArc curve {
  # return true if bent like Arc
  # return false if bent like Bowl
  lassign $curve x0 y0 - - - - x1 y1
  if {$x0 > $x1} then {
    lassign "$x0 $y0 $x1 $y1" x1 y1 x0 y0
  }
  set phi [atan2 [- $y1 $y0] [- $x1 $x0]]
  set c1 [RotateCoords $curve [- $phi]]
  lassign $c1 - y2 - y3
  expr {
    $y3 < $y2 ? yes : no
  }
}

proc bezier::TangensAngle {curve1 curve2 {how auto}} {
  # return angle of common tangential line
  #
  # calc left/right
  #
  lassign [CurveCenter $curve1] x0 y0
  lassign [CurveCenter $curve2] x1 y1
  set phi [atan2 [- $y1 $y0] [- $x1 $x0]]
  if {$phi < 0} then {
    lassign [list $curve1 $curve2] c2 c1
  } else {
    lassign [list $curve1 $curve2] c1 c2
  }
  #
  # adjust horizontally
  #
  lassign [CurveCenter $c1] x0 y0
  lassign [CurveCenter $c2] x1 y1
  set phi [atan2 [- $y1 $y0] [- $x1 $x0]]
  set c1 [RotateCoords $c1 [- $phi]]
  set c2 [RotateCoords $c2 [- $phi]]
  set result [- $phi]
  #
  # check if bowl or arc
  #
  if {$how ne "auto"} then {
    set side $how
  } else {
    if {[CurveIsArc $c1]} then {
      # $c1 yes
      if {[CurveIsArc $c2]} then {
        # $c1 yes, $c2 yes
        set side top
      } else {
        # $c1 yes, $c2 no
        set side topBottom
      }
    } else {
      # $c1 no
      if {[CurveIsArc $c2]} then {
        # $c1 no, $c2 yes
        set side bottomTop
      } else {
        # $c1 no, $c2 no
        set side bottom
      }
    }
  }
  for {set i 0} {$i < 10} {incr i} {
    set phi [AngleOfTwoCurves $c1 $c2 $side]
    set result [- $result $phi]
    set c1 [RotateCoords $c1 [- $phi]]
    set c2 [RotateCoords $c2 [- $phi]]
    if {abs($phi) < 0.0001} break
  }
  set result
}

# === 

proc bezier::tangens2 {left right} {
  # return fractions of beziers left, right
  # where common tangens touches
  set phi [TangensAngle $left $right]
  set left [RotateCoords $left $phi]
  set right [RotateCoords $right $phi]
  # extrema for $left
  lassign $left - y0 - y1 - y2 - y3
  set fracsLeft {}
  foreach frac [Extrema $y0 $y1 $y2 $y3] {
    if {$frac <= 1 && $frac >= 0} then {
      lappend fracsLeft $frac
    }
  }
  # extrema for $right
  lassign $right - y0 - y1 - y2 - y3
  set fracsRight {}
  foreach frac [Extrema $y0 $y1 $y2 $y3] {
    if {$frac <= 1 && $frac >= 0} then {
      lappend fracsRight $frac
    }
  }
  if {[llength $fracsLeft] == 1 && [llength $fracsRight] == 1} then {
    concat $fracsLeft $fracsRight
  }
}

proc bezier::Part {coords frac} {
  lassign $coords ax ay bx by cx cy dx dy
  #
  set abx [expr {$ax + ($bx - $ax) * $frac}]
  set bcx [expr {$bx + ($cx - $bx) * $frac}]
  set cdx [expr {$cx + ($dx - $cx) * $frac}]
  set abcx [expr {$abx + ($bcx - $abx) * $frac}]
  set bcdx [expr {$bcx + ($cdx - $bcx) * $frac}]
  set abcdx [expr {$abcx + ($bcdx - $abcx) * $frac}]
  #
  set aby [expr {$ay + ($by - $ay) * $frac}]
  set bcy [expr {$by + ($cy - $by) * $frac}]
  set cdy [expr {$cy + ($dy - $cy) * $frac}]
  set abcy [expr {$aby + ($bcy - $aby) * $frac}]
  set bcdy [expr {$bcy + ($cdy - $bcy) * $frac}]
  set abcdy [expr {$abcy + ($bcdy - $abcy) * $frac}]
  #
  list $ax $ay $abx $aby $abcx $abcy $abcdx $abcdy
}

proc bezier::segment {coords from to} {
  set frac0 $to
  set coords1 [Part $coords $frac0]
  set frac1 [expr {($to - $from) / $to}]
  lreverse [Part [lreverse $coords1] $frac1]
}

proc bezier::At {coords frac} {
  lrange [Part $coords $frac] end-1 end
}

proc bezier::Det2val det {
    # return numeric value of 2x2 determinante $det
    lassign $det l1 l2
    lassign $l1 a1 a2
    lassign $l2 b1 b2
    # - [* $a1 $b2] [* $a2 $b1]
    expr {double($a1 * $b2 - $a2 * $b1)}
}

proc bezier::lineCutLine {l0 l1 args} {
  # return list of fracs where lines $l0, $l1 cross each other
  # ---
  # 2 lines l0=P-Q, l1R-S
  # P  + u( Q - P ) = R  + v( S - R )
  # ---
  # px + u(qx - px) = rx + v(sx - rx)
  # py + u(qy - py) = ry + v(sy - ry)
  # ---
  # solve equation by u, v
  lassign $l0 px py qx qy
  lassign $l1 rx ry sx sy
  set x1 [expr {$qx - $px}]
  set x2 [expr {$rx - $sx}]
  set xr [expr {$rx - $px}]
  set y1 [expr {$qy - $py}]
  set y2 [expr {$ry - $sy}]
  set yr [expr {$ry - $py}]
  set det [list [list $x1 $x2] [list $y1 $y2]]
  set divisor [Det2val $det]
  if {$divisor != 0} then {
    set uDet [list [list $xr $x2] [list $yr $y2]]
    set uDetVal [Det2val $uDet]
    set u [expr {$uDetVal / $divisor}]
    set vDet [list [list $x1 $xr] [list $y1 $yr]]
    set vDetVal [Det2val $vDet]
    set v [expr {$vDetVal / $divisor}]
    if {0 < $u && $u < 1 && 0 < $v && $v < 1} then {
      list $u $v
    }
  }
}

proc bezier::Cross1 {bez1 bez2 {limit 1e-5}} {
  lassign $bez1 ax0 ay0 ax1 ay1 ax2 ay2 ax3 ay3
  lassign $bez2 bx0 by0 bx1 by1 bx2 by2 bx3 by3
  set ax "$ax0 $ax1 $ax2 $ax3"
  set ay "$ay0 $ay1 $ay2 $ay3"
  set bx "$bx0 $bx1 $bx2 $bx3"
  set by "$by0 $by1 $by2 $by3"
  if {
    [min {*}$ax] < [max {*}$bx] &&
    [min {*}$ay] < [max {*}$by] &&
    [max {*}$ax] > [min {*}$bx] &&
    [max {*}$ay] > [min {*}$by]
  } then {
    set width [- [max {*}$ax {*}$bx] [min {*}$ax {*}$bx]]
    set height [- [max {*}$ay {*}$by] [min {*}$ay {*}$by]]
    if {max($width, $height) < $limit} then {
      # only true crossing, no touching!
      lineCutLine [lreplace $bez1 2 end-2] [lreplace $bez2 2 end-2]
    } else {
      set bez1a [segment $bez1 0 0.5]
      set bez2a [segment $bez2 0 0.5]
      set bez1b [segment $bez1 0.5 1]
      set bez2b [segment $bez2 0.5 1]
      lassign [Cross1 $bez1a $bez2a $limit] frac1 frac2
      if {$frac1 ne ""} then {
        list [expr {$frac1 / 2.0}] [expr {$frac2 / 2.0}]
      } else {
        lassign [Cross1 $bez1a $bez2b $limit] frac1 frac2
        if {$frac1 ne ""} then {
          list [expr {$frac1 / 2.0}] [expr {$frac2 / 2.0 + 0.5}]
        } else {
          lassign [Cross1 $bez1b $bez2a $limit] frac1 frac2
          if {$frac1 ne ""} then {
            list [expr {$frac1 / 2.0 + 0.5}] [expr {$frac2 / 2.0}]
          } else {
            lassign [Cross1 $bez1b $bez2b $limit] frac1 frac2
            if {$frac1 ne ""} then {
              list [expr {$frac1 / 2.0 + 0.5}] [expr {$frac2 / 2.0 + 0.5}]
            }
          }
        }
      }
    }
  }
}

proc bezier::Nearby {x0 y0 x1 y1 {limit 1e-5}} {
  expr {
    abs($x1 - $x0) <= $limit && abs($y1 - $y0) <= $limit
  }
}

proc bezier::BezierPosNearby {coords pos1 pos2 {limit 1e-5}} {
  Nearby {*}[At $coords $pos1] {*}[At $coords $pos2] $limit
}

proc bezier::CoordsReverse coords {
  concat {*}[lreverse [lmap {x y} $coords {list $x $y}]]
}

proc bezier::cut {bez1 bez2 {limit 1e-5} {tolerant no}} {
  if {
    !$tolerant &&
    ( [Nearby {*}[At $bez1 0.0] {*}[At $bez2 0.0] $limit] ||
      [Nearby {*}[At $bez1 1.0] {*}[At $bez2 1.0] $limit] )
  } then {
    lassign [cut [CoordsReverse $bez1] $bez2 $limit yes] frac1 frac2
    if {$frac2 ne {}} then {
      list [expr {1.0 - $frac1}] $frac2
    }
  } else {
    lassign [Cross1 $bez1 $bez2 $limit] frac1 frac2
    if {$frac2 ne {}} then {
      if {[BezierPosNearby $bez1 $frac1 0]} then {
        set frac1 0.0
      } elseif {[BezierPosNearby $bez1 $frac1 1.0]} then {
        set frac1 1.0
      }
      if {[BezierPosNearby $bez2 $frac2 0]} then {
        set frac2 0.0
      } elseif {[BezierPosNearby $bez2 $frac2 1.0]} then {
        set frac2 1.0
      }
      if {(0 < $frac1 && $frac1 < 1) || (0 < $frac2 && $frac2 < 1)} then {
        list $frac1 $frac2
      }
    }
  }
}

proc bezier::cuts {bez1 bez2 {limit 1e-5}} {
  lassign [cut $bez1 $bez2 $limit] frac1 frac2
  if {$frac2 ne {}} then {
    lappend result $frac1 $frac2
    #
    set seg1a [segment $bez1 0 $frac1]
    set seg2a [segment $bez2 0 $frac2]
    set seg1b [segment $bez1 $frac1 1.0]
    set seg2b [segment $bez2 $frac2 1.0]
    #
    foreach {f1 f2} [cuts $seg1a $seg2a $limit] {
      lappend result\
        [expr {$f1 * $frac1}]\
        [expr {$f2 * $frac2}]
    }
    foreach {f1 f2} [cuts $seg1a $seg2b $limit] {
      lappend result\
        [expr {$f1 * $frac1}]\
        [expr {$frac2 + $f2 * (1-$frac2)}]
    }
    foreach {f1 f2} [cuts $seg1b $seg2a $limit] {
      lappend result\
        [expr {$frac1 + $f1 * (1-$frac1)}]\
        [expr {$f2 * $frac2}]
    }
    foreach {f1 f2} [cuts $seg1b $seg2b $limit] {
      lappend result\
        [expr {$frac1 + $f1 * (1-$frac1)}]\
        [expr {$frac2 + $f2 * (1-$frac2)}]
    }
    set result
  }
}

proc bezier::help {} {
  foreach proc [namespace export] {
    set line "[namespace tail [namespace current]] $proc"
    foreach arg [info args $proc] {
      if {[info default $proc $arg def]} then {
        lappend line [list $arg $def]
      } else {
        lappend line $arg
      }
    }
    lappend result $line
  }
  join $result \n
}

namespace eval bezier {
  namespace export bbox tangens2 segment cut cuts help lineCutLine
  namespace ensemble create
}

29.3.2022

<< | Heimatseite | Verzeichnis | Stichworte | Autor | >>