#!/bnr/bootleg/bin/tcl/wishx -f

#set gvar(pts)  {30 20 30 10 20 0 10 0 0 10 0 20 10 30 20 30 30 40 30 50 20 60 10 60 0 50 0 40}

proc _dump {c} {
   global gvar
   set t1 [$c coords orig]
   puts stdout ".c.c create line $t1 -tags obj orig"
   set t1 [$c coords morph]
   puts stdout ".c.c create line $t1 -tags obj morph"  
}

proc _initcurve {c tag} {
   global gvar
   $c delete all
   set gvar(pts) {80 120 80 140 100 140 100 120}
   eval ".c create line $gvar(pts) -tags orig"
   set gvar(ccp) 0
   $c scale $tag 0 0 3 3
   set gvar(pts) [$c coords $tag]
   foreach i {0 1 2 3} {
      set gvar(p${i}x) [lindex $gvar(pts) [expr $i*2]]
      set gvar(p${i}y) [lindex $gvar(pts) [expr $i*2+1]]
      eval "$c create bitmap $gvar(p${i}x) $gvar(p${i}y) -bitmap @bar_icon -tags \"cp$i\""
   }
   $c itemconfig cp$gvar(ccp) -background black
   _docurve $c $gvar(p$gvar(ccp)x) $gvar(p$gvar(ccp)y)
}

proc _docurve {c xc yc} {
   global gvar
   set gvar(p$gvar(ccp)x) $xc
   set gvar(p$gvar(ccp)y) $yc
   set gvar(cx) $gvar(p0x)
   set gvar(cy) $gvar(p0y)
   set xb       $gvar(p1x)
   set yb       $gvar(p1y)
   set xc       $gvar(p2x)
   set yc       $gvar(p2y)
   set xd       $gvar(p3x)
   set yd       $gvar(p3y)
   $c delete orig
   eval "$c create line $gvar(cx) $gvar(cy) $xb $yb $xc $yc $xd $yd -tags orig"
   set gvar(bpts) ""
   $c coords cp$gvar(ccp) $gvar(p$gvar(ccp)x) $gvar(p$gvar(ccp)y)
   set np 10
   $c delete morph
   _drawcurve1 $c $np
   for {set i 0} {$i < $np} {incr i} {
      set x [lindex $gvar(bpts) [expr $i*2]]
      set y [lindex $gvar(bpts) [expr $i*2+1]]
      eval "$c create bitmap $x $y -bitmap @xhair_icon -tags morph"
   }
}

proc _drawcurve1 {c n} {
   global gvar
   set du [expr 1.0/($n-1)]
   set u 0.0
   for {set i 0} {$i < $n} {incr i} {
      set up  [expr 1.0-$u]
      set b2  [expr $u*$u]
      set u2  [expr 3.0*$b2]
      set dx  [expr $gvar(p3x)*$u2+3.0*$gvar(p2x)*(2.0*$u-$u2)+3.0*$gvar(p1x)*(1.0-4.0*$u+$u2)-$gvar(p0x)*3.0*$up*$up]
      set dy  [expr $gvar(p3y)*$u2+3.0*$gvar(p2y)*(2.0*$u-$u2)+3.0*$gvar(p1y)*(1.0-4.0*$u+$u2)-$gvar(p0y)*3.0*$up*$up]
      set b3  [expr $b2*$u]
      set b2  [expr 3.0*$b2*$up]
      set up2 [expr $up*$up]
      set b1  [expr 3.0*$u*$up2]
      set b0  [expr $up2*$up]
      set x   [expr $gvar(p3x)*$b3+$gvar(p2x)*$b2+$gvar(p1x)*$b1+$gvar(p0x)*$b0]
      set y   [expr $gvar(p3y)*$b3+$gvar(p2y)*$b2+$gvar(p1y)*$b1+$gvar(p0y)*$b0]
      append gvar(bpts) "$x $y "
      set u   [expr $u+$du]
      set a   [atan {-1.0*$dx/$dy}]
      eval "$c create line $x $y [expr $x+20*[cos $a]] [expr $y+20*[sin $a]] -tags morph"
   }
}

