#!/bin/sh
# the next line restarts using wish \
exec wish "$0" -- "$@"

# platform specific tweaks
set tweak(button) 0		;# Extra char-space in native buttons
set tweak(handle) 0		;# Space to leave for sizing handle
set tweak(table-border) 0	;# Space to leave around table
set tweak(button-border) 4	;# Space to leave around buttons
set tweak(quit) 2		;# 0 = no quit button, 1 = QUIT/CLOSE, 2 = QUIT
set tweak(button-sticky) ew	;# ew expands buttons to width of cell
set tweak(cornerbox) 0		;# put box in corner to square off scrollbar

# figure out platform
if [catch {set platform [tk windowingsystem]}] {
  if [catch {set platform $tcl_platform(platform)}] {
    set platform unix
  }
}

switch -- $platform {
  aqua {
    set tweak(button) 2
    set tweak(handle) 16
    set tweak(table-pad) 16
    set tweak(table-relief) sunken
    set tweak(table-border) 1
    set tweak(column-relief) sunken
    set tweak(column-border) 1
    unset tweak(button-sticky)
    set tweak(cornerbox) 1
    set tweak(quit) 0
  }
  win32 {
    set tweak(button) 1
    set tweak(handle) 20
  }
}

proc make_listboxes {tn height colwidth format} {
  global boxes boxcols tweak
  set maxcolwidth [expr $colwidth * 2]

  catch {unset boxcols($tn)}
  catch {unset boxes($tn)}

  set yscrollset 0
  set i -1
  set c 0
  foreach {name type width} $format {
    lappend boxcols($tn) $name
    incr i
    if {[string match "@*" $name] || $width == 0} {
      lappend boxes($tn) ""
      continue
    }

    set weight $width
    if {$width > $maxcolwidth} {
      set width $maxcolwidth
    }

    set button $tn.name$i
    set lb $tn.list$i
    set sb $tn.scroll$i
    lappend boxes($tn) $lb
    grid [
      button $button -text $name -command "pressed $tn $i $type" -pady 2
    ] -column $c -row 0
    if [info exists tweak(button-sticky)] {
      grid configure $button -sticky $button-sticky
    }
    grid [
      listbox $lb -height $height -width $width \
		  -xscrollcommand "$sb set" \
		  -selectmode extended \
		  -yscrollcommand "scroll_set $tn"
    ] -column $c -row 1 -sticky nsew
    if [info exists tweak(column-border)] {
      $lb configure -borderwidth $tweak(column-border)
    }
    if [info exists tweak(column-relief)] {
      $lb configure -relief $tweak(column-relief)
    }
    grid [
      scrollbar $sb -orient horizontal -command "$lb xview"
    ] -column $c -row 2 -sticky ew
    grid columnconfigure $tn $c -weight $weight
    incr c
  }
  if $tweak(cornerbox) {
    grid [
      frame $tn.plonk -border 1 -relief sunken
    ] -column $c -row 2 -sticky nsew
  }
  grid [
    scrollbar $tn.scroll -orient vertical -command "scroll_all $tn"
  ] -column $c -row 1 -sticky ns
  grid rowconfigure $tn 1 -weight 1
}

proc scroll_all {table args} {
  global boxes

  foreach lb $boxes($table) {
    if [string length $lb] {
      eval [concat [list $lb yview] $args]
    }
  }
}

proc scroll_set {table first last} {
  global boxes

  $table.scroll set $first $last

  foreach lb $boxes($table) {
    if [string length $lb] {
      $lb yview moveto $first
    }
  }
}

proc fill_boxes {table data} {
  global boxdata
  set boxdata($table) $data
  repaint $table
}

proc repaint {table} {
  global boxes boxcols boxdata boxfilter boxcmds
  foreach lb $boxes($table) {
    if [string length $lb] {
      $lb delete 0 end
    }
  }
  foreach row $boxdata($table) {
    if [info exists boxfilter($table)] {
      set match 1
      foreach {col key} $boxfilter($table) {
        if {[lsearch -exact $key [lindex $row $col]] == -1} {
	  set match 0
        }
      }
      if !$match {
        continue
      }
    }
    foreach lb $boxes($table) cell $row {
      if [string length $lb] {
        $lb insert end $cell
      }
    }
  }
  if [info exists boxcmds($table)] {
    foreach cmd $boxcmds($table) {
      eval $cmd $table
    }
  }
}

