|
Warning: this is an htmlized version!
The original is here, and the conversion rules are here. |
#!/usr/bin/expectk
#!/usr/bin/wish
# (find-angg "LATEX/desenhos.014" "godement")
# (defun goto-block (s) (goto-position (format "«%s»" s)))
# (defun find-diag (s) (find-fline "~/LATEX/desenhos.014" (format "\nepsfile %s\n" s)))
# (find-diag "godement")
# (find-vldifile "tk8.0-dev.list")
#
# (find-es "tcl" "newdiaglib")
# (find-fline "~/LATEX/basiclib.013")
# (find-fline "~/LATEX/diaglib.013")
# (find-fline "~/LATEX/diaglib.013" "proc setdragvars")
# (find-man "3tk canvas" "pathName bind")
# (find-man "3tk bind" "BINDING SCRIPTS AND SUBSTITUTIONS")
# (find-fline "~/TK/freehand")
# (find-fline "~/LATEX/desenhos.013" "epsfile godement")
# (find-man "3tk canvas" "postscript")
# (find-man "3tk canvas" "bbox")
#
# Index:
# «.basic_window» (to "basic_window")
# «.postscript» (to "postscript")
# «.file_I/O» (to "file_I/O")
# «.corners» (to "corners")
# «.vector_math» (to "vector_math")
# «.code_arrays» (to "code_arrays")
# «.text_objects» (to "text_objects")
# «.arrow_objects» (to "arrow_objects")
# «.drag» (to "drag")
# «.compatibility_hacks» (to "compatibility_hacks")
# «.diagxy_hacks» (to "diagxy_hacks")
# «.top_level» (to "top_level")
#
# Code:
# «basic_window» (to ".basic_window")
canvas .c -width 500 -height 350 -relief sunken -borderwidth 2
pack .c -expand yes -fill both -side top
frame .buttons
button .buttons.beD -text {eval $OnDump} -command {eval_OnDump}
button .buttons.bD -text {$OnDump} -command {mybigputs $OnDump}
button .buttons.bC -text {$OnCreate} -command {mybigputs $OnCreate}
button .buttons.bU -text {$OnUpdate} -command {mybigputs $OnUpdate}
button .buttons.bo -text {>stdout} -command {toggle_output}
pack .buttons.beD .buttons.bD .buttons.bC .buttons.bU .buttons.bo \
-side left
frame .buttons2
button .buttons2.bb -text {blackify} -command {blackify}
button .buttons2.ca -text {clear auxiliaries} -command {clear_auxiliaries}
button .buttons2.bp -text {>.eps} -command {save_eps}
button .buttons2.bq -text {quit} -command {exit}
pack .buttons2.bb .buttons2.ca .buttons2.bp .buttons2.bq \
-side left
pack .buttons .buttons2 -after .c
# «postscript» (to ".postscript")
#
# epsfile: set the name of the .eps file and the window title
# blackify, clear_auxiliaries: prepare to save the .eps
# save_eps: do the save
proc epsfile {s} {
global psfile
set psfile "~/LATEX/eps/${s}.eps"
tk appname "${s}.eps"
}
epsfile o
proc blackify {} {
.c itemconfigure all -fill black
}
proc clear_auxiliaries {} {
.c delete _aux_
}
proc save_eps {} {
global psfile
foreach {xl yu xr yd} [.c bbox all] {}
.c postscript \
-x $xl -y $yu -width [expr $xr-$xl] -height [expr $yd-$yu] \
-pageanchor nw -file $psfile
}
# «file_I/O» (to ".file_I/O")
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 eval_OnDump {} {
global OnDump BigStr
set BigStr {}
uplevel #0 $OnDump
mybigputs $BigStr
}
proc myputs {args} {
global Output BigStr
if {$Output==""} {puts [join $args]} else {append BigStr "[join $args]\n"}
}
proc mybigputs {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
}
# «corners» (to ".corners")
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)
}
# «vector_math» (to ".vector_math")
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]"
}
# «code_arrays» (to ".code_arrays")
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
}
# «text_objects» (to ".text_objects")
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 "myputs \"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
}
}
# For when we're too lazy to guess the coordinates
proc float {x y args} {
foreach {tag text} $args {
freetext $tag $text $x $y
incr y 12
}
}
# «arrow_objects» (to ".arrow_objects")
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(T) {-arrow last -width 4 -arrowshape {8 8 3} -smooth 1 \
-stipple @gray50xx.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 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 T {args} { doarrows T $args }
proc linha {args} { doarrows linha $args }
proc thin {args} { doarrows thin $args }
proc samedirs {e w morf args} {
foreach {a b} $args {
$morf $a $b $e $w
}
}
# «drag» (to ".drag")
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"
}
# «compatibility_hacks» (to ".compatibility_hacks")
proc aux {args} {
foreach tag $args {
oncreate .c addtag _aux_ withtag $tag
}
}
proc auxiliary {args} {
global OnDump
set tags {}
foreach {tag text x y} $args {
freetext $tag $text $x $y
lappend tags $tag
}
eval aux $tags
append OnDump "myputs \"aux $tags\"\n"
}
# 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}
}
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
auxiliary 1_$tag1$tag4 * [expr $x + 5] [expr $y + 20]
auxiliary 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 hmorf {args} {
eval samedirs e w morf $args
}
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
}
}
# 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' {args} {
eval samedirs w e morf $args
}
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 ^+ {xy args} {
foreach {x y} $xy {}
set xys {}
foreach {dx dy} $args {
lappend xys [expr $x + $dx] [expr $y + $dy]
}
return $xys
}
set ArrowOptions(gmorf) {-arrow last -width 2 -arrowshape {6 7 2} \
-smooth 1 -stipple @gray50.bmp}
set ArrowOptions(gbij) {-arrow both -width 2 -arrowshape {6 7 2} \
-smooth 1 -stipple @gray50.bmp}
proc gmorf {args} {doarrows gmorf $args}
proc gbij {args} {doarrows gbij $args}
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 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
}
proc kleislirow {x y args} {
foreach dx {0 40 78 122} t $args {
if {$t != ""} {
freetext $t $t [expr $x+$dx] $y
}
}
}
set ArrowOptions(thinlinha) {-width 1 -smooth 1}
proc thinlinha {args} { doarrows thinlinha $args }
# «diagxy_hacks» (to ".diagxy_hacks")
# (find-angg "LATEX/desenhos.014" "diagxy1")
proc dxybuttons {} {
frame .buttons3
button .buttons3.bDxyD -text {$OnDxyDump} -command {mybigputs $OnDxyDump}
button .buttons3.beDxyD -text {eval $OnDxyDump} \
-command {mybigputs [eval $OnDxyDump]}
button .buttons3.savetmpdiag -text {...>~/LATEX/tmpdiag.tex} \
-command { ;# Aaaargh! Hackish!
global env Output BigStr
set OldOutput $Output
set Output $env(HOME)/LATEX/tmpdiag.tex
set BigStr ""
mybigputs [eval $OnDxyDump]
set Output $OldOutput
}
pack .buttons3.bDxyD .buttons3.beDxyD .buttons3.savetmpdiag -side left
pack .buttons3 -after .buttons2
}
set OnDxyDump ""
set dxyorigx 100
set dxyorigy 100
set dxyscale 5
# array: DxyTeX, tag -> TeXcode (the text of the node)
proc dxytext {tag text tex x y {nodump {}}} {
global XY Drags OnDump OnDxyDump DxyTeX
set XY($tag) "$x $y"
set DxyTeX($tag) $tex
metatext $tag $text \$XY($tag)
draggable $tag
if {$nodump==""} {
append OnDump "myputs dxytext $tag [list $text] \[[list list $tex]\] \$XY($tag)\n"
}
}
proc tktodxy {tkxy} {
global dxyorigx dxyorigy dxyscale
foreach {x y} $tkxy {}
return "[expr $dxyscale*($x-$dxyorigx)],[expr -$dxyscale*($y-$dxyorigy)]"
}
proc tktodxydelta {tkxy1 tkxy2} {
global dxyscale
foreach {x1 y1 x2 y2} "$tkxy1 $tkxy2" {}
return "[expr $dxyscale*($x2-$x1)],[expr -$dxyscale*($y2-$y1)]"
}
# (find-diagxyfile "diaxydoc.tex" "learn mainly by example")
# (find-diagxyfile "diaxydoc.tex" "\\morphism(x,y)|p|/{sh}/<dx,dy>[N`N;L]")
#
proc putsdxymorphism {tag1 tag2 arrowname placeshape} {
global XY DxyTeX
set start [tktodxy $XY($tag1)]
set delta [tktodxydelta $XY($tag1) $XY($tag2)]
myputs " \\morphism($start)$placeshape<$delta>\[$DxyTeX($tag1)`$DxyTeX($tag2);$arrowname\]"
}
proc dxymorf {tag1 tag2 {arrowname {}} {placeshape {}}} {
global OnDxyDump
append OnDxyDump "[list putsdxymorphism $tag1 $tag2 $arrowname $placeshape]\n"
}
set tmptagcounter 0
# example: dxyfloatmorf <1 1> � � f |a|/|->/ 100 100 120 120
proc dxyfloatmorf {text1 text2 tex1 tex2 arrowname placeshape x1 y1 x2 y2} {
global tmptagcounter OnDump
set tag1 _tmp$tmptagcounter; incr tmptagcounter
set tag2 _tmp$tmptagcounter; incr tmptagcounter
dxytext $tag1 $text1 "\\phantom{$tex1}" $x1 $y1 nodump
dxytext $tag2 $text2 "\\phantom{$tex2}" $x2 $y2 nodump
dxymorf $tag1 $tag2 $arrowname $placeshape
set stuff [concat [list $text1] [list $text2] [list $tex1] [list $tex2] \
[list $arrowname] [list $placeshape] \
\$XY($tag1) \$XY($tag2)
]
append OnDump "myputs dxyfloatmorf $stuff\n"
}
proc putsdxyplace {tag} {
global XY DxyTeX
myputs " \\place([tktodxy $XY($tag)])\[{$DxyTeX($tag)}\]"
}
proc dxyplace {tag text tex x y} {
global OnDump OnDxyDump
dxytext $tag $text $tex $x $y nodump
append OnDxyDump "putsdxyplace $tag\n"
append OnDump "myputs dxyplace $tag $text [list $tex] \$XY($tag)\n"
}
proc dxysquare {prefix x1 x2 y1 y2
la ta lb tb lc tc ld td
tab psab tac psac tbd psbd tcd pscd } {
dxytext ${prefix}a $la $ta $x1 $y1
dxytext ${prefix}b $lb $tb $x2 $y1
dxytext ${prefix}c $lc $tc $x1 $y2
dxytext ${prefix}d $ld $td $x2 $y2
dxymorf ${prefix}a ${prefix}b $tab $psab
dxymorf ${prefix}a ${prefix}c $tac $psac
dxymorf ${prefix}b ${prefix}d $tbd $psbd
dxymorf ${prefix}c ${prefix}d $tcd $pscd
}
proc dxy2squares {prefix x1 x2 x3 y1 y2
la ta lb tb lc tc ld td le te lf tf
tab psab tbc psbc tad psad tbe psbe tcf pscf tde psde tef psef } {
dxytext ${prefix}a $la $ta $x1 $y1
dxytext ${prefix}b $lb $tb $x2 $y1
dxytext ${prefix}c $lc $tc $x3 $y1
dxytext ${prefix}d $ld $td $x1 $y2
dxytext ${prefix}e $le $te $x2 $y2
dxytext ${prefix}f $lf $tf $x3 $y2
dxymorf ${prefix}a ${prefix}b $tab $psab
dxymorf ${prefix}b ${prefix}c $tbc $psbc
dxymorf ${prefix}a ${prefix}d $tad $psad
dxymorf ${prefix}b ${prefix}e $tbe $psbe
dxymorf ${prefix}c ${prefix}f $tcf $pscf
dxymorf ${prefix}d ${prefix}e $tde $psde
dxymorf ${prefix}e ${prefix}f $tef $psef
}
proc dxy4squares {prefix x1 x2 x3 x4 x5 y1 y2
la ta lb tb lc tc ld td le te lf tf lg tg lh th li ti lj tj
tab psab tbc psbc tcd pscd tde psde
taf psaf tbg psbg tch psch tdi psdi tej psej
tfg psfg tgh psgh thi pshi tij psij } {
dxytext ${prefix}a $la $ta $x1 $y1
dxytext ${prefix}b $lb $tb $x2 $y1
dxytext ${prefix}c $lc $tc $x3 $y1
dxytext ${prefix}d $ld $td $x4 $y1
dxytext ${prefix}e $le $te $x5 $y1
dxytext ${prefix}f $lf $tf $x1 $y2
dxytext ${prefix}g $lg $tg $x2 $y2
dxytext ${prefix}h $lh $th $x3 $y2
dxytext ${prefix}i $li $ti $x4 $y2
dxytext ${prefix}j $lj $tj $x5 $y2
dxymorf ${prefix}a ${prefix}b $tab $psab
dxymorf ${prefix}b ${prefix}c $tbc $psbc
dxymorf ${prefix}c ${prefix}d $tcd $pscd
dxymorf ${prefix}d ${prefix}e $tde $psde
dxymorf ${prefix}a ${prefix}f $taf $psaf
dxymorf ${prefix}b ${prefix}g $tbg $psbg
dxymorf ${prefix}c ${prefix}h $tch $psch
dxymorf ${prefix}d ${prefix}i $tdi $psdi
dxymorf ${prefix}e ${prefix}j $tej $psej
dxymorf ${prefix}f ${prefix}g $tfg $psfg
dxymorf ${prefix}g ${prefix}h $tgh $psgh
dxymorf ${prefix}h ${prefix}i $thi $pshi
dxymorf ${prefix}i ${prefix}j $tij $psij
}
proc dxytriangle {prefix xa ya xb yb xc yc
la ta lb tb lc tc
tab psab tac psac tbc psbc } {
dxytext ${prefix}a $la $ta $xa $ya
dxytext ${prefix}b $lb $tb $xb $yb
dxytext ${prefix}c $lc $tc $xc $yc
dxymorf ${prefix}a ${prefix}b $tab $psab
dxymorf ${prefix}a ${prefix}c $tac $psac
dxymorf ${prefix}b ${prefix}c $tbc $psbc
}
proc dxynttriangle {prefix xa ya xb yb xc yc xd yd
la ta lb tb lc tc ld td
tab psab tac psac tbc psbc tad psad } {
if {$xd==""} { set xd [expr ($xb+$xc)/2] }
if {$yd==""} { set yd [expr ($yb+$yc)/2] }
dxytext ${prefix}a $la $ta $xa $ya
dxytext ${prefix}b $lb $tb $xb $yb
dxytext ${prefix}c $lc $tc $xc $yc
dxytext ${prefix}d $ld $td $xd $yd
dxymorf ${prefix}a ${prefix}b $tab $psab
dxymorf ${prefix}a ${prefix}c $tac $psac
dxymorf ${prefix}b ${prefix}c $tbc $psbc
dxymorf ${prefix}a ${prefix}d $tad $psad
}
# «top_level» (to ".top_level")
if {$argv!=""} {
uplevel #0 $argv
} else {
# I always use this anyway
# source ~/tmp/ee.diag
# source $env(EEVTMPDIR)/ee.diag
}
# Local Variables:
# coding: no-conversion
# ee-delimiter-hash: "\n#*\n"
# ee-anchor-format: "«%s»"
# ee-charset-indicator: "Ñ"
# End: