#
# 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
}


# in:  f = (partial) file name
# out:   "" (NULL) if no matches
#        full name if exactly one match
#        list      w/first==longest match, if multiple matches

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

   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
   if {$posn>0 && $ll} {
      # can't use dirname because it expands ~'s
      set tail [string range $f 0 [expr $posn-1]]$tail
   }

   if {$ll<2} {return $tail} {return "$tail $l"}
}


#return [expr [string first $c "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"]!=-1]

proc isalpha {c} {
   return [regexp -nocase {[a-z]} $c]
}
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} {
   set l2 ""
   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
   exclam comma
}

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
}

proc lmatch {mode list {pattern ""}} {
   if {$pattern==""} {set pattern $list; set list $mode; set mode -glob}
   return [expr [lsearch $mode $list $pattern]!=-1]
}


# 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

bind Text <B1-Motion> {textb1motion %W @%x,%y}
bind Text <ButtonRelease-1> {set text(txnd) 0}
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
   }
}

###

# button 2 pasting _also_ (outsmarts conflict with dragging)

set text(b2-time) 0
set text(b2-x) 0

foreach c {Entry Text} {
   bind $c <Button-2> {+set text(b2-time) %t; set text(b2-x) %x}
}
bind Entry <ButtonRelease-2> {+
   if {[expr abs(%t-$text(b2-time))]<500 && [expr abs(%x-$text(b2-x))]<3} {
      catch {%W insert insert [selection get]; tk_entrySeeCaret %W}
   }
}
bind Text <ButtonRelease-2> {+
   if {[expr abs(%t-$text(b2-time))]<500 && [expr abs(%x-$text(b2-x))]<3} {
      catch {%W insert insert [selection get]; %W yview -pickplace insert}
   }
}


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

   bind $w <Control-KeyPress-h> "
      if \[catch {$w delete sel.first sel.last}\] \
         {$w delete \[expr \[$w index insert\]-1\]}
      tk_entrySeeCaret $w
   "
   bind $w <KeyPress-Delete> "
      if \[catch {$w delete sel.first sel.last}\] \
         {$w delete \[expr \[$w index insert\]-1\]}
      tk_entrySeeCaret $w
   "
   bind $w <KeyPress-BackSpace> "
      if \[catch {$w delete sel.first sel.last}\] \
         {$w delete \[expr \[$w index insert\]-1\]}
      tk_entrySeeCaret $w
   "
   # mac like
   bind $w <KeyPress> "catch {$w delete sel.first sel.last}; [bind Entry <Any-Key>]"
   bind $w <Double-Button-1> "$w select from 0; $w select to end"
}


proc winstderr {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
}