proc addfilter {table col val} {
  global boxfilter
  if [info exists boxfilter($table)] {
    foreach {c v} $boxfilter($table) {
      if {"$c" == "$col" && "$v" == "$val"} return
    }
  }
  lappend boxfilter($table) $col $val
  repaint $table
}

proc unfilter {table} {
  global boxfilter
  catch {unset boxfilter($table)}
  repaint $table
}

proc resort {table col type} {
  global boxdata

  set boxdata($table) [lsort -index $col -$type $boxdata($table)]
  repaint $table
}

proc pressed {table col type} {
  global boxes

  set lb [lindex $boxes($table) $col]
  if ![string length $lb] return

  set list [$lb curselection]

  if ![llength $list] {
    resort $table $col $type
  } else {
    foreach s $list {
      set k [$lb get $s]
      if {![info exists key] || [lsearch -exact $key $k] == -1} {
        lappend key $k
      }
    }
    addfilter $table $col $key
  }
}

proc dump_sel {table} {
  global boxes sep boxdata

  set textbox [textwindow $table]

  foreach lb $boxes($table) {
    if [string length $lb] {
      set l [$lb curselection]
      if [string length $l] break
      if ![info exists len] {
        set len [$lb size]
      }
    }
  }

  $textbox delete 1.0 end

  if [string length $l] {
    foreach s $l {
      add_row_to $textbox [get_row $table $s]
    }
  } else {
    for {set s 0} {$s < $len} {incr s} {
      add_row_to $textbox [get_row $table $s]
    }
  }
}

proc get_row {table i} {
  global boxes

  foreach lb $boxes($table) {
    if [string length $lb] {
      lappend row [$lb get $i]
    }
  }

  return $row
}

proc add_row_to {tb row} {
  global sep sepchar

  if ![info exists sepchar] {
    set sepchar [lindex $sep 0]
  }

  if [string length [$tb get 1.0 1.end]] {
    $tb insert end "\n"
  }
  $tb insert end [join $row $sepchar]
}

set textseq 0
proc textwindow {t} {
  global textwin boxfilter textseq

  if {![info exists textwin($t)] || ![winfo exists $textwin($t)] } {
    if ![info exists textwin($t)] {
      set textwin($t) .textwin$textseq
      incr textseq
    }
    set win $textwin($t)

    toplevel $win
    wm title $win "Selected rows..."

    grid [
      text $win.text \
           -xscrollcommand "$win.sx set" \
           -yscrollcommand "$win.sy set" \
	   -wrap none
    ] -row 0 -column 0 -sticky nsew
    grid [
      scrollbar $win.sx -orient horizontal -command "$win.text xview"
    ] -row 1 -column 0 -sticky ew
    grid [
      scrollbar $win.sy -orient vertical -command "$win.text yview"
    ] -row 0 -column 1 -sticky ns
    grid rowconfigure $win 0 -weight 1
    grid columnconfigure $win 0 -weight 1
  }
  return $textwin($t).text
}

proc onrepaint {table args} {
  global boxcmds
  lappend boxcmds($table) $args
}

proc setup_window {window title} {
  global tweak

  wm title $window $title
  if {"$window" == "."} {
    set w ""
  } else {
    set w $window
  }

  set tbl $w.table

  pack [frame $w.cmd -border $tweak(button-border)] -side bottom -fill x
  pack [
    frame $tbl -border $tweak(table-border)
  ] -side top -fill both -expand 1
  if [info exists tweak(table-pad)] {
    pack configure $tbl -padx $tweak(table-pad) -pady $tweak(table-pad)
  }
  if [info exists tweak(table-relief)] {
    $tbl configure -relief $tweak(table-relief)
  }

  if {$tweak(handle) > $tweak(button-border)} {
    pack configure $w.cmd -padx [expr {$tweak(handle) - $tweak(button-border)}]
#   set fill [expr $tweak(handle) - $tweak(button-border)]
#   pack [frame $w.cmd.handle -width $fill -height $fill] -side right
  }

  if $tweak(quit) {
    if {"$window" == "."} {
      if {$tweak(quit) > 1} {
        set cmd "destroy ."
        set txt QUIT
      } else {
	set command "wm withdraw ."
        set txt CLOSE
      }
    } else {
      set cmd "destroy $window"
      set txt CLOSE
    }
    pack [button $w.cmd.q -text $txt -command $cmd] -side right
  }

  pack [button $w.cmd.d -text Dump -command "dump_sel $tbl"] -side right

  pack [
    button $w.cmd.a -text "Show all" -command "unfilter $tbl"
  ] -side left
  pack [label $w.cmd.filter -text {}] -side left
  onrepaint $tbl showfilter $w.cmd.filter

  return $tbl
}

