#!/usr/bin/wish
##!/usr/bin/expectk

# (find-es "tcl" "newdiaglib")
# (find-fline "~/LATEX/basiclib.013")
# (find-fline "~/LATEX/diaglib.013")

label .msg -text "Head text"
pack  .msg -side top
canvas .c -width 500 -height 350 -relief sunken -borderwidth 2
pack   .c -expand yes -fill both
frame .buttons
pack  .buttons -side bottom
# button .buttons.b1 -text "Coords to stdout" -command coords_to_stdout
# button .buttons.b2 -text "Coords to o"      -command coords_to_o
# button .buttons.b3 -text "Clear auxiliaries" -command clear_auxiliaries
button .buttons.bo  -text {>stdout} -command {toggle_output}
button .buttons.bD  -text {$OnDump} -command {myputs $OnDump}
button .buttons.bC  -text {$OnCreate} -command {myputs $OnCreate}
button .buttons.bU  -text {$OnUpdate} -command {myputs $OnUpdate}
button .buttons.beD -text {eval $OnDump} -command {myputs [eval $OnDump]}
# button .buttons.bCa -text "Clear auxiliaries" -command clear_auxiliaries
pack   .buttons.bo .buttons.beD .buttons.bD .buttons.bC .buttons.bU \
       -side left
# .buttons.bCa
set c .c


set Output {}		;# meaning dump to stdout
proc toggle_output {} {
  global Output env
  if {$Output==""} {
    set Output $env(HOME)/o; .buttons.bo configure -text ">~/o"
  } else {
    set Output ""; .buttons.bo configure -text ">stdout"
  }
}
proc myputs {str} {
  global Output
  if {$Output==""} {puts $str} else {writefile $Output $str}
}

proc readfile {fname} {
  set channel [open $fname r]; set bigstr [read $channel]; close $channel
  return $bigstr
}
proc writefile {fname bigstr} {
  set channel [open $fname w]; puts -nonewline $channel $bigstr; close $channel
}


proc bbcorner {tag rness upness} {
  foreach {xl yu xr yd} [.c bbox $tag] {}
  return "[expr ($xl+$xr)/2+$rness*($xr-$xl)/2]\
          [expr ($yd+$yu)/2-$upness*($yu-$yd)/2]"
}
foreach {dir xness yness} {
  nw  -1 -1    nnw -0.5 -1   n 0 -1   nne 0.5 -1   ne  1 -1
  nww -1 -0.5                                      nee 1 -0.5
  w   -1  0                  c 0  0                e   1  0  
  sww -1  0.5                                      see 1  0.5
  sw  -1  1    ssw -0.5  1   s 0  1   sse 0.5  1   se  1  1   } {
    set Xness($dir) $xness
    set Yness($dir) $yness
}
proc ^ {dir tag} {
  global Xness Yness
  bbcorner $tag $Xness($dir) $Yness($dir)
}




proc v+ {a b args} {
  forach {da db} $args {
    set a [expr $a+$da]
    set b [expr $b+$db]
  }
  return "$a $b"
}
proc v- {a b args} {
  forach {da db} $args {
    set a [expr $a-$da]
    set b [expr $b-$db]
  }
  return "$a $b"
}
proc v*v {a b c d} {
  return "[expr $a*$c] [expr $b*$d]"
}
proc s*v {s a b} {
  return "[expr $s*$a] [expr $s*$b]"
}

# aa--->bb
#   cc--->dd
#
proc vdif+ {aa bb cc} {
  foreach {a1 a2 b1 b2 c1 c2} "$aa $bb $cc" {}
  return "[expr $c1+$b1-$a1] [expr $c2+$b2-$a2]"
}



set Tags {}
set OnCreate ""
set OnUpdate ""
set OnDump ""
# ArrowOptions: array of "create line" options
# Drags: array of tags
# XY: array of pairs of numbers


proc codefor {tag} {
  global Tags
  if {[lsearch $Tags $tag]==-1} {
    lappend Tags $tag
  }
}
proc oncreate {args} {
  global OnCreate
  append OnCreate "[join $args]\n"
  # puts [join $args]
  uplevel #0 [join $args]
}
proc onupdate {args} {
  global OnUpdate
  append OnUpdate "[join $args]\n"
}

proc j {args} {
  uplevel #0 eval join $args
}


