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


#
# UNIXish
#

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 ""}} {
   global file
   if {$l==""} {set l $file(globList)}

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


# 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 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 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 setinsert {l i e} {
   return [linsert [lfilter $e $l] $i $e]
}

proc lfilter {p l} {
   set l2 ""

   foreach i $l {
      if ![string match $p $i] "lappend l2 $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
}

proc name2char {c} {
   global name2charList

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

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

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\]-1\]}
   "
   bind $w <KeyPress-Delete> "
      if \[catch {$w delete sel.first sel.last}\] \
         {$w delete \[expr \[$w index insert\]-1\]}
   "
   bind $w <KeyPress-BackSpace> "
      if \[catch {$w delete sel.first sel.last}\] \
         {$w delete \[expr \[$w index insert\]-1\]}
   "
   # 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"
}


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

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

# numeric sort--should be builtin

proc lnsort {l} {
   if {$l==""} {return ""}

   foreach i $l {
      append l2 [format %015d $i]
   }
   set l2 [lsort $l2]
   foreach $i l2 {
      append l3 [format %d $i]
   }

   return $l3
}

# swiped from mkTextSearch w
#
# The utility procedure below searches for all instances of a
# given string in a text widget and applies a given tag to each
# instance found.
# Arguments:
#
# w -		The window in which to search.  Must be a text widget.
# string -	The string to search for.  The search is done using
#		exact matching only;  no special characters.
# tag -		Tag to apply to each instance of a matching string.

proc TextSearch {w string tag} {
   set cnt 0

    $w tag remove search 0.0 end
    scan [$w index end] %d numLines
    set l [string length $string]
    for {set i 1} {$i <= $numLines} {incr i} {
	if {[string first $string [$w get $i.0 $i.1000]] == -1} {
	    continue
	}
	set line [$w get $i.0 $i.1000]
	set offset 0
	while 1 {
	    set index [string first $string $line]
	    if {$index < 0} {
		break
	    }
	    incr offset $index
	    $w tag add $tag $i.[expr $offset] $i.[expr $offset+$l]
            incr cnt
	    incr offset $l
	    # below bug fix from mkSearch.tcl
	    set line [string range $line [expr $index+$l] 1000]
	}
    }
   return $cnt
}


# modified to handle regexp's and return # of matches -TAP

proc regexpTextSearch {w string tag {case 0}} {
   set cnt 0
   if {$case} {set case "-nocase"} {set case ""}

    $w tag remove search 0.0 end
    scan [$w index end] %d numLines

    for {set i 1} {$i <= $numLines} {incr i} {
      set line [$w get $i.0 $i.1000]
      set offset 0
      while 1 {
         if {![eval regexp $case -indices {"$string"} {"$line"} match]} break
         scan $match "%d %d" index iend
         $w tag add $tag $i.[expr $offset+$index] $i.[expr $offset+$iend+1]
         set line [string range $line [expr $iend+1] end]
         incr offset [expr $iend+1]
         incr cnt
      }
   }
   return $cnt
}