proc _drawcurve2 {c xb yb xc yc xd yd n} {
   global gvar
   if {$n==0} {
      append gvar(bpts) "$gvar(cx) $gvar(cy) $xb $yb $xc $yc $xd $yd "
      set gvar(cx) $xd
      set gvar(cy) $yd
   } else {
      set xab [expr ($gvar(cx)+$xb)/2.0]
      set yab [expr ($gvar(cy)+$yb)/2.0]
      set xbc [expr ($xb+$xc)/2.0]
      set ybc [expr ($yb+$yc)/2.0]
      set xcd [expr ($xc+$xd)/2.0]
      set ycd [expr ($yc+$yd)/2.0]
      set xabc [expr ($xab+$xbc)/2.0]
      set yabc [expr ($yab+$ybc)/2.0]
      set xbcd [expr ($xbc+$xcd)/2.0]
      set ybcd [expr ($ybc+$ycd)/2.0]
      set xabcd [expr ($xabc+$xbcd)/2.0]
      set yabcd [expr ($yabc+$ybcd)/2.0]
      _drawcurve $c $xab $yab $xabc $yabc $xabcd $yabcd [expr $n-1]
      _drawcurve $c $xbcd $ybcd $xcd $ycd $xd $yd [expr $n-1]
   }
}

proc _max {a b} {
   if {$a>$b} {
      return $a
   } else {
      return $b
   }
}

proc _drawcurve3 {c np} {
   global gvar
   set d1x [expr $gvar(p1x)-$gvar(p0x)]
   set d2x [expr $gvar(p2x)-$gvar(p1x)-$d1x]
   set d3x [expr $gvar(p3x)-2.0*$gvar(p2x)+$gvar(p1x)-$d2x]
   set d1y [expr $gvar(p1y)-$gvar(p0y)]
   set d2y [expr $gvar(p2y)-$gvar(p1y)-$d1y]
   set d3y [expr $gvar(p3y)-2.0*$gvar(p2y)+$gvar(p1y)-$d2y]
   set np 10
#  set h2 [expr 1.0/($np*$np)]
#  set t1 [_max [expr $d2x*$gvar(p0x)] [expr $d2x*$gvar(p1x)]]
#  while {[expr 0.75*$h2*$t1]<1.0} {
#     set d3x [expr $d3x/8.0]
#     set d2x [expr $d2x/4.0-$d3x]
#     set d1x [expr ($d1x-$d2x)/2.0]
#     set t1 [_max [expr $d2x*$gvar(p0x)] [expr $d2x*$gvar(p1x)]]
#  }
#  set t1 [_max [expr $d2y*$gvar(p0y)] [expr $d2y*$gvar(p1y)]]
#  while {[expr 0.75*$h2*$t1]<1.0} {
#     set d3y [expr $d3y/8.0]
#     set d2y [expr $d2y/4.0-$d3y]
#     set d1y [expr ($d1y-$d2y)/2.0]
#     set t1 [_max [expr $d2y*$gvar(p0y)] [expr $d2y*$gvar(p1y)]]
#  }
   puts stdout "$d1x $d2x $d3x"
   set x $gvar(p0x)
   set y $gvar(p0y)
   for {set i 0} {$i < $np} {incr i} {
      set x   [expr $x+$d1x]
      set d1x [expr $d1x+$d2x]
      set d2x [expr $d2x+$d3x]
      set y   [expr $y+$d1y]
      set d1y [expr $d1y+$d2y]
      set d2y [expr $d2y+$d3y]
      append gvar(bpts) "$x $y "
   }
}

proc _init1d {c tag} {
   global gvar
   $c delete all
   set gvar(pts) {40 260 40 240 60 240 60 260 80 260 100 260 100 240 80 240 80 220 100 220 100 200 80 200 60 200 60 220 40 220 40 200 40 180 60 180 60 160 40 160 40 140 40 120 60 120 60 140 80 140 80 120 100 120 100 140 100 160 80 160 80 180 100 180 120 180 140 180 140 160 120 160 120 140 120 120 140 120 140 140 160 140 160 120 180 120 180 140 180 160 160 160 160 180 180 180 180 200 180 220 160 220 160 200 140 200 120 200 120 220 140 220 140 240 120 240 120 260 140 260 160 260 160 240 180 240 180 260}
   eval ".c create line $gvar(pts) -tags orig"
   set gvar(ccp) 2
   $c scale $tag 0 0 1 1
   set gvar(pts) [$c coords $tag]
   scan [$c bbox $tag] "%d %d %d %d" gvar(xmin) gvar(ymin) gvar(xmax) gvar(ymax)

   set gvar(p1x) $gvar(xmin)
   set gvar(p1y) $gvar(ymin)
   set gvar(p2x) [expr {($gvar(xmin)+$gvar(xmax))/2.0}]
   set gvar(p2y) [expr {($gvar(ymin)+$gvar(ymax))/2.0}]
   set gvar(p3x) $gvar(xmax)
   set gvar(p3y) $gvar(ymax)

   set gvar(pl) [llength $gvar(pts)]
   set gvar(xl) [expr {$gvar(xmax)-$gvar(xmin)}].0
   set gvar(yl) [expr {$gvar(ymax)-$gvar(ymin)}].0

   foreach i {1 2 3} {
#     puts stdout "$gvar(p${i}x) $gvar(p${i}y)"
      $c delete cp$i
      eval "$c create bitmap $gvar(p${i}x) $gvar(p${i}y) -bitmap @bar_icon -tags \"cp$i\""
   }
   $c itemconfig cp$gvar(ccp) -background black
   _do1d $c $gvar(p$gvar(ccp)x) $gvar(p$gvar(ccp)y)
}

