# jprompts.tcl - various panels to ask the user for something
#
###############################################################################
#  Copyright 1992-2002 by Jay Sekora.  This file may be freely distributed,   #
#  modified or unmodified, for any purpose, provided that this copyright      #
#  notice is retained verbatim in all copies and no attempt is made to        #
#  obscure the authorship of this file.  If you distribute any modified       #
#  versions, I ask, but do not require, that you clearly mark any changes     #
#  you make as such and that you provide your users with instructions for     #
#  getting the original sources.                                              #
###############################################################################

### TO DO
###   checkbox to display output of unix or tcl command

package provide aq 0.1

# following has side-effect of making sure ::aq namespace is defined
namespace eval ::aq {
  namespace export {[a-z]*}
  catch {
    package require jldb
    # following likely to fail, because done by other libraries too
    namespace import ::jldb::shortcuts::*
  }
}

###############################################################################
# global variables:
#
global J_PREFS env
::aq::default J_PREFS(autoposition) 0
::aq::default J_PREFS(confirm) 1


###############################################################################
# natural-language strings:
#
::jldb::set_defaults {
  {{Enter a value:} {Enter a value:}}
  {title:prompt Prompt}
}

###############################################################################
# ::aq::prompt ?options? - prompt the user for information
# if $file, then the Tab key will do filename completion

proc ::aq::prompt { args } {
  ::aq::parse_args {
    {text "Enter a value:"}
    {default ""}
    {cancelvalue ""}
    {file 0}
    {show {}}
    {title title:prompt}
    {history ""}
  }
  
  set text [= $text]
  set title [= $title]
  
  global j_prompt
  global aq_library
  
  set doing_history ![string match "" $history]
  
  set old_focus [focus]			;# so we can restore original focus

  toplevel .pr
  wm withdraw .pr			;# lets us "update" without flashing
  					;# later undone by ::aq::dialogue
  wm title .pr $title
  
  message .pr.msg -width 300 -anchor w -text $text
  
  frame .pr.mid				;# has entry, history buttons if any
  entry .pr.mid.e -width 40
  pack .pr.mid.e -in .pr.mid -side left -fill x
  if $doing_history {
    update idletasks
    set h [winfo reqheight .pr.mid]
    set ht [.pr.mid.e cget -highlightthickness]
    set h [expr {$h - ( $ht * 2 ) - 6}]	;# um, derived empirically. :-) ######
    button .pr.mid.down -width $h -height $h -padx 0 -pady 0 \
      -bitmap @[file join $aq_library bitmaps down.xbm] -command "
      .pr.mid.e delete 0 end
      .pr.mid.e insert end \[::aq::history_down $history\]
      .pr.mid.e xview end
    "
    button .pr.mid.up -width $h -height $h -padx 0 -pady 0 \
      -bitmap @[file join $aq_library bitmaps up.xbm] -command "
      .pr.mid.e delete 0 end
      .pr.mid.e insert end \[::aq::history_up $history\]
      .pr.mid.e xview end
    "
    pack .pr.mid.down .pr.mid.up -side left
  }
  catch {.pr.mid.e configure -show $show} ;# ### NEEDS ERROR CHECKING (tk3) ###
  
  ::aq::buttonbar .pr.b -default ok -buttons [format {
    {ok OK {set j_prompt(result) [.pr.mid.e get]; destroy .pr}}
    {clear Clear {.pr.mid.e delete 0 end}}
    {cancel Cancel {set j_prompt(result) {%s}; destroy .pr}}
  } $cancelvalue]

  pack .pr.msg -side top -fill both -expand yes -padx 10
  pack .pr.mid -side top -padx 10 -pady 10
  pack .pr.b -side bottom -fill x
  pack [::aq::rule .pr -width 200] -side bottom -fill x

  .pr.mid.e delete 0 end
  .pr.mid.e insert end $default
  
  ::aq::dialogue .pr		;# position in centre of screen

  if $file {
    bind .pr.mid.e <Tab> {
      set f [%W get]
      %W delete 0 end
      %W insert end [::aq::expand_filename $f]
      %W xview end
      focus %W				;# work around Tk4 "all" binding
      break
    }
  }
  ::aq::default_button .pr.b.ok .pr.mid.e
  ::aq::cancel_button .pr.b.cancel .pr.mid.e
  
  if $doing_history {
    ::aq::history_begin $history
    bind .pr.mid.e <Up> "
      %W delete 0 end
      %W insert end \[::aq::history_up $history\]
      %W xview end
      catch {break}
    "
    bind .pr.mid.e <Down> "
      %W delete 0 end
      %W insert end \[::aq::history_down $history\]
      %W xview end
      catch {break}
    "
  }

  focus .pr.mid.e
  update
  grab .pr
  tkwait window .pr
  focus -force $old_focus	;# can't figure out a better way...
  if $doing_history {
    if {"x$j_prompt(result)" != "x$cancelvalue"} {
      ::aq::history_append $history $j_prompt(result)
    }
  }
  return $j_prompt(result)
}

