#!/usr/bin/wish
# 98oct02 2:28

# (find-tkexfile "plot.tcl")
# (find-tkexfile "arrow.tcl")
# (find-tkexfile "button.tcl")

source basiclib.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
pack   .buttons.b1 .buttons.b2 .buttons.b3 -side left
set c .c

proc epsfile {s} {
  global psfile
  # set psfile "~/LATEX/${s}.eps"
  set psfile "~/LATEX/eps/${s}.eps"
  .msg configure -text "${s}.eps"
}

proc brack01 {t a b} {
  expr $a + $t * ($b - $a)
}
proc brack {t a b} {
  expr ($a + $b + $t * ($b - $a)) / 2
}
proc brackbox {bb tx ty} { eval brackbox_long $bb $tx $ty }
proc brackbox_long {xleft yup xright ydown tx ty} {
  list [brack $tx $xleft $xright] [brack $ty $yup $ydown]
}
proc bbcorner {tag tx ty} {
  global c
  brackbox [$c bbox $tag] $tx $ty
}
proc ^n  {tag} { bbcorner $tag 0 -1 }
proc ^nw {tag} { bbcorner $tag -1 -1 }; proc ^ne {tag} { bbcorner $tag  1 -1 }
proc ^w  {tag} { bbcorner $tag -1  0 }; proc ^e  {tag} { bbcorner $tag  1  0 }
proc ^sw {tag} { bbcorner $tag -1  1 }; proc ^se {tag} { bbcorner $tag  1  1 }
proc ^s  {tag} { bbcorner $tag 0 1 }

proc ^c  {tag} { bbcorner $tag 0 0 }



proc ^nnw {tag} { bbcorner $tag -0.5 -1 }
proc ^nne {tag} { bbcorner $tag  0.5 -1 }
proc ^ssw {tag} { bbcorner $tag -0.5  1 }
proc ^sse {tag} { bbcorner $tag  0.5  1 }

proc ^nww {tag} { bbcorner $tag -1 -0.5 }
proc ^nee {tag} { bbcorner $tag  1 -0.5 }
proc ^sww {tag} { bbcorner $tag -1  0.5 }
proc ^see {tag} { bbcorner $tag  1  0.5 }



proc ^+ {xy args} {
  foreach {x y} $xy {}
  set xys {}
  foreach {dx dy} $args {
    lappend xys [expr $x + $dx] [expr $y + $dy]
  }
  return $xys
} 




# (find-fline "/usr/lib/tk8.0/demos/")
# (find-fline "/usr/lib/tcl8.0/parray.tcl")

# Globais:
#
# Expr()
# ExprVars
# Vars
# Tags
# Redraw()
# Auxiliaries
# XVarsToDrag
# YVarsToDrag
# ArrowOptions
# Oppo

set ExprVars {}
set Vars {}
set Tags {}
set Auxiliaries {}

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}


set Oppo(nw) se; set Oppo(n) s; set Oppo(ne) sw
set Oppo(w)  e;                 set Oppo(e) w
set Oppo(sw) ne; set Oppo(s) n; set Oppo(se) nw

proc setvars {args} {
  global Expr ExprVars Vars
  foreach {varname valuestring} $args {
    upvar #0 $varname var
    lappend Vars $varname
    set value [uplevel #0 eval expr $valuestring]
    set var $value
    if {" $value" != " $valuestring"} {
      lappend ExprVars $varname
      set Expr($varname) $valuestring
    }
  }
}
proc recalc {} {
  global Expr ExprVars
  foreach varname $ExprVars {
    uplevel #0 set $varname [uplevel #0 expr $Expr($varname)]
  }
}
proc redraw {} {
  global Tags Redraw
  foreach tag $Tags {
    uplevel #0 $Redraw($tag)
  }
}


proc dodrag {x y} {
  global deltax deltay XVarsToDrag YVarsToDrag
  getdeltas $x $y
  foreach xvarname $XVarsToDrag {
    upvar #0 $xvarname xvar
    set xvar [expr $xvar + $deltax]
  }
  foreach yvarname $YVarsToDrag {
    upvar #0 $yvarname yvar
    set yvar [expr $yvar + $deltay]
  }
  recalc
  redraw
}
proc setdragvars {tag xvars yvars} {
  global XVarsToDraw YVarsToDrag c
  uplevel #0 [mysubst {
    $c bind %tag <1> {
      getdeltas %x %y
      set XVarsToDrag {%xvars}
      set YVarsToDrag {%yvars}
    }
  } %tag $tag %xvars $xvars %yvars $yvars]
  uplevel #0 [mysubst {
    $c bind %tag <B1-Motion> {
      dodrag %x %y
    }
  } %tag $tag]
  $c itemconfigure $tag -fill brown4
}

# proc setdragxy {tag args} {
#   set xdrag [format "X(%s)" $tag]
#   set ydrag [format "Y(%s)" $tag]
#   foreach othertag $args {
#     lappend xdrag [format "X(%s)" $othertag]
#     lappend ydrag [format "Y(%s)" $othertag]
#   }
#   setdragvars $tag $xdrag $ydrag
# }

proc setdragxy0 {tag args} {
  set xdrag ""
  set ydrag ""
  foreach othertag $args {
    lappend xdrag [format "X(%s)" $othertag]
    lappend ydrag [format "Y(%s)" $othertag]
  }
  setdragvars $tag $xdrag $ydrag
}
proc setdragxy {tag args} {
  eval setdragxy0 $tag $tag $args
}




# Uma rotina de debugamento bonitinha (e umas amigas dela)
#
proc vardump {} {
  global Vars Expr
  foreach varname $Vars {
    upvar #0 $varname var
    if [uplevel #0 info exists Expr($varname)] {
      puts "$varname => $Expr($varname) => $var"
    } {
      puts "$varname -> $var"
    }
  }
}
proc get_numeric_vars {} {
  global Vars Expr
  foreach varname $Vars {
    upvar #0 $varname var
    if [uplevel #0 info exists Expr($varname)] { } {
      lappend list "$varname $var"
    }
  }
  return $list
}
proc coords_to_stdout {} {
  puts ""
  foreach pair [get_numeric_vars] {
    puts $pair
  }
}
proc coords_to_o {} {
  set o [open ~/o w]
  foreach pair [get_numeric_vars] {
    puts $o $pair
  }
  close $o
}





proc metatext {tag label code} {
  global c Redraw Tags
  uplevel #0 $c create text $code -text $label -tag $tag
  lappend Tags $tag
  set Redraw($tag) "$c coords $tag $code"
}
proc metaarrow {tag code {type m}} {
  global c Redraw Tags ArrowOptions
  set value [eval concat $code]
  eval $c create line $value -tag $tag $ArrowOptions($type)
  lappend Tags $tag
  set Redraw($tag) "eval $c coords $tag $code"
}


proc metaarrow' {A e w B {mid ""} {t ""}} {
  runsubst0 {
    metaarrow %A%mid%B {[^%e %A] [^%w %B]} %t
  } %A $A %e $e %w $w %B $B %mid $mid %t $t
}
proc freetext {args} {
  foreach {tag text x y} $args {
    runsubst0 {
      setvars X(%tag) %x   Y(%tag) %y
      metatext %tag %text {$X(%tag) $Y(%tag)}
      setdragvars %tag {X(%tag)} {Y(%tag)}
    } %tag $tag  %text $text  %x $x  %y $y
  }
}
proc auxiliar {args} {
  global Auxiliaries
  foreach {tag text x y} $args {
    freetext $tag $text $x $y
    lappend Auxiliaries $tag
  }
}