proc _init2d {c tag} {
   global gvar
   $c delete all
   set gvar(pts) {40 260 40 240 60 240 60 260 80 260 100 260 100 240 80 240 80 220 100 220 100 200 80 200 60 200 60 220 40 220 40 200 40 180 60 180 60 160 40 160 40 140 40 120 60 120 60 140 80 140 80 120 100 120 100 140 100 160 80 160 80 180 100 180 120 180 140 180 140 160 120 160 120 140 120 120 140 120 140 140 160 140 160 120 180 120 180 140 180 160 160 160 160 180 180 180 180 200 180 220 160 220 160 200 140 200 120 200 120 220 140 220 140 240 120 240 120 260 140 260 160 260 160 240 180 240 180 260}
#  set gvar(pts)  {30 20 30 10 20 0 10 0 0 10 0 20 10 30 20 30 30 40 30 50 20 60 10 60 0 50 0 40}
   eval ".c create line $gvar(pts) -tags orig"
   set gvar(ccp) 1
   $c scale $tag 0 0 1 1
   set gvar(pts) [$c coords $tag]
   scan [$c bbox $tag] "%d %d %d %d" gvar(xmin) gvar(ymin) gvar(xmax) gvar(ymax)

   set gvar(p1x) [expr {($gvar(xmin)+$gvar(xmax))/2.0}]
   set gvar(p1y) [expr {($gvar(ymin)+$gvar(ymax))/2.0}]
   set gvar(p2x) $gvar(xmin)
   set gvar(p2y) $gvar(ymax)
   set gvar(p3x) $gvar(xmax)
   set gvar(p3y) $gvar(ymax)

   set gvar(pl) [llength $gvar(pts)]

   foreach i {1 2 3} {
#     puts stdout "$gvar(p${i}x) $gvar(p${i}y)"
      $c delete cp$i
      eval "$c create bitmap $gvar(p${i}x) $gvar(p${i}y) -bitmap @bar_icon -tags \"cp$i\""
   }
   $c itemconfig cp$gvar(ccp) -background black
   _do2d $c $gvar(p$gvar(ccp)x) $gvar(p$gvar(ccp)y)
}