###############################################################################
# ::aq::prompt_font ?options? - prompt for a font
# options are:
#   -prompt (default "Font:")
#   -pattern (default "*", but currently ignored)

proc ::aq::prompt_font { args } {
  ::aq::parse_args {
    {prompt "Font:"}
    {pattern "*"}
  }
  global j_prompt
  
  global jfont_size jfont_family jfont_bold jfont_italic
  set jfont_size 12
  set jfont_bold 0
  set jfont_italic 0
  
  toplevel .pr
  wm title .pr $prompt
  wm withdraw .pr			;# lets us "update" without flashing
  					;# later undone by ::aq::dialogue
  message .pr.msg -width 300 -text $prompt -anchor w
  frame .pr.mid
  
  ::aq::option_button .pr.mid.fam \
    -list [font families] \
    -variable jfont_family \
    -width 30
  entry .pr.mid.size -width 5 -textvariable jfont_size
  checkbutton .pr.mid.bold -text bold -variable jfont_bold
  checkbutton .pr.mid.italic -text italic -variable jfont_italic
  pack \
    [::aq::filler .pr.mid] \
    .pr.mid.fam \
    .pr.mid.size \
    .pr.mid.bold \
    .pr.mid.italic \
    [::aq::filler .pr.mid] \
    -side left -fill x
  
  ::aq::buttonbar .pr.b -default ok -buttons {
    {ok OK
      {
        set j_prompt(result) [list $jfont_family $jfont_size]
        if $jfont_bold {lappend j_prompt(result) bold}
        if $jfont_italic {lappend j_prompt(result) italic}
        destroy .pr
      }
    }
  }
  pack \
    [::aq::filler .pr] \
    .pr.msg \
    -side top -padx 10 -fill x
  pack \
    [::aq::filler .pr] \
    .pr.mid \
    [::aq::filler .pr] \
    [::aq::rule .pr] \
    .pr.b \
    -side top -fill x
  focus .pr.mid.size
  update
  ::aq::dialogue .pr
  grab .pr
  tkwait window .pr
  return $j_prompt(result)
}

###############################################################################
# ::aq::prompt_tcl - prompt for a tcl command and execute it

