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: