proc comment args {} switch $tcl_platform(platform) { unix { event add <> event add <> event add <> event delete <> event add <> # correct some strange failures in key bindings bind Text {event generate %W <>} bind Text {event generate %W <>} } } option add *Menu.tearOffCommand fixTornOffMenu option add *Canvas.highlightThickness 0 option add *Label.borderWidth 1 option add *Entry.borderWidth 1 option add *Spinbox.borderWidth 1 option add *Button.borderWidth 1 option add *Menubutton.borderWidth 1 option add *Scrollbar.borderWidth 1 option add *Entry.font {Helvetica 9} option add *Label.font {Helvetica 9} option add *Button.font {Helvetica 9} option add *Menubutton.font {Helvetica 9} option add *Checkbutton.font {Helvetica 9} option add *Labelframe.font {Helvetica 9} option add *Text.font {Helvetica 9} option add *Menu.background \#c0c0c0 option add *Menu.borderWidth 1 option add *Menu.activeBorderWidth 1 option add *Radiobutton.font {Helvetica 9} option add *Radiobutton.justify left option add *Radiobutton.wrapLength 300 option add *Checkbutton.justify left option add *Checkbutton.wrapLength 300 option add *Entry.background white option add *Entry.highlightThickness 0 option add *Text.background white option add *Text.relief sunken option add *Text.borderWidth 1 option add *Text.insertOffTime 0 option add *Text.highlightThickness 0 option add *Text.undo 1 option add *Menu.background \#c0c0c0 option add *Menu.borderwidth 0 proc fixTornOffMenu {menu toplevel} { # make tear-off transient to parent window. set parent [winfo parent $toplevel] wm transient $toplevel $parent if {$::tcl_platform(platform) ne "unix"} { set px [winfo pointerx $parent] set py [winfo pointery $parent] set x [expr {$px - 30}] set y [expr {$py - 10}] wm geometry $toplevel +$x+$y } wm resizable $toplevel no no } proc setVscrollbarIn {toplevel a b} { # set vertical scrollbar in $toplevel (managed by grid) if {$toplevel eq "."} { set scrollbar .vscroll } else { set scrollbar $toplevel.vscroll } if {($a == 0.0) && ($b == 1.0)} { set code "catch {grid forget $scrollbar}" after cancel $code after 100 $code } else { grid configure $scrollbar -row 0 -column 1 -sticky news set code [list $scrollbar set $a $b] after cancel $code after idle $code } } proc setHscrollbarIn {toplevel a b} { # set horizontal scrollbar in $toplevel (managed by grid) if {$toplevel eq "."} { set scrollbar .hscroll } else { set scrollbar $toplevel.hscroll } if {($a == 0.0) && ($b == 1.0)} { set code "catch {grid forget $scrollbar}" after cancel $code after 100 $code } else { grid configure $scrollbar -row 1 -column 0 -sticky news set code [list $scrollbar set $a $b] after cancel $code after idle $code } } namespace eval dummy {} proc scrolledtext {f args} { frame $f -class Scrolledtext text $f.text grid $f.text\ [scrollbar $f.vscroll\ -command [list $f.text yview]]\ -sticky news grid [scrollbar $f.hscroll\ -orient horizontal\ -command [list $f.text xview]]\ -sticky news grid rowconfigure $f 0 -weight 1 grid columnconfigure $f 0 -weight 1 $f.text configure\ -xscrollcommand [list setHscrollbarIn $f]\ -yscrollcommand [list setVscrollbarIn $f]\ -wrap word rename $f ::dummy::$f proc $f {args} [subst { eval $f.text \$args }] eval $f.text configure $args set f } proc scrolledrichtext {f args} { frame $f -class Scrolledrichtext richtext $f.text grid $f.text\ [scrollbar $f.vscroll\ -command [list $f.text yview]]\ -sticky news grid [scrollbar $f.hscroll\ -orient horizontal\ -command [list $f.text xview]]\ -sticky news grid rowconfigure $f 0 -weight 1 grid columnconfigure $f 0 -weight 1 $f.text configure\ -xscrollcommand [list setHscrollbarIn $f]\ -yscrollcommand [list setVscrollbarIn $f]\ -wrap word rename $f ::dummy::$f proc $f {args} [subst { eval $f.text \$args }] eval $f.text configure $args set f } namespace eval Lambda { variable counter 0 array set function {} namespace eval Function {} namespace export lambda } proc ::Lambda::nextName {} { variable counter return [namespace current]::Function::[incr counter] } proc ::Lambda::lambda {arglist body} { # return quasi-anonymous lambda term # (i. e. build a procedure bound to some name, and return that name). variable function set formals [list $arglist $body] if {![info exists function($formals)]} { set name [nextName] uplevel 1 [list proc $name $arglist $body] set function($formals) $name } return $function($formals) } namespace import -force ::Lambda::lambda proc unicode2texNormal {unicode} { variable char2texTable set string [string trim $unicode] set texChars [string map $char2texTable $string] set lineFeedMap [list \n \\\\\n] set texLines [string map $lineFeedMap $texChars] set parPattern {(\s*\\\\\n){2,}} set texLines [regsub -all $parPattern $texLines "\n\n"] string map [list\ ... [globalSetting ...]\ {\pagebreak{}\\} {\pagebreak{}} ] $texLines } # proc subSubjectIndices {src} { set indices\ [regexp -all -inline -indices {(?:^|\n+)([*/_])[^\n]*?\1} $src] set result {} foreach {match sign} $indices { let {from to} $match lappend result $from set foundRange [string range $src $from $to] set char\ [string index [string trim $foundRange] 0] set pat \\$char.*?\\$char if {[regexp -indices $pat $foundRange match1]} { let {from1 to1} $match1 set len [expr {$to1-$from1}] lappend result\ [expr {$from + $len + [string first $char $foundRange]}] } else { lappend result $to } } set result } proc textSubSubjectFragments {src} { set indices -1 set subSubjects {} foreach {from to} [subSubjectIndices $src] { lappend subSubjects [string range $src $from $to] lappend indices [expr {$from - 1}] [expr {$to + 1}] } lappend indices [string length $src] set textList {} foreach {from to} $indices { lappend textList [string range $src $from $to] } # list subSubjectes $subSubjects textList $textList set result [lrange $textList -1 0] foreach subSubject $subSubjects text [lrange $textList 1 end] { lappend result $subSubject $text } set result } proc unicode2tex {src} { set frags [textSubSubjectFragments $src] set result [unicode2texNormal [lindex $frags 0]] array set meaning { * \\bf / \\it _ \\underline } foreach {sub txt} [lrange $frags 1 end] { regexp -indices {[*/_]} $sub indices let {from to} $indices set subChar [string range $sub $from $to] set subText [string range $sub [expr {$to+1}] end-1] set splitRange [regexp -inline ^\\s* $txt] append result \n\n\{\ $meaning($subChar) \ \{ [unicode2texNormal $subText] \}\ \}\ $splitRange\ [unicode2texNormal $txt] } string trim $result } # proc charVal {char} { scan $char %c } proc hex {number} { format %x $number } proc echo {args} { uplevel [list puts $args] } # # return string with non-ascii chars encoded as in ö = \u00f6 etc. # proc unicode2asciiEncoded {rawString} { set string [string map {\\ \\\\} $rawString] while {[regexp {[^[:ascii:]]} $string nonAsciiChar]} { set nonAsciiVal [charVal $nonAsciiChar] set hexVal [hex $nonAsciiVal] while {[string length $hexVal] < 4} { set hexVal 0$hexVal } set hexVal \\u$hexVal set string [string map [list $nonAsciiChar $hexVal] $string] } set string } proc saveString {string file} { set port [open $file w] puts -nonewline $port $string close $port } proc cat file { set port [open $file] set contents [read $port] close $port return $contents } proc let {args} { uplevel 1 foreach $args {break} } proc range {num args} { switch [llength $args] { 0 { set from 0 set to $num set step 1 } 1 { set from $num set to $args set step 1 } 2 { set from $num let {to step} $args } } set result [list ] for {set i $from} {$i < $to} {set i [expr {$i + $step}]} { lappend result $i } return $result } proc map {func list} { set result [list ] foreach el $list { lappend result [uplevel [list $func $el]] } return $result } proc llindex {l args} { # return nested list index, e.g. llindex $nestedList 4 2 if {[llength $args] == 0} { return $l } else { eval llindex [list [lindex $l [lindex $args 0]]] [lrange $args 1 end] } } namespace eval Stack { variable stack {} namespace export push pop tos } proc Stack::pop {{s ::Stack::stack}} { upvar $s stack set result [lindex $stack end] set stack [lrange $stack 0 end-1] return $result } proc Stack::push {val {s ::Stack::stack}} { upvar $s stack lappend stack $val } proc Stack::tos {{s ::Stack::stack}} { upvar $s stack lindex $stack end } namespace import -force ::Stack::push namespace import -force ::Stack::pop namespace import -force ::Stack::tos proc map {func list} { set result [list ] foreach el $list { lappend result [uplevel [list $func $el]] } return $result } proc shift {listVar} { upvar $listVar list set result [lindex $list 0] set list [lrange $list 1 end] set result } proc unshift {el listVar} { upvar $listVar list set list [concat $el $list] } namespace eval Sleep { namespace export sleep variable count 0 } proc ::Sleep::newVar {} { variable count return var[incr count] } proc ::Sleep::sleep {num} { set var [newVar] uplevel 1 set ::Sleep::$var 1 after $num [list set ::Sleep::$var 0] vwait ::Sleep::$var unset ::Sleep::$var } namespace import -force ::Sleep::sleep proc lreverse {l} { set i [llength $l] set result {} while {$i} { lappend result [lindex $l [incr i -1]] } # return this value set result } proc relPathFromTo {fromDir toDir} { # return path string relative from $fromDir to $toDir. # $fromDir is assumed to be a directory (not a file). set from [file normalize $fromDir] set to [file normalize $toDir] if {$::tcl_platform(platform) eq "windows"} { set driveMap { a: A: b: B: c: C: d: D: e: E: f: F: g: G: h: H: i: I: j: J: k: K: l: L: m: M: n: N: o: O: p: P: q: Q: r: R: s: S: t: T: u: U: v: V: w: W: x: X: y: Y: z: Z: } regexp {^[a-zA-Z]:} [pwd] drive if {![regexp {^[a-zA-Z]:} $from]} { set from $drive$from } set from [string map $driveMap $from] if {![regexp {^[a-zA-Z]:} $to]} { set to $drive$to } set to [string map $driveMap $to] } set fromList [file split $from] set fromLength [llength $fromList] set toList [file split $to] set toLength [llength $toList] set commonList {} foreach path1 $fromList path2 $toList { if {$path1 ne $path2} { break } else { lappend commonList $path1 } } set commonLength [llength $commonList] set fromList1 [lrange $fromList $commonLength end] set toList1 [lrange $toList $commonLength end] set resultList {} foreach i $fromList1 { lappend resultList .. } eval lappend resultList $toList1 if {$resultList ne {}} { eval file join $resultList } }