proc _init3d {c tag} {
   global gvar
   $c delete all
   set gvar(pts) {40 260 40 240 60 240 60 260 80 260 100 260 100 240 80 240 80 220 100 220 100 200 80 200 60 200 60 220 40 220 40 200 40 180 60 180 60 160 40 160 40 140 40 120 60 120 60 140 80 140 80 120 100 120 100 140 100 160 80 160 80 180 100 180 120 180 140 180 140 160 120 160 120 140 120 120 140 120 140 140 160 140 160 120 180 120 180 140 180 160 160 160 160 180 180 180 180 200 180 220 160 220 160 200 140 200 120 200 120 220 140 220 140 240 120 240 120 260 140 260 160 260 160 240 180 240 180 260}
   set gvar(ccp) 5
   eval ".c create line $gvar(pts) -tags orig"
   $c scale $tag 0 0 1 1
   set gvar(pts) [$c coords $tag]
   scan [$c bbox $tag] "%d %d %d %d" gvar(xmin) gvar(ymin) gvar(xmax) gvar(ymax)

   set gvar(p1x) $gvar(xmin)
   set gvar(p1y) $gvar(ymin)
   set gvar(p2x) [expr {($gvar(xmin)+$gvar(xmax))/2.0}]
   set gvar(p2y) $gvar(ymin)
   set gvar(p3x) $gvar(xmax)
   set gvar(p3y) $gvar(ymin)

   set gvar(p4x) $gvar(xmin)
   set gvar(p4y) [expr {($gvar(ymin)+$gvar(ymax))/2.0}]
   set gvar(p5x) $gvar(p2x)
   set gvar(p5y) $gvar(p4y)
   set gvar(p6x) $gvar(xmax)
   set gvar(p6y) $gvar(p4y)

   set gvar(p7x) $gvar(xmin)
   set gvar(p7y) $gvar(ymax)
   set gvar(p8x) $gvar(p2x)
   set gvar(p8y) $gvar(ymax)
   set gvar(p9x) $gvar(xmax) 
   set gvar(p9y) $gvar(ymax)

   set gvar(pl) [llength $gvar(pts)]
   set gvar(xl) [expr {$gvar(xmax)-$gvar(xmin)}].0
   set gvar(yl) [expr {$gvar(ymax)-$gvar(ymin)}].0

   foreach i {1 2 3 4 5 6 7 8 9} {
#     puts stdout "$gvar(p${i}x) $gvar(p${i}y)"
      $c delete cp$i
      eval "$c create bitmap $gvar(p${i}x) $gvar(p${i}y) -bitmap @bar_icon -tags \"cp$i\""
   }
   $c itemconfig cp$gvar(ccp) -background black
   _do3d $c $gvar(p$gvar(ccp)x) $gvar(p$gvar(ccp)y)
}

proc _do1d {c xc yc} {
   global gvar
   set gvar(p$gvar(ccp)x) $xc
   set gvar(p$gvar(ccp)y) $yc
   $c delete morph
   set npts ""
   for {set i 0} {$i < $gvar(pl)} {incr i 2} {
      set x  [lindex $gvar(pts) $i]
      set tx [expr ($x-$gvar(xmin))/$gvar(xl)]
      set t1 [expr 1.0-$tx]
      set x1 [expr ($gvar(p1x)*$t1*$t1+$gvar(p2x)*$t1*2.0*$tx+$gvar(p3x)*$tx*$tx)]
      set y  [lindex $gvar(pts) [expr $i+1]]
      set ty [expr ($y-$gvar(ymin))/$gvar(yl)]
      set t1 [expr 1.0-$ty]
      set y1 [expr ($gvar(p1y)*$t1*$t1+$gvar(p2y)*$t1*2.0*$ty+$gvar(p3y)*$ty*$ty)]
#     puts stdout "($x,$y) ($x1,$y1)"
      append npts "$x1 $y1 "
   }
   eval "$c create line $npts -tags morph -width 2"
   $c coords cp$gvar(ccp) $gvar(p$gvar(ccp)x) $gvar(p$gvar(ccp)y)
}

proc _do2d {c xc yc} {
   global gvar
   puts stdout "$gvar(pl)"
#  set gvar(p$gvar(ccp)x) $xc
#  set gvar(p$gvar(ccp)y) $yc
   $c delete morph
   set npts ""
   set k 1.0
   set cr [expr (1.0*$gvar(p1x)*$gvar(p1x)+$gvar(p1y)*$gvar(p1y))]
   for {set i 0} {$i < $gvar(pl)} {incr i 2} {
      set x  [lindex $gvar(pts) $i]
      set y  [lindex $gvar(pts) [expr $i+1]]
#     set ax [expr ($gvar(p2x)-$gvar(p1x))/$k]
#     set bx [expr ($gvar(p3x)-$gvar(p1x))/$k]
#     set cx [expr ($gvar(p1x)*($x+$y+$k)-$x*$gvar(p2x)-$y*$gvar(p3x))/$k]
#     set ay [expr ($gvar(p2y)-$gvar(p1y))/$k]
#     set by [expr ($gvar(p3y)-$gvar(p1y))/$k]
#     set cy [expr ($gvar(p1y)*($x+$y+$k)-$x*$gvar(p2y)-$y*$gvar(p3y))/$k]
#     set x1 [expr $ax*$x+$bx*$y+$cx]
#     set y1 [expr $ay*$x+$by*$y+$cy]
      set h  [sqrt ($x*$x+$y*$y)]
      set y1 [expr $h/$cr]
      set x1 [expr [acos ($x/$h)]/6.2831853]
      if {$y<0} { set x1 [expr 1-$x1] }
      set x1 [expr $x1*$x]
      set y1 [expr $y1*$y]
      puts stdout "($x,$y) ($x1,$y1)"
      append npts "$x1 $y1 "
   }
   eval "$c create line $npts -tags morph -width 2"
   $c coords cp$gvar(ccp) $gvar(p$gvar(ccp)x) $gvar(p$gvar(ccp)y)
}

