#D \module
#D   [       file=cont\_set.pm,
#D        version=1999.04.01,
#D          title=General modules, 
#D       subtitle=showing \CONTEXT\ commands,
#D         author=Hans Hagen,
#D           date=\currentdate,
#D      copyright={PRAGMA / Hans Hagen \& Ton Otten},
#D    suggestions={Tobias Burnus \& Taco Hoekater}]
#C
#C This module is part of the \CONTEXT\ macro||package and is
#C therefore copyrighted by \PRAGMA. See licen-en.pdf for 
#C details. 

#D As always: thanks to Taco and Tobias for testing this 
#D module and providing suggestions and code snippets as 
#D well as haunting bugs.  

package cont_set ; 

#D This module (package) deals with providing help information
#D about the \CONTEXT\ commands. The data needed is derived
#D from the setup files by \CONTEXT\ itself. The data is
#D stored in files with suffix \type {tws} (tex work setup). 
#D This module introduces some subroutines: 
#D 
#D \starttabulatie[|Tl|p|]
#D \NC \type {set\_setup\_interface}   \NC sets the primary interface 
#D                                     to search in \NC \NR 
#D \NC \type {set\_setup\_title}       \NC sets the title of the main 
#D                                     window title \NC \NR 
#D \NC \type {setups\_found}           \NC locate the \type {tws} files 
#D                                     using the \type {kpsewhich} 
#D                                     program \NC \NR   
#D \NC \type {show\_setups}            \NC allocate the radio buttons 
#D                                     that can be used to select a 
#D                                     command set \NC \NR 
#D \NC \type {load\_setup(filename)}   \NC load the names \type {tws} 
#D                                     file \NC \NR   
#D \NC \type {load\_setups}            \NC all found command files can 
#D                                     be loaded at once \NC \NR   
#D \NC \type {setup\_found(filename)}  \NC this routine returns~1 when    
#D                                     the file is loaded \NC \NR 
#D \NC \type {update\_setup}           \NC when we browse the list with 
#D                                     commands, this routine takes care 
#D                                     of updating the text area \NC \NR 
#D \NC \type {change\_setup}           \NC we can manually set the 
#D                                     command set we want to browse, 
#D                                     and this routine takes care of 
#D                                     this \NC \NR 
#D \NC \type {show\_setup(command)}    \NC context sensitive help can be 
#D                                     provided by calling this sub \NC \NR
#D \stoptabulatie
#D 
#D First we load some packages and set some constants. 

use Tk ;
use Tk::ROText ;
use Config ; 

use strict;

use subs qw/ update_setup / ;

my $dosish       = ($Config{'osname'} =~ /dos|win/i) ;
my $default_size = $dosish ? 9 : 12 ; 

my $textfont     = "Courier   $default_size       " ;
my $userfont     = "Courier   $default_size italic" ;
my $buttonfont   = "Helvetica $default_size bold  " ;

unless ($dosish) 
  { $textfont   = "-adobe-courier-bold-r-normal--$default_size-120-75-75-m-70-iso8859-1" ;
    $userfont   = "-adobe-courier-bold-o-normal--$default_size-120-75-75-m-70-iso8859-1" ;
    $buttonfont = "-adobe-helvetica-bold-r-normal--$default_size-120-75-75-p-69-iso8859-1" }
 
my $s_vertical   = 30 ; 
my $s_horizontal = 72 ; 
my $c_horizontal = 24 ; 

#D The main window is not resizable, but the text area and 
#D command list will have scrollbars. 

my $mw = MainWindow -> new ( -title => 'ConTeXt commands' ) ;

$mw -> resizable ('n', 'n') ; 

sub SetupWindow { return $mw } ; 

my $sw = $mw -> Scrolled (                'ROText'      ,
                           -scrollbars => 'se'          ,
                               -height => $s_vertical   ,  
                                -width => $s_horizontal ,  
                                 -wrap => 'none'        ,
                           -background => 'ivory1'      ,
                                 -font => $textfont     ) ;

my $cw = $mw -> Scrolled (                'Listbox'     ,
                           -scrollbars => 'e'           ,
                                 -font => $textfont     ,
                                -width => $c_horizontal ,  
                     -selectbackground => 'gray'        ,
                           -background => 'ivory1'      ,
                           -selectmode => 'browse'      ) ;

