home *** CD-ROM | disk | FTP | other *** search
/ MacFormat 1999 April / macformat-075.iso / Shareware Plus / Applications / Alpha / Tcl / SystemCode / CorePackages / prompts.tcl < prev    next >
Encoding:
Text File  |  1998-11-21  |  15.0 KB  |  471 lines  |  [TEXT/ALFA]
  1. ## -*-Tcl-*-
  2.  # ###################################################################
  3.  #  Vince's Additions - an extension package for Alpha
  4.  # 
  5.  #  FILE: "prompts.tcl"
  6.  #                                    created: 27/1/98 {11:14:34 am} 
  7.  #                                last update: 18/11/98 {9:44:34 pm} 
  8.  #  Author: Vince Darley
  9.  #  E-mail: <darley@fas.harvard.edu>
  10.  #    mail: Division of Engineering and Applied Sciences, Harvard University
  11.  #          Oxford Street, Cambridge MA 02138, USA
  12.  #     www: <http://www.fas.harvard.edu/~darley/>
  13.  #  
  14.  # Copyright (c) 1998  Vince Darley
  15.  # 
  16.  # See the file "license.terms" for information on usage and redistribution
  17.  # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  18.  # 
  19.  # General purpose status-line completion procedures.  Currently
  20.  # used by Tcl, TeX and Bib modes.  Will go in Alpha's 'CorePackages'
  21.  # directory with the next patch release.
  22.  # 
  23.  # Also contains a set of procedures for prompting the user
  24.  # for _small_ pieces of information, with validation of type
  25.  # for values entered.
  26.  # ###################################################################
  27.  ##
  28.  
  29. # auto-loading extension.
  30. alpha::extension prompts 0.1.1
  31.  
  32. namespace eval prompt {}
  33.  
  34. # ◊◊◊◊ Status line completion ◊◊◊◊ #
  35.  
  36. ## 
  37.  # -------------------------------------------------------------------------
  38.  # 
  39.  # "prompt::statusLineComplete" --
  40.  # 
  41.  #  Optional flags this proc can take
  42.  #  
  43.  #  -nobackup             : can't use left-arrow to remove a char
  44.  #  -nocache              : don't cache the list of completions 
  45.  #  -nomatchiserror       : if nothing matches, we abort
  46.  #  -initialpatt <string> : start with this string
  47.  #  -preeval <script>     : evaluate this script first at global scope
  48.  #  -posteval <script>    : evaluate this script afterwards at global scope
  49.  #  -tryuppercase         : if we have no matches, check if the user was
  50.  #                        : too lazy to use the shift key!
  51.  # -------------------------------------------------------------------------
  52.  ##
  53. proc prompt::statusLineComplete {what completeWith args} {
  54.     global __keysSoFar __startIndex __lastMatchesDisplayed __lastMatches \
  55.       __oldCurr
  56.     set __keysSoFar {}
  57.     set __startIndex 0
  58.     set __lastMatchesDisplayed {}
  59.     set __oldCurr ""
  60.     
  61.     catch {unset __lastMatches}
  62.     
  63.     message ""
  64.     set patt ""
  65.  
  66.     getOpts [list -preeval -posteval -initialpatt]
  67.     if {[info exists opts(-initialpatt)]} {
  68.         set patt $opts(-initialpatt)
  69.     }
  70.     set pos [getPos]
  71.     
  72.     if {[info exists opts(-preeval)]} {
  73.         catch {uplevel \#0 $opts(-preeval)}
  74.     }
  75.     catch {status::prompt "${what}: $patt" prompt::_complete anything}
  76.     if {[info exists opts(-posteval)]} {
  77.         catch {uplevel \#0 $opts(-posteval)}
  78.     }
  79.     catch {unset __lastMatches}
  80.     # we're done
  81.     if {[info exists __completed]} {
  82.         return $__completed
  83.     }
  84.     message "Aborted: $patt"
  85.     goto $pos
  86.     error "Aborted: $patt"
  87. }
  88.  
  89. ## 
  90.  # -------------------------------------------------------------------------
  91.  # 
  92.  # "prompt::_complete" --
  93.  # 
  94.  # Summary: 
  95.  # 
  96.  #      Hit 'space' or 'return' or '1' to hit the first completion in
  97.  # the list, 2-9 to select subsequent ones, 'tab' to scroll the list,
  98.  # or any character to complete further.  Hit 'left-arrow' to delete
  99.  # a character from the current entry.  You can also use 'delete' to
  100.  # delete a character, except it's not shown in the display until you
  101.  # add a character.  This is a limitation of Alpha.
  102.  # 
  103.  # Details:
  104.  # 
  105.  #  The mods to this proc are along the lines of the proc that provides 
  106.  #  acronym-epansion in latex. Here you just type and get a list in the 
  107.  #  statusline of all the commands known to tcl that start with whatever 
  108.  #  you have typed so far. Whenever the set of commands share a common 
  109.  #  prefix that goes beyond what you have typed the "letters-entered" 
  110.  #  portion of the statusline advances to include all the common letters 
  111.  #  (this means you have to be careful you don't re-enter them manually, as 
  112.  #  that will likely abort entry as no command will match).
  113.  #  
  114.  #  Once you have started entering characters, you are presented with the 
  115.  #  number of known cammands that start with those characters followed by 
  116.  #  a horizontal listing of as many of those commands that will fit on the 
  117.  #  line. These commands are separated by double spaces in order to make 
  118.  #  commands stand out as a whole to the eye (command with "::" in them 
  119.  #  are harder for the eyes to parse without this).
  120.  #  
  121.  #  At this point you either keep entering characters to narrow the matching 
  122.  #  commands, type a tab to scroll through the horizontal list, or type a 
  123.  #  numeral that corresponds to the position one of the visible commands in 
  124.  #  the horizontal list (which will then be looked-up).
  125.  #  
  126.  #  If you just keep entering characters till you narrow the list to one 
  127.  #  command, you might get down to a situation where the command you want 
  128.  #  out of the matches is contained in all the other matches. When this 
  129.  #  happens all you have to do is to type a <space> and you will look-up 
  130.  #  that command.
  131.  #  
  132.  #  To make things easier, whenever a character is entered that would abort 
  133.  #  the procedure, it is first checked to see if the upperCase version of 
  134.  #  tht character would not keep us for aborting. For example, if you had 
  135.  #  'page…' as the entered portion, your list would be: 
  136.  #  (pageBackward  pageForward  pageSetup), so entering 'B' or 'b' would 
  137.  #  lookup pageBackward for you.
  138.  #  
  139.  #  ToDo: 
  140.  #  • provide cushioning/alerting mechanism against aborting when the user 
  141.  #  does not notice that entered portion has been automatically extended. 
  142.  #  Perhaps, flash the statusline and color the automatically entered 
  143.  #  portion, and/or allow the rentering of the auto-entered portion. 
  144.  #  Of course insertColorEscape does not work in the statusline, but 
  145.  #  perhaps it would be possible figure out the escapes and enter them 
  146.  #  as literals via message.
  147.  #  • perhaps alter this so you have the option of deleting characters 
  148.  #  instead of aborting when you get no matches.
  149.  #  • perhaps provide a variant that inserts the found procName into your 
  150.  #  current cursor position instead of doing a look-up.
  151.  #  
  152.  #  Note: made one change, moved the "number found:" portion of the prompt 
  153.  #  outside the horizontal list so it is easy to visually parse the list 
  154.  #  to determine what nember to hit to make a choice from the list.
  155.  #  
  156.  #  Author: mostly Tom Fetherston; Vince made the proc a little more
  157.  #  general so it is now used by C++, Tcl and Bib modes.
  158.  # -------------------------------------------------------------------------
  159.  ##
  160. proc prompt::_complete {curr {key 0} {mod 0}} {
  161.     global __keysSoFar __startIndex __lastStartIndex __lastMatchesDisplayed
  162.     global __oldCurr
  163.     
  164.     if {$mod && ($mod != 2)} {error ""}
  165.     upvar opts opt
  166.     upvar patt pat
  167.     upvar completeWith compP
  168.     upvar what whatP
  169.     if {![info exists opt(-nocache)]} {
  170.     global __lastMatches
  171.     }
  172.     if {$__oldCurr != "" && ([string length $__oldCurr] >= [string length $curr])} {
  173.     # we've used delete (Alpha just deletes without telling us)
  174.     set real_key $key
  175.     set remove [expr {1 + [string length $__oldCurr] - [string length $curr]}]
  176.     regsub {.$} $curr "" __oldCurr
  177.     set key "\034"
  178.     } else {
  179.     set __oldCurr $curr
  180.     }
  181.     switch -regexp -- $key {
  182.     "\t" {
  183.         set __lastStartIndex $__startIndex 
  184.         if {![info exists __lastMatches]} {
  185.         set __lastMatches [lsort [eval $compP [list $pat]]]
  186.         }
  187.         set msg "$whatP '$pat…' ($__lastMatches)"
  188.         if {[string length $msg] > 80} {
  189.         set numFound [llength $__lastMatches]
  190.         set nextIdx [expr {$__startIndex + 1}]
  191.         set msg "$whatP '$pat…' $numFound found: ([lindex $__lastMatches $__startIndex] … »tab"
  192.         while {($nextIdx < $numFound) && ([string length "$msg  [lindex $__lastMatches $nextIdx]"] <= 80)} {
  193.             set matchesDisplayed [lrange $__lastMatches $__startIndex $nextIdx]
  194.             incr nextIdx
  195.             if {$nextIdx >= $numFound} {
  196.             set more ""
  197.             } else {
  198.             set more "…"
  199.             } 
  200.             if {$__startIndex == 0} {
  201.             set start ""
  202.             } else {
  203.             set start "…"
  204.             } 
  205.             set msg "$whatP '$pat…' $numFound found: ($start $matchesDisplayed $more) »tab"
  206.         }
  207.         if {$nextIdx >= [expr {$numFound}]} {
  208.             set __lastStartIndex $__startIndex 
  209.             set __startIndex 0
  210.         } else {
  211.             set __lastStartIndex $__startIndex 
  212.             set __startIndex [expr {$nextIdx}]
  213.         }
  214.         }
  215.         message $msg
  216.         set __lastMatchesDisplayed $matchesDisplayed
  217.         return " "
  218.     }
  219.     " " - "\r" {
  220.         set __lastMatches [lindex $__lastMatchesDisplayed 0]
  221.     }
  222.     "\[\034\035\036\037\]" {
  223.         if {![info exists opt(-nobackup)] && $key == "\034"} {
  224.         set __keysSoFar $pat
  225.         set oldNumFound [llength $__lastMatches]
  226.         set numFound $oldNumFound
  227.         if {![info exists remove]} {set remove 1}
  228.         # make sure we remove enough chars so that we
  229.         # actually add some more choices!
  230.         while {$remove > 0 || ($numFound <= $oldNumFound && $__keysSoFar != "")} {
  231.             set __keysSoFar [string range $__keysSoFar 0 [expr {[string length $__keysSoFar] -2}]]
  232.             set __lastMatches [eval $compP [list $__keysSoFar]]
  233.             set numFound [llength $__lastMatches]
  234.             incr remove -1
  235.         }
  236.         set __lastMatches [lsort $__lastMatches]
  237.         set pat $__keysSoFar
  238.         if {[info exists real_key]} {
  239.             uplevel 1 [list prompt::_complete $curr $real_key]
  240.         }
  241.         } else {
  242.         error ""
  243.         }
  244.     }
  245.     default {
  246.         # here we rely on left-to-right evaluation
  247.         if {![llength [set __lastMatches [prompt::_updateLastMatches $compP $__keysSoFar$key]]] \
  248.           && [regexp {[1-9]} $key]} {
  249.         # we hit 1-9 and are trying to select that item in 
  250.         # the list displayed
  251.         if {$key <= [llength $__lastMatchesDisplayed]} {
  252.             set __lastMatches [lindex "null $__lastMatchesDisplayed" $key]
  253.         } else {
  254.             error ""
  255.         }                 
  256.         }
  257.         # otherwise we already did all we needed in the first part
  258.         # of the 'if' statement.
  259.     }
  260.     }
  261.     
  262.     set numFound [llength $__lastMatches]
  263.     if {!$numFound} {
  264.     # first we'll see if the user was just too lazy to shift the key
  265.     if {[info exists opt(-tryuppercase)]} {
  266.         set __lastMatches [prompt::_updateLastMatches $compP $__keysSoFar[string toupper $key]]
  267.         set numFound [llength $__lastMatches]
  268.     }
  269.     } 
  270.     append __keysSoFar $key
  271.     set pat $__keysSoFar
  272.     switch $numFound {
  273.     0 {
  274.         if {![info exists opt(-nomatchiserror)]} {
  275.         message "$whatP '$pat…' NO MATCHES!!"
  276.         return " "
  277.         } else {
  278.         error "No matches"
  279.         }
  280.     }
  281.     1 {
  282.         set pat $__lastMatches
  283.         message "$whatP -- '$pat'"
  284.         upvar __completed c
  285.         set c $pat
  286.         error ""
  287.     }
  288.     }
  289.     set pat [largestPrefix $__lastMatches]
  290.     set __keysSoFar $pat
  291.     set matchesDisplayed $__lastMatches
  292.     set msg "$whatP '$pat…' ($matchesDisplayed)"
  293.     if {[string length $msg] > 80} {
  294.     set matchesDisplayed [lindex $__lastMatches 0]
  295.     set nextIdx 1
  296.     set msg "$whatP '$pat…' $numFound found: ($matchesDisplayed …) »tab"
  297.     while {($nextIdx < $numFound) && ([string length "$msg [lindex $__lastMatches $nextIdx]"] <= 80)} {
  298.         append matchesDisplayed "  " [lindex $__lastMatches $nextIdx]
  299.         incr nextIdx
  300.         set msg "$whatP '$pat…' $numFound found: ($matchesDisplayed …) »tab"
  301.     }
  302.     if {$nextIdx > [expr {$numFound}]} {
  303.         set __lastStartIndex $__startIndex 
  304.         set __startIndex 0
  305.     } else {
  306.         set __lastStartIndex $__startIndex 
  307.         set __startIndex [expr {$nextIdx -1}]
  308.     }
  309.     
  310.     } 
  311.     set __lastMatchesDisplayed $matchesDisplayed
  312.     message $msg 
  313.     return " "
  314. }
  315.  
  316. proc prompt::_updateLastMatches {compP str} {
  317.     global __lastMatches
  318.     if {![info exists __lastMatches]} {
  319.     set res [lsort [eval $compP $str]] 
  320.     } else {
  321.     set res [completion::fromList $str __lastMatches]
  322.     }
  323.     if {[info exists __lastMatches]} {
  324.     set __lastMatches $res
  325.     } 
  326.     return $res
  327. }
  328.  
  329. # ◊◊◊◊ Simple dialogs/prompts ◊◊◊◊ #
  330.  
  331. ensureset promptNoisily 0
  332. ensureset useStatusBar 1
  333.  
  334. ## 
  335.  # -------------------------------------------------------------------------
  336.  # 
  337.  # "prompt::var" --
  338.  # 
  339.  #  Ask for value for a single variable.  Forces calling proc to return
  340.  #  if value isn't ok, or procedure is cancelled.
  341.  # -------------------------------------------------------------------------
  342.  ##
  343. proc prompt::var {prompt var {def ""} {testproc ""} {desired 1} {errmsg ""}} {
  344.     global promptNoisily useStatusBar
  345.     if {$promptNoisily && $useStatusBar} {beep}
  346.     upvar $var vvar
  347.     if {$useStatusBar} {
  348.         if {[catch {statusPrompt "$prompt ($def): "} vvar]} {
  349.             return -code return
  350.         }
  351.         if {![string length $vvar]} {
  352.             set vvar $def
  353.         }
  354.     } else {
  355.         if {[catch {prompt $prompt $def} vvar]} {
  356.             return -code return
  357.         }
  358.     }
  359.     if {$testproc != ""} {
  360.         if {[$testproc $vvar] != $desired} {
  361.             beep
  362.             message $errmsg
  363.             return -code return
  364.         }
  365.     }
  366. }
  367.  
  368. ## 
  369.  # -------------------------------------------------------------------------
  370.  # 
  371.  # "prompt::simple" --
  372.  # 
  373.  #  Prompt for a few variable values, with entry-validation.  Example
  374.  #  usage:
  375.  #  
  376.  #      prompt::simple \
  377.  #        [list "how many rows?" numberRows 2 N] \
  378.  #          [list "how many columns?" numberColumns 2 N]
  379.  #
  380.  #  Which either throws an error, or ensures the variables 'numberRows'
  381.  #  'numberColumns' are set to Natural numbers, with defaults of '2'.
  382.  # -------------------------------------------------------------------------
  383.  ##
  384. proc prompt::simple {args} {
  385.     set i 0
  386.     set y 40
  387.     set dialog ""
  388.     while 1 {
  389.         set v [lindex $args $i]
  390.         if {[llength $v] <= 1} {
  391.             set args [lrange $args $i end]
  392.             break
  393.         }
  394.         upvar [lindex $v 1] _v$i
  395.         lappend dialog "-t" [lindex $v 0] 10 $y 180 [expr {$y + 18}] \
  396.           -e [lindex $v 2] 220 $y 240 [expr {$y + 18}]
  397.         incr y 30
  398.         set _check$i [lrange $v 3 end]
  399.         incr i
  400.     }
  401.     # now args contains just the options
  402.     getOpts {-title}
  403.     if {[info exists opts(-title)]} {
  404.         set title [list -t $opts(-title) 20 10 440 30]
  405.     } else {
  406.         set title [list -t "Please enter the following:" 20 10 440 30]
  407.     }
  408.     set buttons [dialog::okcancel 50 y]
  409.     set res [eval [concat dialog -w 480 -h $y $title \
  410.       $buttons $dialog]]
  411.     if {[lindex $res 1]} { error "Cancel" }
  412.     for {set j 0} {$j < $i} {incr j} {
  413.         set _v$j [string trim [lindex $res [expr {2+$j}]]]
  414.         if {[set _check$j] != ""} {
  415.             eval entry::validate [list [set _v$j]] [set _check$j] 
  416.         }
  417.     }
  418.     return
  419. }
  420.  
  421. namespace eval entry {}
  422.  
  423. ## 
  424.  # -------------------------------------------------------------------------
  425.  # 
  426.  # "entry::validate" --
  427.  # 
  428.  #  Check if {$val} is of the given type, if the type is unrecognised, it
  429.  #  is assumed to be a procedure we call, and check if the result of
  430.  #  that procedure is either 1 or the first element of args if such
  431.  #  an element was given.
  432.  #  
  433.  #  Therefore
  434.  #  
  435.  #    entry::validate $x Z
  436.  #    entry::validate $x is::Integer
  437.  #    entry::validate $x is::Integer 1
  438.  #    
  439.  #  are all equivalent.
  440.  # -------------------------------------------------------------------------
  441.  ##
  442. proc entry::validate {val type args} {
  443.     switch -- $type {
  444.     "N" - "Z+" {
  445.         if {![is::PositiveInteger $val]} {
  446.         alpha::errorAlert "invalid input '$val':  unsigned, positive integer required"
  447.         }
  448.     }
  449.     "Z" {
  450.         if {![is::Integer $val]} {
  451.         alpha::errorAlert "invalid input '$val':  integer required"
  452.         }
  453.     }
  454.     "bool" {
  455.     }
  456.     "R" {
  457.         if {![is::Numeric $val]} {
  458.         alpha::errorAlert "invalid input '$val':  real number required"
  459.         }
  460.     }
  461.     default {
  462.         set check [eval $type [list $val]]
  463.         if {$check != [expr {[llength $args] == 0 ? 1 : [lindex $args 0]}]} {
  464.         alpha::errorAlert "invalid input '$val'"
  465.         }
  466.     }
  467.     }
  468. }
  469.  
  470.  
  471.