#
# some functions which should be part of Tcl, but aren't
#
# Tom Phelps (phelps@cs.Berkeley.EDU)
#


#
# UNIXish
#


# pipeexp - expand file names in a pipe
proc pipeexp {p} {
   set p [string trim $p]

   set expp ""
   foreach i $p {
      if {[regexp {^[.~/$]} $i]} {lappend expp [fileexp $i]} \
      else {lappend expp $i}
   }
   return $expp
}

# fileexp perform file spec expansion: ~ . .. $
proc fileexp {f} {
   global env

   set f [string trim $f]
   set l [string length $f]
   set expf ""

   set dir [pwd]
   foreach i [split $f /] {
      switch -glob $i {
         "" {set dir ""}
         ~  {set dir $env(HOME)}
	 $* {set val $env([string trim [string range $i 1 end] ()])
             if {[string match /* $val]} {set dir $val} {append expf /$val)}}
         .  {set dir $dir}
	 .. {set dir [file dirname $dir]}
	 default {append expf /$i}
      }
   }

   return $dir$expf
}

proc filecomplete {f} {
   if [string match */ $f] return
   set expf [fileexp [file dirname $f]]/[file tail $f]
   set l [glob -nocomplain $expf*]
   set ll [llength $l]

   set tail [file tail $f]
   if {!$ll} {
      # maybe indicate that partial name not good
#     set tail ""
   } elseif {$ll==1} {
      set tail [file tail $l]
      if {[file isdirectory $l]} {append tail /}
   } else {
      # determine the longest common prefix
      set lf [lfirst $l]; set lfl [string length $lf]
      set last $lfl
      set ni [expr [string last / $lf]+1]
      foreach i $l {
         set il [string length $i]
         for {set j $ni} {$j<=$last} {incr j} {
            if {[string range $lf $j $j]!=[string range $i $j $j]} break
         }
         set last [min $last [expr $j-1]]
      }
      set tail [file tail [string range [lfirst $l] 0 $last]]
   }

   # compose original directory specification with (possibly) new tail
   set posn [string last [file tail $f] $f]
   if {$posn>0} {
      # can't use dirname because it expands ~'s
      return [string range $f 0 [expr $posn-1]]$tail
   } else {return $tail}
}


proc isalpha {c} {
   return [expr [string first $c "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"]!=-1]
}
proc isnum {c} {return [expr [string first $c "123456790"]!=-1]}
proc isalphanum {c} {return [expr [isalpha $c]||[isnum $c]]}

proc stringicap {s} {return [string toupper [string range $s 0 0]][string range $s 1 end]}

proc tr {s c1 c2} {
   foreach i [split $s $c1] {
      append l2 $i $c2
   }
   return [string trimright $l2 $c2]
}


# reverse glob
#    pass expanded filename, list of shortenings
proc bolg {f {l ""}} {
   if {$l==""} {global file; set l $file(globList)}

   foreach i $l {
      if [regsub ([glob -nocomplain $i])(.*) $f "$i\\2" short] {return $short}
   }
   return $f
}


proc setinsert {l i e} {
   return [linsert [lfilter $e $l] $i $e]
}
# short enought to just inline: if [lsearch $l $e]==-1 {lappend $l $e}
#proc setinsert {l e} {
#   if {[lsearch $l $e]==-1} {
#      return [lappend $l $e]
#   } else {
#      return $l
#   }
#}


proc unsplit {l c} {
   foreach i $l {
      append l2 $i $c
   }
#   return [string trimright $l2 $c]
   return [string range $l2 0 [expr [string length $l2]-2]]
}

proc bytes2prefix {x} {
   set k 1024
   set mb [expr $k*$k]
   set gb [expr $k*$mb]
   set bp 10

   return [
   if {$x<$k} {format " $x bytes"} \
   elseif {$x<[expr $k*$bp]} {format "%0.1f K" [expr ($x+0.0)/$k]} \
   elseif {$x<$mb} {format "[expr $x/$k] K"} \
   elseif {$x<[expr $mb*$bp]} {format "%0.1f MB" [expr ($x+0.0)/$mb]} \
   elseif {$x<$gb} {format "[expr $x/$mb] MB"} \
   elseif {$x<[expr $gb*$bp]} {format "%0.1f GB" [expr ($x+0.0)/$gb]} \
   else {format "[expr $x/$gb] GB"}
   ]
}

proc bytes2prefix {x} {
   set pfx {bytes KB MB GB TB QB}
   set bp 20
   set k 1024
   set sz $k

   set y BIG
   for {set i 0} {$i<[llength $pfx]} {incr i} {
      if {$x<$sz} {
         set y [format " %0.0f [lindex $pfx $i]" [expr $x/($sz/$k)]]
         break
      } elseif {$x<[expr $sz*$bp]} {
         set y [format " %0.1f [lindex $pfx [expr $i+1]]" [expr ($x+0.0)/$sz]]
         break
      }

      set sz [expr $sz*$k]
   }

   return $y
}



#
# Lispish
#

# unfortunately, no way to have more-convenient single quote form
proc quote {x} {return $x}

proc uniqlist {l} {
   set l1 [lsort $l]
   set e ""
   set l2 ""
   foreach i $l1 {
      if {$e!=$i} {
         set e $i
         lappend l2 $e
      }
   }
   return $l2
}

proc uniqilist {l} {
   set l1 [lsort -integer $l]
   set e ""
   set l2 ""
   foreach i $l1 {
      if {$e!=$i} {
         set e $i
         lappend l2 $e
      }
   }
   return $l2
}


proc min {args} {
   set x [lindex $args 0]
   foreach i $args {
      if {$i<$x} {set x $i}
   }
   return $x
}

proc avg {args} {
   set sum 0.0

   if {$args==""} return
   
   foreach i $args {set sum [expr $sum+$i]}
   return [expr ($sum+0.0)/[llength $args]]
}

proc max {args} {
   set x [lindex $args 0]
   foreach i $args {
      if {$i>$x} {set x $i}
   }
   return $x
}

proc abs {x} {
   if {$x<0} {return [expr 0-$x]} {return $x}
}


proc lfirst {l} {return [lindex $l 0]}
proc lsecond {l} {return [lindex $l 1]}
proc lthird {l} {return [lindex $l 2]}
proc lfourth {l} {return [lindex $l 3]}
# five is enough to get all pieces of `configure' records
proc lfifth {l} {return [lindex $l 4]}
proc lsixth {l} {return [lindex $l 5]}
proc lseventh {l} {return [lindex $l 6]}
proc lrest {l} {return [lrange $l 1 end]}

proc llast {l} {
   set end [llength $l]
   if {!$end} {return ""}
   return [lindex $l [expr $end-1]]
}

proc setappend {l e} {
   return "[lfilter $e $l] $e"
}

proc lfilter {p l} {
   set l2 ""

   foreach i $l {
      if ![string match $p $i] "lappend l2 [list $i]"
   }
   return $l2
}

proc lassoc {l k} {

   foreach i $l {
      if {[lindex $i 0]==$k} {return [lindex $i 1]}
   }
}

# like lassoc, but search on second element, returns first
proc lbssoc {l k} {

   foreach i $l {
      if {[lindex $i 1]==$k} {return [lindex $i 0]}
   }
}

proc lreverse {l} {
   set l2 ""
   for {set i [expr [llength $l]-1]} {$i>=0} {incr i -1} {
      lappend l2 [lindex $l $i]
   }
   return $l2
}


#
# X-ish
#

proc geom2posn {g} {
   regexp {(=?[0-9]+x[0-9]+)([-+]+[0-9]+[-+]+[0-9]+)} $g both d p
   return $p
}



#
# Tcl-ish
#


# translate ascii names into single character versions
# this should be a bind option

set name2charList {
   minus plus percent ampersand asciitilde at less greater equal
   numbersign dollar asciicircum asterisk quoteleft quoteright
   parenleft parenright bracketleft bracketright braceleft braceright
   semicolon colon question slash bar period underscore backslash
}

proc name2char {c} {
   global name2charList

   if {[set x [lsearch $name2charList $c]]!=-1} {
       return [string index "-+%&~@<>=#$^*`'()\[\]{};:?/|._\\" $x]
   } else {return $c}
}

# 0=none="", 1=Shift=S, 2=Alt?, 4=Ctrl=C, 8=meta=M
proc key_state2mnemon {n} {
   set mod ""

   if {$n>=8} {append mod M; set n [expr $n-8]}
   if {$n>=4} {append mod C; set n [expr $n-4]}
   if {$n>=2} {append mod A; set n [expr $n-2]}
   if {$n} {append mod S}
   
   return $mod
}


# remove all char c from string s

proc stringremove {s {c " "}} {
   set s2 ""
   set slen [string length $s]

   for {set i 0} {$i<$slen} {incr i} {
      set sc [string index $s $i]
      if [string match $c $sc]==0 {append s2 $sc}
   }
   return $s2
}

proc tk_listboxNoSelect args {
    foreach w $args {
        bind $w <Button-1> {format x}
	bind $w <B1-Motion> {format x}
	bind $w <Shift-1> {format x}
	bind $w <Shift-B1-Motion> {format x}
    }
}

# could do with "listbox select&highlight pattern"

proc listboxshowS {lb s {first 0} {cnstr yes}} {
   set sz [$lb size]

   for {set i $first} {$i<$sz} {incr i} {
      if [string match $s [$lb get $i]] {
         listboxshowI $lb $i $cnstr
         return $i
      }
   }
   return -1
}

proc listboxshowI {lb high {cnstr yes}} {
#   if {$high>=[$lb size] || $high<0} return
   set high [max 0 [min $high [expr [$lb size]-1]]]

   set hb [lindex [split [lindex [$lb configure -geometry] 4] x] 1]
   set hx [max 0 [expr [$lb size]-$hb]]
   if {$cnstr=="yes"} {set hl [expr $high<$hb?0:[min $high $hx]]} {set hl $high}
   $lb select from $high
   $lb yview $hl
}

proc listboxreplace {lb index new} {
   $lb delete $index
   $lb insert $index $new
   # don't lose selection
   $lb select from $index
}


# preserves selection, yview

proc listboxmove {l1 l2} {
   listboxcopy $l1 $l2
   $l1 delete 0 end
}

proc listboxcopy {l1 l2} {

   $l2 delete 0 end
   listboxappend $l1 $l2
   catch {$l2 select from [$l1 curselection]}
# use NEW yview to keep same yview position
#   catch {$l2 yview [$l1 yview]}
}

proc listboxappend {l1 l2} {

   set size [$l1 size]

   for {set i 0} {$i<$size} {incr i} {
      $l2 insert end [$l1 get $i]
   }
}


### extend selection beyond window border, by Paul Raines

set text(txnd) 0
set text(delay) 100
proc textb1motion { w loc } {
   global text

   set ypos [lindex [split $loc ","] 1]
   if {$ypos > [winfo height $w]} {
      if {!$text(txnd)} {after $text(delay) textextend $w}
      set text(txnd) 1
      set text(direction) down
   } elseif {$ypos < 0} {
      if {!$text(txnd)} {after $text(delay) textextend $w}
      set text(txnd) 1
      set text(direction) up
   } else {
      set text(txnd) 0
      set text(direction) 0
   }

   if {!$text(txnd)} {
      tk_textSelectTo $w $loc
   }
}

proc textextend { w } {
   global text

   if {$text(txnd)} {
      if {$text(direction) == "down"} {
         tk_textSelectTo $w sel.last+1l
         $w yview -pickplace sel.last+1l
      } elseif {$text(direction) == "up"} {
         tk_textSelectTo $w sel.first-1l
         $w yview -pickplace sel.first-1l
      } else return

      after $text(delay) textextend $w
   }
}

###


proc emacsbind {w} {
   bind $w <Enter> "focus $w"
   bind $w <Control-KeyPress-d> "$w delete \[$w index insert\]"
   bind $w <Control-KeyPress-k> "$w delete \[$w index insert\] end"
   bind $w <Control-KeyPress-f> "$w icursor \[expr \[$w index insert\]+1\]"
   bind $w <Control-KeyPress-b> "$w icursor \[expr \[$w index insert\]-1\]"
   bind $w <Control-KeyPress-a> "$w icursor 0"
   bind $w <Control-KeyPress-e> "$w icursor end"

   bind $w <Control-KeyPress-h> "
      if \[catch {$w delete sel.first sel.last}\] \
         {$w delete \[expr \[$w index insert\]\]}
   "
   bind $w <KeyPress-Delete> "
      if \[catch {$w delete sel.first sel.last}\] \
         {$w delete \[expr \[$w index insert\]\]}
   "
   bind $w <KeyPress-BackSpace> "
      if \[catch {$w delete sel.first sel.last}\] \
         {$w delete \[expr \[$w index insert\]\]}
   "
   # mac like
   bind $w <Double-Button-1> "$w select from 0; $w select to end"
# conflicts with dragging
#   bind $w <Button-2> "$w insert insert \[selection get\]"
}


proc winerrout {w msg} {
   if {![winfo exists $w]} return

   set fg [lindex [$w configure -foreground] 4]
   set bg [lindex [$w configure -background] 4]

   winstdout $w $msg
   $w configure -foreground $bg -background $fg
   update idletasks; after 500
   $w configure -foreground $fg -background $bg
}

proc winstdout {w msg} {
   global winout

   if {![winfo exists $w]} return
   $w configure -text $msg
   set winout(lastMessage$w) $msg
}


# need a selection of sound, and don't use stdout!

proc beep {} {
   puts -nonewline stdout "\007"; flush stdout
}

proc tk_textSelectTo {w index} {
    global tkPriv
 
    if [catch {$w index anchor}] {
        $w mark set anchor $index
    }
    case $tkPriv(selectMode) {
        char {
            if [$w compare $index < anchor] {
                set first $index
                set last anchor
            } else {
                set first anchor
                set last [$w index $index+1c]
            }
        }
        word {
            if [$w compare $index < anchor] {
                set first [$w index "$index wordstart"]
                set last [$w index "anchor wordend"]
            } else {
                set first [$w index "anchor wordstart"]
                set last [$w index "$index wordend"]
            }
        }
        line {
            if [$w compare $index < anchor] {
                set first [$w index "$index linestart"]
                set last [$w index "anchor lineend + 1c"]
            } else {
                set first [$w index "anchor linestart"]
                set last [$w index "$index lineend + 1c"]
            }
        }
    }
    $w tag remove sel 0.0 $first
    $w tag add sel $first $last
    $w tag remove sel $last end
}

# The procedure below is invoked to backspace over one character in
# a text widget.  The name of the widget is passed as argument.
 
proc tk_textBackspace w {
    $w delete insert-1c insert
}
proc tk_textIndexCloser {w a b c} {
    set a [$w index $a]
    set b [$w index $b]
    set c [$w index $c]
    if [$w compare $a <= $b] {
        return 1
    }
    if [$w compare $a >= $c] {
        return 0
    }
    scan $a "%d.%d" lineA chA
    scan $b "%d.%d" lineB chB
    scan $c "%d.%d" lineC chC
    if {$chC == 0} {
        incr lineC -1
        set chC [string length [$w get $lineC.0 $lineC.end]]
    }
    if {$lineB != $lineC} {
        return [expr {($lineA-$lineB) < ($lineC-$lineA)}]
    }
    return [expr {($chA-$chB) < ($chC-$chA)}]
}
proc tk_textResetAnchor {w index} {
    global tkPriv
    if {[$w tag ranges sel] == ""} {
        set tkPriv(selectMode) char
        $w mark set anchor $index
        return
    }
    if [tk_textIndexCloser $w $index sel.first sel.last] {
        if {$tkPriv(selectMode) == "char"} {
            $w mark set anchor sel.last
        } else {
            $w mark set anchor sel.last-1c
        }
    } else {
        $w mark set anchor sel.first
    }
}