# a-->b
#  c-->d
#
# d:=c+b-a
#
proc deltatext {a b args} {
  foreach {c d dtext dragvars} $args {
    setvars "X($d)" [format {$X(%s) + $X(%s) - $X(%s)} $c $b $a]
    setvars "Y($d)" [format {$Y(%s) + $Y(%s) - $Y(%s)} $c $b $a]
    metatext $d $dtext [format {$X(%s) $Y(%s)} $d $d]
    setdragxy0 $d $dragvars
  }
}
proc samedirs {dir1 dir2 command args} {
  foreach {tag1 tag2} $args {
    $command $tag1 $tag2 $dir1 $dir2
  }
}




#
# Umas coisas pros diagramas de adjun‡äes:
#

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 reflec {x y at a bt b {ct ""} {c ""}} {
  freetext $at $a $x $y
  freetext $bt $b $x [expr $y + 40]
  L $at $bt s n
  if {" $ct" != " "} {
    freetext $ct $c [expr $x + 20] [expr $y + 70]
    morf $ct $bt nw s
  }
}
proc hmorf {at bt args} {
  morf $at $bt e w
  if [llength $args] {eval hmorf $args}
}

# Pro caso invertido (com evs):
proc reflec' {x y at a bt b {ct ""} {c ""}} {
  freetext $at $a $x $y
  freetext $bt $b $x [expr $y + 50]
  R $at $bt s n
  if {" $ct" != " "} {
    freetext $ct $c [expr $x + 44] [expr $y + 80]
    morf $bt $ct sse nw
  }
}
proc hmorf' {at bt args} {
  morf $at $bt w e
  if [llength $args] {eval hmorf' $args}
}

proc morfs {a b dir dir2 args} {
  morf $a $b $dir $dir2
  if [llength $args] {eval morfs $args}
}

# Pras adjun‡äes quadradas:
#
proc vtorre' {x y at a bt b args} {
  set y [expr $y + 40]
  freetext $bt $b $x $y
  morf $at $bt s n
  if [llength $args] {eval vtorre' $x $y $bt $b $args}
}
proc vtorre {x y at a bt b args} {
  freetext $at $a $x $y
  eval vtorre' $x $y $at $a $bt $b $args
}
proc R' {at aRt args} {
  R $at $aRt e w
  if [llength $args] {eval R' $args}
}
proc L' {at aLt args} {
  L $at $aLt w e
  if [llength $args] {eval L' $args}
}



