Bezier

Package Bezier provides calculation of crossings fraction of bezier curves.
bezier bbox (bezier): returns bounding box
bezier tangens2 (bezier1) (bezier2): returns fractions where common tangens touches
bezier segment (bezier) (from) {to}: returns partial bezier
bezier cut (bezier1) (bezier2}: returns fractions where beziers are crossing
bezier cuts (bezier1) (bezier2}: returns pairwise all crossings. Unsorted.
bezier help: returns overview of syntax
# file: Bezier-0.1.tm

package provide Bezier 0.1

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}]
    }]
}

proc bezier::TypeOf curve {
  lassign $curve x0 y0 - - - - x1 y1
  set phi [atan2 [- $y1 $y0] [- $x1 $x0]]
  set curve [RotateCoords $curve [- $phi]]
  lassign $curve ax ay bx by cx cy dx dy 
  if {$by + $cy - 2 * $ay < 0} then {
    return arc
  } else {
    return bowl
  }
}

proc bezier::CurrentAngle {left right} {
  # calc angle of upper left corners ob bboxes
  set bbox1 [bbox $left]
  set bbox2 [bbox $right]
  if {[TypeOf $left] eq "arc"} then {
    # n-formed like an arc
    lassign $bbox1 x0 y0
    lassign $bbox2 x1 y1
  } else {
    # u-formed like a bowl
    lassign $bbox1 x0 - - y0
    lassign $bbox2 x1 - - y1
  }
  atan2 [- $y1 $y0] [- $x1 $x0]
}

proc bezier::AdjustedCoords {left right {rounds 100}} {
  for {set i 0} {$i < $rounds} {incr i} {
    set phi [CurrentAngle $left $right]
    set left [RotateCoords $left [- $phi]]
    set right [RotateCoords $right [- $phi]]
    if {abs($phi) < 1e-16} break
  }
  list $left $right
}

proc bezier::UppermostFraction coords {
  lassign $coords x0 y0 x1 y1 x2 y2 x3 y3
  set xExtr [Extrema $x0 $x1 $x2 $x3]
  set yExtr [Extrema $y0 $y1 $y2 $y3]
  set elements {}
  foreach f [concat $xExtr $yExtr] {
    if {$f >= 0 && $f <= 1} then {
      lassign [At $coords $f] x y
      lappend elements [list $f $x $y]
    }
  }
  if {[TypeOf $coords] eq "arc"} then {
    lindex [lsort -real -index end $elements] 0 0
  } else {
    lindex [lsort -real -index end $elements] end 0
  }
}

proc bezier::tangens2 {left right} {
  lassign $left x0 y0 - - - - x1 y1
  set phi [atan2 [- $y1 $y0] [- $x1 $x0]]
  set left [RotateCoords $left [- $phi]]
  set right [RotateCoords $right [- $phi]]
  #
  if {[TypeOf $left] ne "arc"} then {
    set left [ScaleCoords $left 1 -1]
    set right [ScaleCoords $right 1 -1]
  }
  if {[lindex [bbox $left] 0] > [lindex [bbox $right] 0]} then {
    set reverse yes
    lassign [list $left $right] right left
  } else {
    set reverse no
  }
  set result [lmap coords [AdjustedCoords $left $right] {
      UppermostFraction $coords
    }]
  if {$reverse} then {
    lreverse $result
  } else {
    set result
  }
}

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
}
Einleitung
Bedienkonzept
Tastenkürzel
Menü
Tutorial
Software
- General
- Packages
  - Obj
  - XML
  - Bezier
- Dot
- Line
- Fill
- Group
- Canvaseditor
- GlassCube
- Main
- Constraints
Hinweise
Galerie
Notizen