proc metatext {tag text code} {
  codefor  $tag
  oncreate .c create text [j $code] -text [list $text] -tag $tag -fill brown4
  onupdate eval .c coords $tag \$XY($tag)
}
proc freetext {args} {
  global XY Drags OnDump
  foreach {tag text x y} $args {
    set XY($tag) "$x $y"
    metatext $tag $text \$XY($tag)
    draggable $tag
    append OnDump "puts \"freetext $tag [list $text] \$XY($tag)\"\n"
  }
}
proc deltatext {a b args} {
  foreach {c d dtxt drags} $args {
    codefor $d
    oncreate set XY($d) "\[vdif+ \$XY($a) \$XY($b) \$XY($c)\]"
    onupdate set XY($d) "\[vdif+ \$XY($a) \$XY($b) \$XY($c)\]"
    metatext $d $dtxt \$XY($d)
    draggable $d
  }
}


set ArrowOptions(m) {-arrow last -width 2 -arrowshape {6 7 2} -smooth 1}
set ArrowOptions(bij) {-arrow both -width 2 -arrowshape {6 7 2} -smooth 1}
set ArrowOptions(R) {-arrow last -width 4 -arrowshape {8 8 3} -smooth 1}
set ArrowOptions(L) {-arrow last -width 4 -arrowshape {8 8 3} -smooth 1 \
  -stipple @gray50.bmp}
set ArrowOptions(linha) {-width 2 -smooth 1}
set ArrowOptions(thin) {-arrow last -width 1 -arrowshape {3 4 1} -smooth 1}

proc metaarrow {tag code {type m}} {
  global ArrowOptions
  codefor  $tag
  oncreate eval .c create line $code -tag $tag \$ArrowOptions($type)
  onupdate eval .c coords $tag $code
}
proc metaarrow' {A e w B {mid ""} {type m}} {
  set tag $A$mid$B
  metaarrow $tag "\[^ $e $A\] \[^ $w $B\]" $type
}
#proc morf {a b dir dir2} {metaarrow' $a $dir $dir2 $b}
#proc bij  {a b dir dir2} {metaarrow' $a $dir $dir2 $b {} bij}
#proc R    {a b dir dir2} {metaarrow' $a $dir $dir2 $b {} R}
#proc L    {a b dir dir2} {metaarrow' $a $dir $dir2 $b {} L}

proc doarrows {type Args} {
  foreach {a b dir dir2} $Args {
    metaarrow' $a $dir $dir2 $b {} $type
  }
}
proc morf  {args} { doarrows m $args }
proc bij   {args} { doarrows bij $args }
proc R     {args} { doarrows R $args }
proc L     {args} { doarrows L $args }
proc linha {args} { doarrows linha $args }

proc samedirs {e w morf args} {
  foreach {a b} $args {
    $morf $a $b $e $w
  }
}


proc draggable {tag {passives {}}} {
  global Drags
  set Drags($tag) "$tag $passives"
  .c bind $tag <1>         "set oldxy \"%x %y\""
  .c bind $tag <B1-Motion> "bigdrag {%x %y} $tag"
  .c bind $tag
}
proc bigdrag {newxy tag} {
  global Drags XY oldxy OnUpdate
  foreach passive $Drags($tag) {
    set XY($passive) [vdif+ $oldxy $newxy $XY($passive)]
  }
  set oldxy $newxy
  eval $OnUpdate
}


proc setdragxy {tag args} {
  global Drags
  set Drags($tag) "$tag $args"
}



# (find-fline "~/LATEX/diaglib.013" "proc setdragvars")
# (eeman "3tk canvas" "pathName bind")
# (eeman "3tk bind" "BINDING SCRIPTS AND SUBSTITUTIONS")
# (find-fline "~/TK/freehand")

# (find-fline "~/LATEX/desenhos.013" "epsfile godement")

# freetext a a 99 73
# freetext b b 234 73
# freetext aF aF 82 142
# freetext aG aG 119 115
# freetext aFH aFH 63 195
# freetext aFK aFK 112 212
# 
# setdragxy a b
# setdragxy aF aG
# setdragxy aFH aFK
# 
# deltatext aF aG   aFH aGH aGH {aG}   aFK aGK aGK {aFK}
# deltatext a b	aF bF bF {aF}   aG bG bG {aG}
# deltatext a b   aFH bFH bFH {aFH aFK}   aGH bGH bGH {aG}
# deltatext a b   aFK bFK bFK {aFK}   aGK bGK bGK {aFK}
# 
# samedirs e w	morf	a b  aF bF  aG bG  aFH bFH  aFK bFK  aGH bGH  aGK bGK
# samedirs ne sw	morf	aF aG   bF bG   aFH aGH   bFH bGH   aFK aGK   bFK bGK
# samedirs see nw morf	aFH aFK   aGH aGK   bFH bFK   bGH bGK
# 
# samedirs s n	R	a aF   b bF
# samedirs se n	L	a aG   b bG
# samedirs ssw n	R	aF aFH   aG aGH   bF bFH   bG bGH
# samedirs sse n	L	aF aFK   aG aGK   bF bFK   bG bGK

# puts $OnCreate
# puts ---
# puts $OnUpdate