#D The (optional) file buttons are packed in a frame. 

my $fw = $mw -> Frame () ; 

my %lw ; 

#D We can search for commands, using: 

my $request  = $fw -> Entry (       -font => $textfont , 
                              -background => 'ivory1' ,
                                   -width => 20 ) ;

#D And the whole bunch of widgets are packed in the main 
#D window. 

$fw -> pack (   -fill => 'x'    ,
                -side => 'top'  ) ; 
$sw -> pack (  #-fill => 'both' , 
             #-expand => 1      ,
                -side => 'left' ) ;
$cw -> pack (   -fill => 'both' , 
              -expand => 1      ) ;

#D We scan for available setup files, with suffix \type {tws}.
#D These should be somewhere on the system, grouped in one
#D directory. At least the english file \type {cont-en.tws}
#D should be found. 

my $tws_path        = '' ; 
my @setup_files     = ('cont-en.tws') ; 
my $setup_file      = $setup_files[0] ; 
my $setup_interface = 'en' ; 
my $old_setup_file  = '' ;

sub set_setup_interface 
  { $setup_interface = shift } 

sub set_setup_title 
  { $mw -> configure ( -title => shift ) }

sub setups_found  
  { $tws_path = `kpsewhich --format='other text files' --progname=context cont-en.tws` ; 
    $tws_path =~ s/cont-en\.tws.*// ; 
    chop $tws_path ; 
    @setup_files = glob ("$tws_path*.tws") ; 
    if (@setup_files) 
      { foreach (@setup_files) { s/\.tws// ; s/.*\/// } 
        $setup_file = $setup_files[0] ;
        return 1 } 
    else 
      { return 0 } } 

#D The setup files can be shown and chosen. 

sub show_setups 
  { foreach (@setup_files)
      { $lw{$_} = $fw -> Radiobutton (     -text => lc $_          , 
                                          -value => $_             , 
                                           -font => $buttonfont    , 
                                    -selectcolor => 'ivory1'       ,
                                    -indicatoron => 0              , 
                                         command => \&change_setup ,
                                       -variable => \$setup_file   ) ;
        $lw{$_} -> pack ( -padx => '2p', 
                          -pady => '2p', 
                          -side => 'left' ) } 
       $request -> pack ( -padx => '6p', 
                          -pady => '2p', 
                          -side => 'left' ) }

$cw -> bind ('<B1-Motion>', \&update_setup ) ;
$cw -> bind ('<1>'        , \&update_setup ) ;
$cw -> bind ('<Key>'      , \&update_setup ) ;

$sw -> tag ('configure', 'user'     ,       -font => $userfont ) ;
$sw -> tag ('configure', 'command'  , -foreground => 'green3'  ) ;
$sw -> tag ('configure', 'variable' ,       -font => $userfont ) ;
$sw -> tag ('configure', 'default'  ,  -underline => 1         ) ;
$sw -> tag ('configure', 'symbol'   , -foreground => 'blue3'   ) ;
$sw -> tag ('configure', 'or'       , -foreground => 'yellow3' ) ;
$sw -> tag ('configure', 'argument' , -foreground => 'red3'    ) ;
$sw -> tag ('configure', 'par'      ,   -lmargin1 => '4m'      ,
                                        -lmargin2 => '6m'      ) ;

my %setups ;
my %commands ;   
my %loadedsetups ; 
my %positions ; 
my %crosslinks ; 

my $current_setup  = '' ; 

#D Setups are organized in files called \type {*.tws} and
#D alike. Several files can be loaded simultaneously. When
#D loading, we grab whole paragraphs. The variables and values
#D belonging to a command, are stored in the hash table \type
#D {setups}, one per language. The command templates are
#D stored in \type {commands}. 
#D 
#D A \type {tws} file is generated by \CONTEXT\ from the setup
#D definition files. Only \CONTEXT\ knows the current meaning
#D of commands and keywords. The files are generating by
#D simply saying something like: 
#D 
#D \starttypen
#D texexec  --interface=en  setupd  
#D texexec  --interface=de  setupd  
#D texexec  --interface=nl  setupd  
#D texexec  --interface=cz  setupd  
#D \stoptypen 
#D 
#D This results in files formatted as: 
#D 
#D \starttypen 
#D startsetup
#D com:setupcolors
#D typ:vars/
#D var:state:start,stop,global,local:
#D var:conversion:yes,no,always:
#D var:reduction:yes,no:
#D var:rgb:yes,no:
#D var:cmyk:yes,no:
#D stopsetup
#D \stoptypen
#D
#D This format can be stored rather efficient and parsed rather
#D fast. What more do we need.  

sub load_setup 
  { my $filename = shift ; 
    unless (keys %{$commands{$filename}})
      { local $/ = 'stopsetup' ; # in plaats van '' ivm unix ; (taco)
        $current_setup = '' ; 
        if (open(SETUP, "$tws_path$filename.tws" ))
          { my $position = 0 ; 
            while (<SETUP>)
              { chomp  ;
                s/startsetup//mso ;
                s/stopsetup//mso ; # redundant geworden 
                s/\r\n //gms ;     # in plaats van s/ //gms ; (taco)
                s/com\:(.*?)\:\s(.*)//mso ;
                my $string = $1 ; 
                my $command = $1 ;
                my $setup = $2 ;
                ++$position ;
                $string =~ s/(.*?)\<\<(.*?)\>\>(.*?)/$1$2$3/o ;
                $setups    {$filename}{$string}   = $setup ;
                $commands  {$filename}{$string}   = $command ;
                $positions {$filename}{$string}   = $position ;
                $crosslinks{$filename}[$position] = $string }
            close (SETUP) } }
    my @list = sort {lc $a cmp lc $b} keys %{$commands{$filename}} ;
    $cw -> delete ('0.0', 'end') ;
    $cw -> insert ('end', @list) ;
    $cw -> selectionSet ('0.0', '0.0') ;
    $cw -> activate ('0.0') ;
    $setup_file = $filename ;
    update_setup } 

sub load_setups 
  { foreach my $setup (@setup_files) { load_setup ($setup) } } 

#D The core of this module deals with transforming the 
#D definitions like shown earlier. Details on the format 
#D can be found in the file \type {setupd.tex}. We use the 
#D \type {Tk::Text} automatic hanging identation features. 
#D The next subs are examples of the kind you write once 
#D and never look at again.

my @arguments      = () ;  
my $nested_setup   = 0  ;
my $continue_setup = 0  ;
my $argument       = 0  ;
my $stopsuffix     = '' ;
my $stopcommand    = '' ;

my %arg ;

$arg {repeat} = '//n*/'                   ;
$arg {arg}    = 'argument/{/.../}'        ;
$arg {args}   = 'argument/{/..,...,../}'  ;
$arg {dis}    = 'argument/$$/.../$$'      ;
$arg {idx}    = 'argument/{/.../}'        ;
$arg {idxs}   = 'argument/{/..+...+../}'  ;
$arg {mat}    = 'argument/$/...:$'        ;
$arg {nop}    = '//.../'                  ;
$arg {fil}    = '//.../'                  ;
$arg {pos}    = 'symbol/(/.../)'          ;
$arg {poss}   = 'symbol/(/...,.../)'      ;
$arg {sep}    = 'command//\\\\/'          ;
$arg {ref}    = 'symbol/[/ref/]'          ;
$arg {refs}   = 'symbol/[/ref,../]'       ;
$arg {val}    = 'symbol/[/.../]'          ;
$arg {vals}   = 'symbol/[/..,...,../]'    ;
$arg {var}    = 'symbol/[/..=../]'        ;
$arg {vars}   = 'symbol/[/..,..=..,../]'  ;
$arg {cmd}    = 'command//\cmd/'          ;
$arg {dest}   = 'symbol/[/..ref/]'        ;
$arg {dests}  = 'symbol/[/..,..refs,../]' ;
$arg {trip}   = 'symbol/[/x:y:z=/]'       ;
$arg {trips}  = 'symbol/[/x:y:z=,../]'    ;
$arg {wrd}    = 'argument/{/.../}'        ;
$arg {wrds}   = 'argument/{/......./}'    ;
$arg {par}    = 'command//\par/'          ;
$arg {stp}    = '//stop/'                 ;
$arg {par}    = 'command///'              ;

sub show_command
  { my $command = shift ;
    local $_ = $commands{$setup_file}{$command} ;
    if ($command eq $_)
      { $sw -> insert ('end', "\\$command", 'command' ) }
    elsif (/(.*?)\<\<(.*?)\>\>(.*?)/o)
      { $sw -> insert ('end', "\\", 'command' ) ;
        if ($1) { $sw -> insert ('end', $1, 'command' ) }
        if ($2) { $sw -> insert ('end', $2, ['command','user'] ) }
        if ($3) { $sw -> insert ('end', $3, 'command' ) }
        $stopsuffix = $2 } }

sub show_left_argument
  { local $_ = shift ; 
    my @thearg = split (/\//, $arg{$arguments[$_]}) ;
    $sw -> insert ('end', $thearg[1], ['par',$thearg[0]] ) }

sub show_middle_argument
  { local $_ = shift ; 
    my @thearg = split (/\//, $arg{$arguments[$_]}) ;
    if ($thearg[1])
      { $sw -> insert ('end', $thearg[2], 'par' ) } 
    else
      { $sw -> insert ('end', $thearg[2], ['par',$thearg[0]] ) } }

sub show_right_argument
  { local $_ = shift ; 
    my @thearg = split (/\//, $arg{$arguments[$_]}) ;
    $sw -> insert ('end', $thearg[3], ['par',$thearg[0]] ) ;
    ++$argument }  

sub show_reference
  { if (($nested_setup<=1)&&(defined($arguments[$argument])))
      { if ($arguments[$argument]=~/ref/)
          { $sw -> insert ('end', "\n" ) ;
            show_left_argument ($argument) ;
            show_middle_argument ($argument) ;
            show_right_argument ($argument) } } }

sub show_stop_command
  { my $before_stop = shift ; 
    if ($stopcommand)
      { if ($stopsuffix)
          { $sw -> insert ('end', '\\stop', 'command' ) ;
            $sw -> insert ('end', $stopsuffix, ['command','user'] ) }
        else
          { $sw -> insert ('end', $stopcommand, 'command' ) } } }

sub show_whatever_left
  { while ($argument<@arguments) 
      { $sw -> insert ('end', "\n" ) ;
        show_left_argument ($argument) ;
        show_middle_argument ($argument) ;
        show_right_argument ($argument) ; 
        ++$argument } 
    if ($stopcommand)
      { $sw -> insert ('end', "\n...\n...\n...\n", 'par') ;
        show_stop_command } }

sub do_update_setup                # type: 0=all 1=vars 2=vals 
  { my ($command, $type) = @_ ; 
    my $setup = $setups{$setup_file}{$command} ;
    my $default = '' ; 
    my $key = '' ; 
    my $meaning = '' ; 
    my @values = () ; 
    local $_ ;
    ++$nested_setup ;
    while ($setup=~/(typ|var|val|ivr|ivl)\:(.*?)\:\s/mgo)
      { $key = $1 ;
        $meaning = $2 ;
        if    (($key=~/var/o)&&($type!=2))
          { $_ = $meaning ; s/(.*?)\:(.*?)\:(.*)//o ;
            if (($nested_setup>1)&&(!$2)) { next }
            $key = $1 ; 
            if ($3) { $default = $3 } else { $default = '' }
            $_= $2 ; s/\s//go ; @values = split (/,/,$_) ; 
            if ($continue_setup)
              { $sw -> insert ('end', ",\n ", 'par') }
            else
              { $continue_setup = 1 ;
                $sw -> insert ('end', "\n", 'par') ;
                show_left_argument($argument) }
            $sw -> insert ('end', $key , 'par' ) ;
            $sw -> insert ('end', '=', ['symbol','par'] ) ;
           #while (1)
            while (@values)
              { my $value = shift @values ;
                if ($value =~ /^\*/o) 
                  { $value =~ s/^\*//o ; 
                    $sw -> insert ('end', lc $value, ['variable','par'] ) }
                elsif ($value eq $default)
                  { $sw -> insert ('end', $value, ['default','par'] ) }
                else
                  { $sw -> insert ('end', $value, 'par' ) }
                if (@values)
                  { $sw -> insert ('end', '|' , ['or','par'] ) }
                else
                  { last } } }
        elsif (($key=~/val/o)&&($type!=1))
          { $_ = $meaning ; s/(.*)\:(.*)//o ;
            if (($nested_setup>1)&&(!$2)) { next }
            $_ = $1 ; s/\s//go ; @values = split (/,/,$_) ;
            if ($2) { $default = $2 } else { $default = '' }
            if ($continue_setup)
              { $continue_setup = 0 ;
                show_right_argument($argument) }
            $sw -> insert ('end', "\n" , 'par') ;
            show_left_argument($argument) ;
           #while (1)
            while (@values)
              { unless (@values) { last } 
                my $value = shift (@values) ;
                if ($value =~ /^\*/o)
                  { $value =~ s/^\*//o ; 
                    $sw -> insert ('end', lc $value, ['variable','par'] ) }
                elsif ($value eq $default)
                  { $sw -> insert ('end', $value, ['default','par'] ) }
                else
                  { $sw -> insert ('end', $value, 'par' ) }
                if (@values)
                  { $sw -> insert ('end', ', ', 'par' ) }
                else
                  { last } }
            show_right_argument($argument) }
        elsif ($key=~/typ/o)
         { if ($nested_setup==1)
             { show_command ($command) ;
               my $arguments = $meaning ;
               if ($arguments=~/stp/)
                 { $_ = $command ;
                   s/start(.*)/$1/o ;
                   $stopcommand = "\\stop$_" ;
                   $arguments =~ s/stp//go }
               @arguments = split (/\//,$arguments) ;
               if (@arguments)
                 { for (my $i=0;$i<@arguments;$i++)  
                    { show_left_argument ($i) ;
                      show_middle_argument ($i) ;
                      show_right_argument ($i) }
                   if ($stopcommand) 
                     { $sw -> insert ('end', ' ... ') ;
                       show_stop_command } 
                   $sw -> insert ('end', "\n\n") ;
                   show_command ($command) }
               $argument = 0 ;
               $continue_setup = 0 } }
        elsif ($key=~/ivr/o)
          { $meaning =~ s/(.*)\:(.*)//o ;
            do_update_setup ($1,1) }
        elsif ($key=~/ivl/o)
          { $meaning =~ s/(.*)\:(.*)//o ;
            do_update_setup ($1,2) }
        show_reference }
   --$nested_setup ;
   if (($continue_setup)&&(!$nested_setup)) 
     { show_right_argument ;
       show_whatever_left } }

#D Now the real work is done, we only have to define a few
#D housekeeping routines. The next sub adapts the text area 
#D to the current selected command and normally is bound to 
#D the list browsing commands. 

sub update_setup 
 { $old_setup_file = $setup_file ;
   if (keys %{$commands{$setup_file}})
     { my $key ; 
       unless ($cw->curselection)
         { $cw -> selectionSet('0.0','0.0') }  
       $key = $cw -> get($cw->curselection) ;
       if ($current_setup ne $key) 
         { $current_setup = $key ;
           $sw -> delete ('1.0', 'end' ) ;
           $nested_setup = 0 ;
           $argument = 0 ;
           $stopcommand = '' ;
           $stopsuffix = '' ;
           do_update_setup ($key,0) ;
           $mw -> raise ; 
           $mw -> focus } } }

#D In editors we want to provide context sensitive help
#D information. The next sub first tries to locate the
#D commands asked for in the setup data currently selected,
#D and when not found takes a look at all the loaded files. 
    
sub show_setup 
  { my $asked_for = shift ;
    unless ($asked_for) { return } 
    my $found = 0 ;  
    $asked_for =~ s/^\\// ;    
    if ($setup_interface) 
      { $found = 0 ; 
        foreach my $name (@setup_files) 
          { if (($name=~/\-$setup_interface/)&&(exists($commands{$name}{$asked_for}))) 
              { $found = 1 ; 
                $setup_file = $name ; 
                last } } }  
    if (!($found)&&(exists($commands{$setup_file}{$asked_for}))) 
      { $found = 1 } 
    else 
      { $found = 0 ; 
        foreach my $name (@setup_files) 
          { if (exists($commands{$name}{$asked_for})) 
              { $found = 1 ; 
                $setup_file = $name ; 
                last } } }  
    if ($found) 
      { my @list = sort {lc $a cmp lc $b} keys %{$commands{$setup_file}} ;
        $cw -> delete ('0.0', 'end') ;
        $cw -> insert ('end', @list) ;
        $found = 0 ; 
        foreach (@list) { if ($_ eq $asked_for) { last } ++$found }   
        my $index = "$found.0" ; 
        $cw -> selectionSet ($index, $index) ;
        $cw -> activate ($index) ;
        $cw -> see ($index) ;
        update_setup ;
        $mw -> raise ; 
        $mw -> focus } } 

#D Whenever a new set of commands is selected (by means of the
#D buttons on top the screen) the list and text are to be
#D updated. 

sub change_setup 
  { my $command = '' ; 
    if ($old_setup_file)
      { unless ($cw->curselection)
         { $cw -> selectionSet('0.0','0.0') }  
        $command = $cw -> get($cw->curselection) ;
        my $position = $positions{$old_setup_file}{$command} ;
        $command = $crosslinks{$setup_file}[$position] }
    load_setup($setup_file) ;
    my @list = sort {lc $a cmp lc $b} keys %{$commands{$setup_file}} ;
    $cw -> delete ('0.0', 'end') ;
    $cw -> insert ('end', @list) ;
    if ($command) 
      { show_setup($command) } 
    else 
      { $cw -> selectionClear ('0.0','end') ; 
        $cw -> selectionSet ('0.0', '0.0') ;
        $cw -> see ('0.0') ;
        $cw -> activate ('0.0') }
    update_setup ;
    $mw -> raise ; 
    $mw -> focus }

#D Sometimes we want to make sure the dat is loaded indeed:

sub setup_found
  { my $filename = shift ; 
    if (-e "$tws_path$filename.tws") 
      { $setup_file = $filename ; 
        return 1 } 
    else 
      { return 0 } }

#D The next feature is dedicated to Tobias, who suggested 
#D it, and Taco, who saw it as yet another proof of the 
#D speed of \PERL. It's also dedicated to Ton, who needs it 
#D for translating the big manual. 

sub handle_request 
  { my $index = $cw -> index('end') ;
    unless ($index) { return } 
    my $req = $request -> get ;  
    unless ($req) { return } 
    $req =~ s/\\//o ; 
    $req =~ s/\s//go ; 
    $request -> delete('0','end') ; 
    $request -> insert('0',$req) ; 
    unless ($req) { return } 
    my ($l,$c) = split (/\./,$index) ; 
    for (my $i=0;$i<=$l;$i++)
      { $index = "$i.0" ; 
        my $str = $cw -> get ($index, $index) ; 
        if ($str =~ /^$req/) 
          { $cw -> selectionClear ('0.0','end') ; 
            $cw -> selectionSet ($index, $index) ; 
            $cw -> activate ($index) ;
            $cw -> see ($index) ;
            update_setup ; 
            $mw -> raise ; 
            $mw -> focus ;
            return } } } 

$request -> bind ('<Return>', sub { handle_request } ) ;

sub insert_request 
  { my ($self, $chr) = @_ ;
    if ($self ne $request) 
      { $request -> insert ('end', $chr) }
    handle_request } 

foreach my $chr ('a'..'z','A'..'Z')
  { $mw -> bind ( "<KeyPress-$chr>", sub { insert_request(shift, $chr) } ) } 

$mw -> bind ( "<backslash>", sub { insert_request(shift, "\\") } ) ;

sub delete_request
  { my $self = shift ;
    if ($self ne $request) 
      { my $to = $request -> index ('end') ; 
        my $from = $to - 1 ;
        if ($from<0) { $from = 0 }
        $request -> delete ($from,$to) }
    handle_request } 

$mw -> bind ( "<BackSpace>", sub { delete_request } ) ;

sub new_request 
  { $request -> delete (0,'end') ;
    handle_request }

$mw -> bind ( "<space>", sub { new_request } ) ;

#D Just in case: 

sub raise_setup 
  { $mw -> raise }

sub dont_exit   
  { $mw -> protocol( 'WM_DELETE_WINDOW' => sub { } ) }  

#D An example use is: 
#D
#D \starttypen 
#D load_setup ("cont-$nl") ; 
#D show_setup ('omlijnd') ;  
#D MainLoop () ;
#D \stoptypen 
#D
#D Now everything is done, we return 1: 

1 ;