proc showfilter {label filter} {
  global boxfilter boxcols

  set msg ""
  if [info exists boxfilter($filter)] {
    foreach {col key} $boxfilter($filter) {
      set name [lindex $boxcols($filter) $col]
      if {[llength $key] == 1} {
        lappend msgs "$name is '$key'"
      } else {
        lappend msgs "$name is ('[join $key "' or '"]')"
      }
    }
    set msg [join $msgs " and "]
  }
  $label configure -text $msg
}

proc read_data {file sep com {_data ""}} {
  if [string length $_data] {
    upvar 1 $_data data
  }
  while {[gets $file line] >= 0} {
    if [string length $com] {
      if [string match $com* $line] {
	continue
      }
    }
    lappend data [split $line $sep]
  }
  if [info exists data] {
    return $data
  } else {
    return ""
  }
}

proc read_file {name sep com {_data ""}} {
  if [string length $_data] {
    upvar 1 $_data data
  }
  if [catch {set fp [open $name r]} err] {
    puts stderr $err
    exit 2
  }
  return [read_data $fp $sep $com data]
}

proc usage {msg} {
  global argv0 usage

  puts stderr "$argv0: $msg"
  set cmd $argv0

  regsub {.*/} $cmd {} cmd
  puts stderr "Usage: $cmd $usage"
}

set usage {[-F fs] [-C cs] [-h height] [-w width] [-f file]... label... [-- file...]
	-F fs	set the field separator
	-C cs	set the comment string
	@label	don't display this field}


set sep " \t"
set com ""
set colwidth 10
set colheight 10
set finished 0
foreach arg $argv {
  if $finished {
    if ![info exists title] { set title "VDB ($arg...)" }
    read_file $arg $sep $com data
    continue
  }
  if [info exists nextvar] {
    set $nextvar $arg
    unset nextvar
    continue
  }
  if [info exists nextact] {
    switch $nextact {
      file {
        if ![info exists title] { set title "VDB ($arg...)" }
        read_file $arg $sep $com data
      }
    }
    unset nextact
    continue
  }
  switch -glob -- $arg {
    -w {
      set nextvar colwidth
    }
    -h {
      set nextvar colheight
    }
    -F {
      set nextvar sep
    }
    -C {
      set nextvar com
    }
    -- {
      set finished 1
    }
    -f {
      set nextact file
    }
    -* {
      usage "Unknown option $arg"
      exit 2
    }
    default {
      lappend cols $arg
    }
  }
}

if ![info exists cols] {
  usage "No column labels provided"
  exit 2
}

if ![info exists data] {
  set title "VDB (standard input)"
  read_data stdin $sep $com data
}

if ![info exists data] {
  exit 0
}

set col 0
foreach label $cols {
  if {[string match {-*} $label]} {
    set maxwidth($col) 0
  } elseif {[string length $label] <= 0} {
    set maxwidth($col) 0
  } else {
    set maxwidth($col) [string length $label]
    incr maxwidth($col) $tweak(button)
  }
  set coltype($col) unknown
  incr col
}
set numcols $col

foreach row $data {
  while {[llength $row] < $numcols} {
    lappend row ""
  }
  lappend newdata $row
}

set rows 0
foreach row $newdata {
  set col 0
  foreach cell $row {
    if {$col >= $numcols} break
    set len [string length $cell]
    if {$len > $maxwidth($col)} {
      set maxwidth($col) $len
    }
    if $len {
      if {"$coltype($col)" != "ascii"} {
        if [string is integer -strict $cell] {
          set coltype($col) integer
        } else {
          set coltype($col) ascii
        }
      }
    }
    incr col
  }
  incr rows
}

set col 0
foreach name $cols {
  set type $coltype($col)
  set width $maxwidth($col)
  if {"$type" == "unknown"} {
    set name "@$name"
    set type "ascii"
    set width 0
  }
  lappend format $name $type $width
  incr col
}

if {$rows < $colheight} {
  set colheight $rows
}

set tbl [setup_window . $title]
make_listboxes $tbl $colheight $colwidth $format
fill_boxes $tbl $newdata