proc ::aq::prompt_tcl { args } {
  ::aq::parse_args {
    {history j_tcl}
  }
  global j_prompt_tcl
  append j_prompt_tcl(RESULT) {}
  
  set prompt [= prompt:tcl "Tcl Command:"]
  set title_short [= title:tcl:result_short "Tcl result"]
  set title [= title:tcl:result "Result of Tcl command"]
  
  set prompt_result [::aq::prompt \
    -history $history -text $prompt]
  if {$prompt_result != {}} then {
    set j_prompt_tcl(RESULT) $prompt_result
    set result [uplevel #0 $j_prompt_tcl(RESULT)]
    set length [string length $result]
    if {$length == 0} {
      return
    }
    if {$length < 40 && ! [string match "*\[\t\r\]*" $result]} {
      ::aq::alert -title $title_short -text $result
      return
    } else {
      ::aq::more -title $title -text $result
      return
    }
  }
}

###############################################################################
# ::aq::prompt_unix - prompt for a unix command and execute it

proc ::aq::prompt_unix { args } {
  ::aq::parse_args {
    {history j_unix}
  }
  global j_prompt_unix
  append j_prompt_unix(RESULT) {}
  
  set prompt [= prompt:unix {Unix Command:}]
  set title_short [= title:unix:result_short {Command output}]
  
  set prompt_result [::aq::prompt \
    -history $history -text $prompt]
  if {$prompt_result != {}} then {
    set j_prompt_unix(RESULT) $prompt_result
    set command $prompt_result
    set result [uplevel #0 exec $command < /dev/null]
    set length [string length $result]
    if {$length == 0} {
      ::aq::alert -text \
        [subst -nocommands -nobackslashes [= {No output from $command.}]]
      return
    }
    if {$length < 40 && ! [string match "*\[\t\r\]*" $result]} {
      ::aq::alert -title $title_short -text $result
      return
    } else {
      set title \
        [subst -nocommands -nobackslashes \
        [= title:unix:result "Output of Unix command"]]
      ::aq::more -title $title -text $result
      return
    }
  }
}

###############################################################################
# ::aq::prompt_colour_name - prompt for a colour name
### PROBLEM: LOCATION OF /usr/lib/X11/rgb.txt IS HARDCODED!
### Also, should open and process without forking off an awk
### Also, getting $w into strings is done in an ugly manner

::jldb::set_defaults {
  {prompt:colour_name {Choose a colour:}}
  {title:colour_name {Colour Name Selector}}
}

proc ::aq::prompt_colour_name { args } {
  global AQSYSINFO
  ::aq::parse_args {
    {prompt prompt:colour_name}
    {title title:colour_name}
    {default magenta}
  }
  
  set prompt [= $prompt]
  set title [= $title]
  
  global j_prompt
  global J_PREFS
  if {[lsearch [array names J_PREFS] {scrollbarside}] == -1} {
    set J_PREFS(scrollbarside) right ;# make sure it's defined
  }
  
  set old_focus [focus]			;# so we can restore original focus
  
  set w ".prompt_colour_name"
  toplevel $w
  wm title $w $title
  
  set rgbfile /usr/lib/X11/rgb.txt
  if [file isfile $rgbfile] {
    set colourlist [lsort [exec awk { NF == 4 { print $4 } } $rgbfile]]
  } else {
    set colourlist {
      aquamarine bisque black blue brown burlywood coral crimson cyan
      firebrick gold goldenrod green grey grey25 grey33 grey50 grey66
      grey75 khaki lavender magenta maroon navy orange orchid pink plum
      purple red salmon tan tomato turquoise white yellow
    }
  }
  
  set j_prompt(colour) {}
  
  label $w.l -text $prompt
  ::aq::buttonbar $w.b -default ok -orient vertical -buttons [list \
    [list ok OK [format {
        catch {set j_prompt(colour) [%s.list get [%s.list curselection]]}
        destroy %s
      } $w $w $w] \
    ] \
  ]
  frame $w.frame -width 100 -height 100 \
    -background $default -relief raised -borderwidth 2
  frame $w.list
  scrollbar $w.list.sb -command "$w.list.lb yview"
  listbox $w.list.lb -yscroll "$w.list.sb set" -relief flat
  if {!$AQSYSINFO(tinyscreen)} {
    $w.list.lb configure -width 20 -height 20
  }
  
  pack $w.list.sb [::aq::rule $w.list] \
    -side $J_PREFS(scrollbarside) -fill y
  pack $w.list.lb -in $w.list -side left -expand yes -fill both
  
  pack $w.l [::aq::rule $w] -side top -fill x
  pack $w.list [::aq::rule $w] -side left -expand yes -fill both
  pack $w.frame -side top -fill both -expand yes -padx 10 -pady 10
  pack $w.b -side bottom -fill x
  pack [::aq::rule $w] -side bottom -fill x
  
  # Fill the listbox with a list of several useful colours:
  
  foreach i $colourlist {
    $w.list.lb insert end $i
  }
  
  # Set up bindings for the browser.
  
  bind $w.list.lb <Control-q> "destroy $w"
  bind $w.list.lb <Control-c> "destroy $w"
  focus $w.list.lb
  bind $w.list.lb <Button-1> "
    $w.list.lb selection clear 0 end
    $w.list.lb selection set \[$w.list.lb nearest %y\]
    catch {
      set j_prompt(colour) \[$w.list.lb get \[$w.list.lb curselection\]\]
    }
    $w.frame config -background \$j_prompt(colour)
  "
  bind $w.list.lb <Double-Button-1> "
    $w.b.ok invoke
    break
  "
  ::aq::default_button $w.b.ok $w
  focus $w
  ::aq::dialogue $w
  tkwait window $w
  focus -force $old_focus		;# can't figure out a better way...
  if {$j_prompt(colour) == ""} {set j_prompt(colour) $default}
  return $j_prompt(colour)
}

proc ::aq::prompt_color_name \
  [info args ::aq::prompt_colour_name] \
  [info body ::aq::prompt_colour_name]

###############################################################################
# ::aq::prompt_colour_rgb - prompt for a colour RGB value
#   An eviscerated version of selcol.tcl by Sam Shen <sls@aero.org>,
#   which also let you choose HSV values

::jldb::set_defaults {
  {prompt:colour_rgb {Choose a colour:}}
  {title:colour_rgb {Colour Colour Selector}}
}

proc ::aq::prompt_colour_rgb { args } {
  ::aq::parse_args {
    {prompt prompt:colour_rgb}
    {title title:colour_rgb}
    {default {#ff80ff}}
  }
  
  set hexbyte {[0-9a-fA-F][0-9a-fA-F]}
  
  if ![string match #$hexbyte$hexbyte$hexbyte $default] {
    error "illegal RGB colour $default"
  }
  set prompt [= $prompt]
  set title [= $title]
  
  global j_prompt
  
  # extract hex values of default/current colour as decimal numbers
  scan $default "#%2x%2x%2x" j_prompt(red) j_prompt(green) j_prompt(blue)
  
  set j_prompt(flag) 0
  
  set old_focus [focus]			;# so we can restore original focus
  
  set w .prompt_rgb
  toplevel $w
  wm title $w $title
  wm minsize $w 100 100
  wm maxsize $w [winfo screenwidth $w] [winfo screenheight $w]
  
  label $w.l -text $prompt

  frame $w.patch -width 100 -height 100 -relief raised -borderwidth 2
  entry $w.value -width 12
  bind $w.value <1> {%W select from @0; %W select to end}
  frame $w.scales
  set j_prompt(flag) 1
  ::aq::_colour_rgb_make_scale $w $w.scales.red red 255 \
    [= colour_name:red Red]
  ::aq::_colour_rgb_make_scale $w $w.scales.green green 255 \
    [= colour_name:green Green]
  ::aq::_colour_rgb_make_scale $w $w.scales.blue blue 255 \
    [= colour_name:blue Blue]
  pack $w.scales.red $w.scales.green $w.scales.blue \
    -side left -fill y -expand yes
  set j_prompt(flag) 0
  
  ::aq::buttonbar $w.b -default ok -orient vertical -buttons {
    {
      ok OK { }
    }
  }
  
  $w.b.ok configure -command "
    set j_prompt(return) \[$w.value get\]
    destroy $w
  "
  
  pack $w.l
  pack [::aq::rule $w] -fill x
  pack $w.scales -expand yes -side left -fill y
  pack [::aq::rule $w] -side left -fill y
  pack $w.value -fill both
  pack $w.patch -expand yes -fill both -padx 10 -pady 10
  pack [::aq::rule $w] -fill x
  pack $w.b -fill x
  
  ::aq::_colour_rgb_update_colour $w red $j_prompt(red)
  
  ::aq::default_button $w.b.ok $w $w.value
  focus $w
  ::aq::dialogue $w
  tkwait window $w
  focus -force $old_focus		;# can't figure out a better way...
  return $j_prompt(return)
}

proc ::aq::_colour_rgb_make_scale {w name var to title} {
  global j_prompt
  
  frame $name
  scale $name.scale -to $to \
    -command "::aq::_colour_rgb_update_colour $w $var"
  if {$to >= 100} {
    $name.scale configure -length $to
  }
  $name.scale set [set j_prompt($var)]
  label $name.label -text $title
  pack $name.label -in $name
  pack $name.scale -in $name -expand yes -fill y
}

proc ::aq::_colour_rgb_update_colour {w var value} {
  global j_prompt

  if {$j_prompt(flag) == 1} {return}
  set j_prompt(flag) 1
  set j_prompt($var) $value
  set colour [format "#%02x%02x%02x" \
    $j_prompt(red) $j_prompt(green) $j_prompt(blue)]
  catch {}
  $w.patch configure -background $colour
  $w.value delete @0 end
  $w.value insert 0 $colour
  set j_prompt(flag) 0
}

###############################################################################

proc ::aq::prompt_color_rgb \
  [info args ::aq::prompt_colour_rgb] \
  [info body ::aq::prompt_colour_rgb]