proc _do3d {c xc yc} {
   global gvar
   set gvar(p$gvar(ccp)x) $xc
   set gvar(p$gvar(ccp)y) $yc
   $c delete morph
   set npts ""
   for {set i 0} {$i < $gvar(pl)} {incr i 2} {
      set x  [lindex $gvar(pts) $i]
      set y  [lindex $gvar(pts) [expr $i+1]]
      set u  [expr ($x-$gvar(xmin))/$gvar(xl)]
      set v  [expr ($y-$gvar(ymin))/$gvar(yl)]
      set u1 [expr 1.0-$u]
      set v1 [expr 1.0-$v]
      set a1 [expr $u1*$u1]
      set b1 [expr 2.0*$u*$u1]
      set c1 [expr $u*$u]
      set a3 [expr $v1*$v1]
      set b3 [expr 2.0*$v*$v1]
      set c3 [expr $v*$v]
      set a2 [expr $gvar(p1x)*$a3+$gvar(p4x)*$b3+$gvar(p7x)*$c3]
      set b2 [expr $gvar(p2x)*$a3+$gvar(p5x)*$b3+$gvar(p8x)*$c3]
      set c2 [expr $gvar(p3x)*$a3+$gvar(p6x)*$b3+$gvar(p9x)*$c3]
      set x1 [expr $a2*$a1+$b2*$b1+$c2*$c1]
      set a2 [expr $gvar(p1y)*$a3+$gvar(p4y)*$b3+$gvar(p7y)*$c3]
      set b2 [expr $gvar(p2y)*$a3+$gvar(p5y)*$b3+$gvar(p8y)*$c3]
      set c2 [expr $gvar(p3y)*$a3+$gvar(p6y)*$b3+$gvar(p9y)*$c3]
      set y1 [expr $a2*$a1+$b2*$b1+$c2*$c1]
#     puts stdout "($x,$y) ($x1,$y1)"
      append npts "$x1 $y1 "
   }
   eval "$c create line $npts -tags morph -width 2"
   $c coords cp$gvar(ccp) $gvar(p$gvar(ccp)x) $gvar(p$gvar(ccp)y)
}

proc _setcp {c value} {
   global gvar
   $c itemconfig cp$gvar(ccp) -background white
   set gvar(ccp) $value
   $c itemconfig cp$gvar(ccp) -background black
}

set gvar(cmd) 1d

wm minsize . 50 50
canvas .c -width 700 -height 700 -scrollregion "-100 -100 600 600"
_init$gvar(cmd) .c orig
frame .m
   radiobutton .m.b1 -text "Morph1D" -variable gvar(cmd) -value 1d \
      -command " _init1d .c orig "
   radiobutton .m.b2 -text "Morph2D" -variable gvar(cmd) -value 2d \
      -command " _init2d .c orig "
   radiobutton .m.b3 -text "Morph3D" -variable gvar(cmd) -value 3d \
      -command " _init3d .c orig "
   radiobutton .m.b4 -text "Curve"   -variable gvar(cmd) -value curve \
      -command " _initcurve .c orig "
pack append .m .m.b1 left \
               .m.b2 left \
               .m.b3 left \
               .m.b4 left
frame .com
   button .com.b1 -text "Clear" -command { _init$gvar(cmd) .c orig }
   button .com.b2 -text "Dump"  -command "_dump .c"
   button .com.b3 -text "Quit"  -command "destroy ."
   scale .com.s -label "Control pts" -w 20 -len 100 -from 0 -to 9 -orient horiz
   .com.s set $gvar(ccp)
   .com.s configure -command "_setcp .c"
pack append .com .m left \
                 .com.b1 left \
                 .com.b2 left \
                 .com.b3 left \
                 .com.s left
pack append . .c left \
              .com bottom
proc _doit {c cx cy} {
   global gvar
   _do$gvar(cmd) $c [$c canvasx $cx] [$c canvasy $cy]
}

bind .c <Button-2>    " _doit .c %x %y "