# Pro diagrama da introdu‡Æo:
#
proc linha {a b dir dir2} {metaarrow' $a $dir $dir2 $b {} linha}


# Pros diamond lemmas:
#
proc thinsw {a b} {metaarrow' $a sw ne $b {} thin}
proc thinse {a b} {metaarrow' $a se nw $b {} thin}



# Setas cinza que nÆo sÆo funtores:
#
set ArrowOptions(gmorf) {-arrow last -width 2 -arrowshape {6 7 2} -smooth 1 -stipple @~/TK/gray50.bmp}
set ArrowOptions(gbij) {-arrow both -width 2 -arrowshape {6 7 2} -smooth 1 -stipple @~/TK/gray50.bmp}
proc gmorf {a b dir dir2} {metaarrow' $a $dir $dir2 $b {} gmorf}
proc gbij  {a b dir dir2} {metaarrow' $a $dir $dir2 $b {} gbij}

proc gmorf {args} {
  foreach {a b dir dir2} $args {
  metaarrow' $a $dir $dir2 $b {} gmorf
} }
proc gbij {args} {
  foreach {a b dir dir2} $args {
    metaarrow' $a $dir $dir2 $b {} gbij
} }

proc fibrado {x y tag1 txt1 tag2 txt2 tag3 txt3 tag4 txt4} {
  freetext $tag1 $txt1 $x $y
  freetext $tag2 $txt2 [expr $x + 40] $y
  freetext $tag3 $txt3 $x [expr $y + 40]
  freetext $tag4 $txt4 [expr $x + 40] [expr $y + 40]
  morf $tag2 $tag1 w e
  gbij $tag1 $tag3 s n
  gbij $tag2 $tag4 s n
  morf $tag4 $tag3 w e
  setdragxy $tag1 $tag2 $tag3 $tag4
}
proc quadrado {x y tag1 txt1 tag2 txt2 tag3 txt3 tag4 txt4} {
  freetext $tag1 $txt1 $x $y
  freetext $tag2 $txt2 [expr $x + 40] $y
  freetext $tag3 $txt3 $x [expr $y + 40]
  freetext $tag4 $txt4 [expr $x + 40] [expr $y + 40]
  morf $tag1 $tag2 e w
  morf $tag1 $tag3 s n
  morf $tag2 $tag4 s n
  morf $tag3 $tag4 e w
  setdragxy $tag1 $tag2 $tag3 $tag4
}
proc quadrado-adj {x y tag1 txt1 tag2 txt2 tag3 txt3 tag4 txt4} {
  freetext $tag1 $txt1 $x $y
  freetext $tag2 $txt2 [expr $x + 40] $y
  freetext $tag3 $txt3 $x [expr $y + 40]
  freetext $tag4 $txt4 [expr $x + 40] [expr $y + 40]
  R $tag1 $tag2 e w
  morf $tag1 $tag3 s n
  morf $tag2 $tag4 s n
  L $tag4 $tag3 w e
  auxiliar 1_$tag1$tag4 * [expr $x + 5] [expr $y + 20]
  auxiliar 2_$tag1$tag4 * [expr $x + 35] [expr $y + 20]
  bij 1_$tag1$tag4 2_$tag1$tag4 e w
  setdragxy $tag1 $tag2 $tag3 $tag4 1_$tag1$tag4 2_$tag1$tag4
}
proc kite {x y  a as  ar ars  arl arls  b bs  bl bls} {
  reflec $x $y  $ar $ars  $arl $arls  $a $as
  reflec [expr $x+40] $y  $b $bs  $bl $bls
  hmorf $ar $b  $arl $bl
  morf $a $bl  ne s
}


# Pras m“nadas:
#
proc kleislirow {x y args} {
  foreach dx {0 40 78 122} t $args {
    if {$t != ""} {
      freetext $t $t [expr $x+$dx] $y
    }
  }
}
proc thinmorf {args} {
  foreach {a b dir dir2} $args {
    metaarrow' $a $dir $dir2 $b {} thin
  }
}




proc clear_auxiliaries {} {
  global Auxiliaries
  puts $Auxiliaries
  eval .c delete $Auxiliaries
  # Warning:
  # Do not run "recalc" or "redraw" after that!
  # Some corners will cease to exist.
  .buttons.b3 configure -text "Blackify" -command blackify
}
proc blackify {} {
  .c itemconfigure all -fill black
  .buttons.b3 configure -text "Output o.ps" -command output_o.ps
}
#
# % proc outps {args} { eval .c postscript $args }
# % .c bbox all
# 60 53 231 185
# % outps -pageanchor nw -x 60 -y 53 -width 171 -height 132
#
proc output_o.ps00 {xleft ytop xright ybot} {
  .c postscript -file [v@ psfile "~/o.ps"] -pageanchor nw \
      -x $xleft -y $ytop \
      -width [expr $xright - $xleft] -height [expr $ybot - $ytop]
}
proc output_o.ps0 {x1 y1 x2 y2} {
  output_o.ps00 [min $x1 $x2] [min $y1 $y2] [max $x1 $x2] [max $y1 $y2]
}

proc output_o.ps {} {
  eval output_o.ps0 [.c bbox all]
}






# proc output_o.ps_ {xleft ytop xright ybot} {
#   .c postscript -file ~/o.ps -pageanchor nw \
#       -x $xleft -y $ytop \
#       -width [expr $xright - $xleft] -height [expr $ybot - $ytop]
# }
# proc output_o.ps {} {
#   eval output_o.ps_ [.c bbox all]
# }
#