#!/usr/local/bin/perl 
#
# Copyright (C) 1992 by Gustaf Neumann, Stefan Nusser
#
#      Wirtschaftsuniversitaet Wien,
#      Abteilung fuer Wirtschaftsinformatik
#      Augasse 2-6,
#      A-1090 Vienna, Austria
#      neumann@wu-wien.ac.at, nusser@wu-wien.ac.at
#
# Permission to use, copy, modify, and distribute this software and its
# documentation for any purpose and without fee is hereby granted, provided     
# that the above copyright notice appears in all copies and that both that
# copyright notice and this permission notice appear in all supporting
# documentation.  This software is provided "as is" without expressed or
# implied warranty.
#
# Date: Jul 13 1992
# Author: Gustaf Neumann
# Version: 0.92
#

$WafeLib = $ENV{'WAFELIB'} || "/usr/lib/X11/wafe";
require "$WafeLib/perl/wafe.pl";
$R4 = ($wafe'XVersion =~ /R4/);

if (!$R4) {
    @R5SWidgets = ('panner');
    @R5CWidgets = ('tree', '$C', 'porthole', '$C');
}

if (!defined($noPLOTTER) && $wafe'Packages =~ /\bPLOTTER\b/) {
    @plotterSWidgets = ('axis','barPlot','linePlot','xyLinePlot',
                        'labelAxis','textPlot', 'xyAxis');
    @plotterCWidgets = ('plotter',join(" ",@plotterSWidgets));
}

@simpleWidgets = (
		  'asciiText',
		  'clock',
		  'command',
		  'label',
		  'list',
		  'logo',
		  'menuButton',
		  'smeBSB',
		  'smeLine',
		  'stripChart',
		  'toggle',
                  @R5SWidgets,
                  @plotterSWidgets,
		  );

%compositeWidgets = (
		     'box', '$C',
		     'dialog', '$C',
		     'paned', '$C',
		     'form', '$C',
		     'simpleMenu', 'smeBSB smeLine',
		     'transientShell', '$C',
		     'viewport', '$C',
                     @R5CWidgets,
                     @plotterCWidgets,
		    );

$C = join(" ",keys %compositeWidgets)
      ." asciiText clock command label list logo menuButton panner stripChart toggle";
grep(eval "\$compositeWidgets{$_} = \"$compositeWidgets{$_}\";", keys %compositeWidgets);
undef $C;

%domain = (
           'BackingStore', 'Always NotUseful WhenMapped',
           'Boolean', 'true false',
           'EdgeType', 'chainBotton chainTop chainLeft chainRight rubber',
           'InitialState', 'Iconic Normal',
           'Justify', 'center left right',
           'Orientation', 'horizontal vertical',
           'ShapeStyle', 'oval rectangle ellipse roundedRectangle',
# for asciitext
           'ScrollMode', 'always whenneeded never',
           'ResizeMode', 'never width height both',
           'WrapMode', 'never line word',
           'EditMode', 'read append edit',
           'AsciiType', 'file string',
# for plotter widget
           'Linestyle', 'LineSolid LineDoubleDash LineOnOffDash',
           'FontSize', 'smallest small medium normal big biggest',
           'FontStyle', 'plain bold italic bolditalic',
           'Shading', 'gray0 gray1 gray2 gray3 gray4 gray5 gray6 gray7 gray8 gray9 gray10',
           'AtJustify', 'left right center top bottom',
           'PlotMarkType', 'rectangle plus xmark star diamond triangle1 triangle2 triangle3 triangle4',
           'PlotLineType', 'lines points impulses linepoints lineimpulses',
           'PlotLineStyle', 'solid dotted dashed dotdashed dotted2 dotted3 dotted4 dotted5 dashed3 dashed4 dashed5 dotdashed2',
          );


#
#
# this is for string resources  for which empty strings are meaningful resources

$allowEmpty = 'value string label';

%widgetReference = (
           'fromVert', 1,
           'fromHoriz', 1,
           'treeParent', 1,
);

%invert = (
	   'active', 'passive',
	   'passive', 'active',
	   );

%hasExtraProc = (
	      'barPlot', 'barPlotAttachData',
	      'labelAxis', 'labelAxisAttachData',
	      'linePlot', 'linePlotAttachData',
	      'xyLinePlot', 'xyLinePlotAttachData',
	      'panner', 'talk',
	      'asciiText', 'textSetSelectionArray textSinkSetTabs',
	      );

$lang = 'tcl';

$BEGIN = "### BEGIN wafedesign TCL ###\n";
$END = "### END wafedesign TCL ###\n";

$defaultPerlProgram = <<'End of Perl';
#!/usr/bin/perl
$WafeLib = $ENV{'WAFELIB'} || "/usr/lib/X11/wafe";
require "$WafeLib/perl/wafe.pl";

&UI( <<"End of TCL");
### BEGIN wafedesign TCL ###
### END wafedesign TCL ###
End of TCL

while(<STDIN>) {
    chop;
    print "---> <$_>\n";
    eval $1 if /^perl (.*)/; 
}
&wafe'cleanup; 
End of Perl

$defaultTclProgram = <<'End of Tcl';
#!/usr/bin/X11/wafe --f
# 
# User Code comes here
#
### BEGIN wafedesign TCL ###
### END wafedesign TCL ###
End of Tcl

$top = "top chainTop bottom chainTop";
&UI( <<"End of TCL");
form top topLevel 
   label info top label {} width 700 $infoColors
   form paned top fromVert info width 700 height 520 left chainLeft right chainRight
      form widgets paned defaultDistance 0
          label titleWidgets widgets label {Widgets:} borderWidth 0 $top $boldFont
          list resList widgets verticalList true forceColumns true $threeD \\
                horizDistance 120 fromVert titleWidgets $top height 543 width 300 \\
                callback {echo set \$w: \[getTypeOfAttribute \[lindex \$w 0\] %s\] %s}

topLevelShell preview topLevel allowShellResize true
      form appl0 preview  width 100 height 100 
          label titleAppl appl0 label {Preview:} borderWidth 0 $top $boldFont
          label prevlab appl0 \\
             $background $normalFont borderWidth 0 \\
             label {Shift<Btn1>: move, Shift<Btn3>: select} \\
             fromHoriz titleAppl
          form form1 appl0 width 100 height 100 resizable true fromVert titleAppl
          command duplicate appl0 label Duplicate $buttonAtts \\
             callback {echo %w} \\
             fromVert form1 
          command delete appl0 label Delete $buttonAtts \\
             callback {echo %w} \\
             fromVert form1 fromHoriz duplicate 

   command quit top label Quit $buttonAtts \\
      callback quit \\
      fromVert paned 
   command dump top label Generate $buttonAtts \\
      callback {echo dump; popup dumpmenu none} \\
      fromVert paned fromHoriz quit 
   command load top label Load $buttonAtts \\
      callback {global dir; doDir \$dir} \\
      fromVert paned fromHoriz dump 
#   command step top $buttonAtts \\
#      callback {echo %w} \\
#      fromVert paned fromHoriz load 

   transientShell  filemenu topLevel 
   callback filemenu popupCallback position top:100/250
      form fmform filemenu
      list fmlist fmform defaultColumns 5 
      callback fmlist callback exec {sV fmtext string %s}

      label fmtextlab fmform label {Filename:} $boldFont borderWidth 0 \\
          fromVert fmlist 
      asciiText fmtext fmform width 200 editType edit \\
          fromVert fmlist fromHoriz fmtextlab
      action fmtext override \\
          {<Key>Return: exec(echo file \[gV fmtext string\];popdown filemenu)}

      label fmdirlab fmform label {Match:} $boldFont borderWidth 0 \\
          fromVert fmlist fromHoriz fmtext
      asciiText fmdir fmform width 200 editType edit \\
          fromVert fmlist fromHoriz fmdirlab
      action fmdir override \\
          {<Key>Return: exec(doDir \[gV fmdir string\])}

      command fmquit fmform label Cancel $buttonAtts \\
          callback {popdown filemenu} \\
          fromVert fmtext
      command fmok fmform label Insert $buttonAtts \\
          callback {echo file full \[gV fmtext string\];popdown filemenu} \\
          fromVert fmtext fromHoriz fmquit 
      command fmoki fmform label {Insert without top Widget} $buttonAtts \\
          callback {echo file into \[gV fmtext string\];popdown filemenu} \\
          fromVert fmtext fromHoriz fmok 
      command fmokn fmform label {Load new} $buttonAtts \\
          callback {echo file new \[gV fmtext string\];popdown filemenu} \\
          fromVert fmtext fromHoriz fmoki 

   transientShell dumpmenu topLevel 
   callback dumpmenu popupCallback position top:100/300
      form dmForm dumpmenu
      asciiText dmText dmForm height 300 width 500 $textFont \\
            editType edit type string \\
            scrollVertical whenneeded scrollHorizontal whenneeded
      command dmQuit dmForm label Cancel $buttonAtts \\
            callback {popdown dumpmenu} \\
            fromVert dmText
      command dmTcl dmForm label Tcl $buttonAtts \\
            callback {echo dump tcl} \\
            fromHoriz dmQuit fromVert dmText
      command dmPerl dmForm label Perl $buttonAtts \\
            callback {echo dump perl} \\
            fromHoriz dmTcl fromVert dmText
      command dmsave dmForm label Save $buttonAtts \\
            callback {echo dump . \[gV dmFn string\]} \\
            fromHoriz dmPerl fromVert dmText
      asciiText dmFn dmForm width 200 editType edit \\
          fromVert dmText fromHoriz dmsave
      action dmFn override \\
          {<Key>Return: exec(echo dump . \[gV dmFn string\])}


   transientShell setvalmenu topLevel allowShellResize true
   callback setvalmenu popupCallback positionCursor 45
    dialog setvaltext setvalmenu label {Resource value:} value {} $backGround 
    sV setvaltext.label $backGround $boldFont
    command setvalquit setvaltext label {cancel} $buttonAtts \\
        callback {popdown setvalmenu}
    action setvaltext.value  override {<Key>Return: exec(global w r; \\
       echo sV \$w: \$r [gV setvaltext value\]) \\
	   XtMenuPopdown(setvalmenu) }

   transientShell svs topLevel allowShellResize true
   callback svs popupCallback positionCursor 45
#    form svsForm svs $background
#    label svsLab svsForm $backGround $boldFont 
#    simpleMenu svsMenu svsForm $backGround fromVert svsLab

proc menu {lab entries} { \\
    form svsForm svs;\\
    label svsLab svsForm borderWidth 0 label \$lab $backGround $boldFont; \\
    set vert svsLab;\\
    foreach pairs \$entries {\\
       set e [lindex \$pairs 0];\\
       toggle \$e svsForm label \$e state [lindex \$pairs 1] \\
          $normalFont $threeD fromVert \$vert \\
          callback "global w r;echo sV \\\$w: \\\$r \$e;popdown svs;destroyWidget svsForm";\\
       set vert \$e;}; \\
    command svsQuit svsForm fromVert \$vert label {Cancel} \\
       callback {popdown svs;destroyWidget svsForm} $threeD $backGround $boldFont;\\
    popup svs none;\\
}

#    eval listChange fmlist 0 0 1 Arg [split [exec /bin/ls -1 \$dir] \\n];\\

proc doDir {ndir} {global dir;\\
    set dir \$ndir; \\
    sV fmdir string \$dir; \\
    eval listChange fmlist 0 0 1 Arg [lsort [glob \$dir]];\\
    popup filemenu none;\\
}

proc echoPos {w d} {\\
     echo sV \$w: horizDistance [expr [gV \$w horizDistance]\$d]; \\
     echo sV \$w: vertDistance [expr [gV \$w vertDistance]\$d]}

proc setWidget {nw update} {global w; \\
  if [lsearch \$w \$nw]==-1 \\
      {lappend w \$nw; sV t_\$nw state true; \\
      if \$update {addTimeOut 10 {updateResList \$w}}}}

proc unsetWidget {nw update} {global w; \\
  set pos [lsearch \$w \$nw];\\
      echo unsetWidget <\$w> <\$nw> \$pos; \\
  if \$pos>-1 \\
      {set w [lreplace \$w \$pos \$pos]; sV t_\$nw state false;\\
       if \$update {addTimeOut 10 {updateResList \$w}}}}

proc updateResList {w} {global extra;\\
     set allRes {};\\
     set allClasses {};\\
     foreach l \$w {\\
         set class [getClass \$l];\\
         if [lsearch \$allClasses \$class]==-1 { \\
             getResourceList \$l res; \\
             regexp {^([a-zA-Z]+)} \$l type;\\
             if [info exists extra(\$type)] \\
                {foreach x \$extra(\$type) {lappend res *\$x}}; \\ 
             lappend allRes [nodup [lsort \$res]];\\
             lappend allClasses \$class;\\
          }\\
     };\\
#     eval  listChange resList 0 0 1 Arg [union \$allRes]; \\
     set list [union \$allRes]; \\
     sV resList longest 150 list \$list numberStrings [llength \$list]; \\
     sV info label "current Widgets: \$w"}

proc nodup {list} {\\
     set n [expr [llength \$list]-2];\\
     for {set i 0; set x 0} {\$i<\$n} {incr i} {\\
        set y [expr \$x+1];\\
        if {[lindex \$list \$x] == [lindex \$list \$y]} \\
            {set list [lreplace \$list \$x \$x]} {incr x};\\
     }; return \$list \\
}

proc union {args} {\\
 set nargs [eval concat \$args];\\
 if [llength \$nargs]==0 {return none};\\
 set l1 [lindex \$nargs 0];\\
 set nargs [lreplace \$nargs 0 0];\\ 
 foreach l2 \$nargs {\\
    set result {};\\
    foreach e \$l1 {if [lsearch \$l2 \$e]>-1 {lappend result \$e}};\\
    set l1 \$result;\\
 };\\
 return \$l1;\\
}

mergeResources *resizable true  *AtPlotter.width 100 *AtPlotter.height 100 

set dir {*}
set w {}
#set extra(barPlot) "barPlotAttachData"
#set extra(labelAxis) "labelAxisAttachData"
#set extra(linePlot) "linePlotAttachData"
#set extra(xyLinePlot) "xyLinePlotAttachData"
#set extra(panner) "talk"
#set extra(asciiText) {textSetSelectionArray textSinkSetTabs}
End of TCL

&wafe'applyActions("dmText",@textActions);

$tcl = 'mergeResources ';
grep(!/[Ss]hell/ && ($tcl .= "*\u$_.width 100 *\u$_.height 100 "),keys %compositeWidgets);
foreach $w (keys %hasExtraProc) {
    $tcl .= ";set extra($w) {$hasExtraProc{$w}}";
    grep(($isExtraProc{$_}=1),split(/\s+/,$hasExtraProc{$w}));
}
&Xui($tcl);

if (!$R4) {
    &Xui(
      "form theTree paned width 400 fromHoriz widgets;"
      ."panner pan theTree top chainTop width 50 height 50;"
      ."label titleTree theTree label {Tree:} borderWidth 0 $top $boldFont fromHoriz pan;"
      ."porthole hole theTree $top bottom chainBottom height 510 width 250 fromVert pan;"
      ."tree tree hole;talk pan hole tree;"
      ."toggle t_form1 tree label {form1} $buttonAtts callback {echo toggle form1}");
} else {
    &Xui(
      "viewport tree paned resizable false fromHoriz widgets "
      ."width 250 height 574 allowHoriz true allowVert true forceBars true;"
      ."box b_form1 tree hSpace 20 orientation vertical borderWidth 0 vSpace 1;"
      ."toggle t_form1 b_form1 width 200 label {form1} $buttonAtts callback {echo toggle form1}");
}

$vert = "fromVert titleWidgets";
foreach(&types) {
    &Xui("command w_$_ widgets label {$_} width 100 $vert sensitive false $top $buttonAtts "
         ."callback {echo new %w}");
    $vert = "fromVert w_$_";
}
&Xui("realize; popup preview none");

sub beep {
    &Xui("callActionProc fmtext {} no-op RingBell"); 1;
}
sub warn {
    &beep();
    &info($_[0]);
}

sub composite {
    grep(&widgetIsComposite($_),@_);
}
sub simple {
    grep(!&widgetIsComposite($_),@_);
}
sub active {
    grep($widget{$_} eq 'active',@_);
}
sub widgets {
    grep($widget{$_},keys %widget);
}
sub types {
    @Types = ((sort @simpleWidgets),sort keys %compositeWidgets) if !@Types;
    return @Types;
}
sub children {
    grep($father{$_} eq $_[0],&widgets);
}

sub newName {
    local($type,$min) = @_;
#    print "===== new Name $type min = <$min> counter = <$name{$type}>\n";
    $name{$type} = $min if ++ $name{$type} < $min; 
    return $type. $name{$type};
}

sub getType {
    local($_) = @_;
    m/^(\D+)\d/;
    $1;
}

sub widgetIsComposite { 
    local($type) = &getType($_[0]);
    $typeIsComposite{$type};
}
sub defaultFather {
    (reverse &composite(&active(&widgets)))[0] || "form1";
}
sub findFather {
    local($type) = @_;
    local(@candidates) = split(/\s+/,$canBeChildOf{$type});
    shift @candidates;
    local(@activeCandidates) = reverse &active(@candidates);
#    print "CAN BE CHILD OF <$canBeChildOf{$type}>\n";
#    print "all candi <<", join(",",@candidates),">> <@candidates[$[]>\n";
#    print "act candi <<", join(",",@activeCandidates),">> <@activeCandidates[$[]>\n";
    return @activeCandidates[$[] if @activeCandidates>0;
    return @candidates[$[] if @candidates>0;
    return "form1";
}
sub expandPerlVariables {
    local($_) = @_;
    local($theValue);
#    return $_ if !/^\$/;
    s/\"/\\\"/g;
#    print "     evaluating: <<". '$theValue =  "' . $_ . '";'.">>\n";
    eval '$theValue =  "' . $_ . '";';
    warn $@ if $@;
#    print "     theValue = <$theValue>\n";
    return $theValue;
}

sub setValue {
    local($widget,$res,$theValue) = @_;
    local($token,$pre,$post) = &getType($widget)."-$res";
    if ($token eq 'asciiText-file' && !$value{"$widget$;$res"}) {
	$pre = "sV $widget string {/dev/null}";
    } elsif ($token eq 'list-list') {
	$pre = "sV $widget numberStrings 0";
	$post = "echo sV $widget: numberStrings [llength {$theValue}]";
    } 
    $references{"$widget$;$res"} = $theValue if $widgetReference{$res};
#    print "$pre;sV $widget $res {$theValue};$post\n\n";
    &Xui("$pre;sV $widget $res {$theValue};$post");
}

#
#
# put argument between braces if needed
sub groupedArg {
    local($arg) = @_;
    return "{$arg}" if $value =~ /[ \]\[]/ || $value eq '';
    return $arg;
}

#sub substituteNames {
#    local($res) = @_;
#    foreach $oldName (keys %substituteName) {
#	$res =~ s/\b$oldName\b/$substituteName{$oldName}/g;
#    }
#    $res;
#}        

sub substituteNames {
    local($string) = @_;
    foreach (reverse sort keys %invName) {
	next if $_ eq $invName{$_};
#	print "+++++++ $_ substitutes $invName{$_}\n";
	$string =~ s/\b$invName{$_}\b/$_/g;
    }
    return($string);
}

sub intoTree {
    local($w,$father,$u) = @_;
    &Xui("box b_$w b_$father $u hSpace 20 orientation vertical borderWidth 0 vSpace 1;"
	 ."toggle t_$w b_$w $u label $w width 200 $buttonAtts callback {echo toggle $w}"), 
	return "b_$w t_$w" if $R4;
    &Xui("toggle t_$w tree $u treeParent t_$father label $w $buttonAtts callback {echo toggle $w}");
    return "t_$w";
}

sub intoForm {
    local($type,$name,$father,$unmanaged,$state,$props) = @_;
    local($tcl);
    $tcl .= "$type $name $father $unmanaged $props;";
    $tcl .= "setWidget $name 1;" if $state eq 'active';
    $tcl .= "action $name override {Shift<Btn3Down>: exec(echo toggle %w)};" 
	if $father !~ /plot/;
    &Xui($tcl), return if $father !~ /^form\d/;
#    $tcl .= "echoPos $name +0;" 
#	if $props !~ /\bfromVert\b/ && $props !~ /\bfromHoriz\b/;
    $tcl .= "action $name override {Shift<Btn1Motion>: exec(global X Y;"
	 ."sV $name horizDistance \[expr %X-\$X\] vertDistance \[expr 1+%Y-\$Y\])};"
         ."action $name override {Shift<Btn1Up>: exec(echoPos %w +0)};"
	 ."action $name override {Shift<Btn1Down>: exec(global X Y;translateCoords $father 0 0 X Y)}";
    &Xui($tcl);
}

sub newWidget {
    local($type,$name,$father,$unmanaged,$state,$props) = @_;
    local($unmanagedWidgets,$toManage);
    $widget{$name} = $state ? 'active' : 'passive';
    $father{$name} = $father;
    print "newWidget <$type> <$name> <$father>\n";
    local($unmanagedWidgets) = &intoTree($name,$father,$unmanaged);
#    print "props for $type $name before <$props>\n";
#    $props = $props || &setDefaultResources($type);
#    print "props for $type $name after <$props>\n";
    ($unmanaged,$toManage) = $type =~ /[Ss]hell/ ? ("","") : ($unmanaged,$name);
    &intoForm($type,$name,$father, $unmanaged,$widget{$name},
	      &expandPerlVariables($props));
    &possibleChildren("$name",1);
    return "$unmanagedWidgets $toManage ";
}

sub duplicateWidgets {
    local($top,@widgets) = @_;
    local($father,$cmd);
    foreach $w (&composite(@widgets),&simple(@widgets)) {
	$type = &getType($w);
	$newName = &newName($type);
	$substituteName{$w} = $newName;
	$father = $substituteName{$father{$w}} || $father{$w};
	&newWidget($type,$newName,$father,"",0,
            join(" ",&setProps($newName,&getProps($w)))); 
	&Xui("echoPos $newName +15") if $top;
        foreach (grep(/^$w$;/,keys %extra)) {
            ($w,$cmd) = split(/$;/,$_);
	    $extra{"$newName$;$cmd"} = $extra{$_};
	    &Xui("$cmd $newName $extra{$_}");
	}
	&duplicateWidgets(0,&children($w));
    }
    undef %substituteName if $top;
}

sub loadWidgets {
    local($mode,$newProgram,@line) = @_;
    local($line,$defaultFather);
    local($loadedTcl);

    # collate names of all loaded widgets and compute new names
    foreach (@line) {
	next if /^[#;]/ || /^\s*$/ || /^\s*realize/;
        $line .= $`,next if m/\\?\\\s*$/;
        $line .= $_; 
        $line = "",next if $line =~ /^sV/ || 
		   ($line =~ /^(\S+)\s/ && $isExtraProc{$1});
	local($type,$oldName,$oldFather,$res) = 
		   $line =~ m/^(\S+)\s+(\S+)\s+(\S+)\s*(.*)$/;
        $line = '';
	next if $mode eq 'into' && $oldFather eq 'topLevel';
        local($oldNr) = $oldName =~ m/\D(\d+)$/;
	$substituteName{$oldName} = &newName($type,$oldNr);
#       print "11111111 <$oldName> ==> <$substituteName{$oldName}>\n";
    }

    # build inverse name lookup table
    local(%invName);
    grep(($invName{$substituteName{$_}}=$_),keys %substituteName);

    #second pass: generate widgets with new names
    local($unManaged);
    foreach (@line) {
	next if /^[#;]/ || /^\s*$/ || /^\s*realize/;
        $line .= $`,next if m/\\?\\\s*$/;
        $line .= $_;
 print "assembled line = <$line>\n";
#  $dummy = <STDIN>;

        local($cmd,$oldName,$rest) = $line =~ /^\s*(\S+)\s+(\S+)\s+(\S.*)$/;
	$line = '';
        if ($cmd eq 'sV' || $isExtraProc{$cmd}) {
            $rest = &substituteNames($rest);
	    local($command) = "$cmd $substituteName{$oldName} $rest";
	    $extra{"$substituteName{$oldName}$;$cmd"} = $rest;
	    print "command: $command\n";
	    &Xui($command);
            next;
	} 
	local($oldFather,$res) = $rest =~ m/^(\S+)\s+(\S+.*)$/;
	local($newRes) = &substituteNames($res);

	if ($mode eq 'into' && $oldFather eq 'topLevel') {
	    &Xui('sV form1 '.&expandPerlVariables(
		     join(" ",&setProps("form1",&parseProps($newRes)))));
	    next;
	}
	local($newName) = $substituteName{$oldName};
	local($newFather) = 
		   $substituteName{$oldFather} 
		   || $defaultFather
		   || ($defaultFather = &findFather($cmd));
	$unManaged .= &newWidget($cmd,$newName,$newFather,'unmanaged',0,
		   join(" ",&setProps($newName,&parseProps($newRes))));
    }
    $currentProgram = &substituteNames($currentProgram) if $newProgram;
    &Xui("manageChild $unManaged");
    undef %substituteName;
}

sub deleteWidgets {
    local(@widgets) = @_;
    foreach $w (&simple(@widgets),&composite(@widgets)) {
	next if $w eq 'form1'; #never delete form1
	&deleteWidgets(&children($w));
	if ($widget{$w}) { 
	    undef $widget{$w};
	    undef $father{$w};
	    &Xui("unsetWidget $w 1;destroyWidget $w t_$w") if !$R4;
	    &Xui("unsetWidget $w 1;destroyWidget $w b_$w") if $R4;
	}
	grep(/^$w$;/ && undef $value{$_},keys %value);
	grep(/^$w$;/ && undef $extra{$_},keys %extra);
	grep(/^$w$;/ && undef $references{$_},keys %references);
	&possibleChildren($w,0);
#	print "delete: <$w>, father = <$father{$w}>\n";
    }
}

sub getProps {
    local($widget) = @_;
    local(@props);
    foreach $nr (grep(/^$widget$;/,keys %value)) {
	($name,$res) = split(/$;/,$nr);
	push(@props, ($value{$nr} =~ /\$/) ? $value{$nr} : "$res {$value{$nr}}")
	    if $value{$nr} ne "" || $allowEmpty =~ /\b$res\b/;
    }
    return @props;
}

sub setProps {
    local($widget,@props) = @_;
    local($res,$val,$theValue);
    foreach (@props) {
#        print "      parsing <$_> ... \n";
        $theValue = &expandPerlVariables($_);
#        print "      the Value <$theValue> ... \n";
        ($res,$val) = ($theValue =~ /^(\S+)\s?(.*)$/);
	($val) =~ s/^{(.*)}$/$1/;
        $references{"$widget$;$res"} = $val if $widgetReference{$res};
	$value{"$widget$;$res"} = m/^\$/ ? $_ : $val;
#	print "      setProps: <<$theValue>> <$widget:$res> = <$_>\n";
    }
    return @props;
}

sub setDefaultResources {
    local($type) = @_;
    return "width 100 height 100" if $compositeWidgets{$type};
    return "";
}




#print "Result: ".join("\n",(&parseProps("a {b} c d "
#	." g {} h {das ist eine \\{ Klaammer}"
#	." e {aaa {bbb} ccc} "
#)))."\n\n";

sub findNonEscaped {
    local($_,$char,$pos) = @_;
#    return length($`)+1+$pos if substr($_,$pos) =~ m/^[^$char]*[^\\]$char/;
    return length($`)+1+$pos if substr($_,$pos) =~ m/[^\\]$char/;
    return -1;
}

sub parseProps {
    local($_) = @_;
    local(@props);
#	print "parsing props <$_>\n";
    while (!/^$/) {
	s/^\s+//;
	push(@props,$1),next if s/^(\$\S+)//;
	push(@props,"$1 {$2}"),next if s/^(\S+)\s+{([^{]*)}//;
        if (s/^(\S+)\s+{(.*)$//) {
	    local($res,$string)=($1,$2);
#	    print "looking for closing bracket in <$string>\n";
            local($pos,$level) = ($[,1);
	    while ($level && $pos<length($string)) {
		local($openBrace) = &findNonEscaped($string,'{',$pos);
		local($closeBrace) = &findNonEscaped($string,'}',$pos);
#print "pos $pos, level $level, open $openBrace, "
#."close $closeBrace c=<".substr($string,$pos,1).">\n";
		$level++,$pos=++$openBrace,next 
		    if $openBrace > -1 && 
			($openBrace < $closeBrace || $closeBrace == -1);
		$level--,$pos=++$closeBrace,next 
		    if $closeBrace > -1 && 
			($closeBrace < $openBrace || $openBrace == -1);
                $level=0, next if $closeBrace == $openBrace;
	    }
#	    print "parsed: <$res> = <".substr($string,0,$pos).">\n";
	    push(@props,"$res {".substr($string,0,$pos));
	    $_ = substr($string,$pos+1);
#	    print "continuing with : <$_>\n";
            next;
        }
	push(@props,"$1 $2"),next if s/^(\S+)\s+(\S+)//;
#        print "restprops = <$_>\n";						 
    }
#	print "props = ",join("--",@props),".\n";
    return @props;
}


sub generateProgram {
    local($inlang,$filename) = @_;
    local(%props,$tcl,$type,$props);
    # print "lang = $inlang, filename =<$filename>\n";
    foreach $nr (keys %value) {
	($name,$res) = split(/$;/,$nr);
	local($value) = $value{$nr};
	$props{$name} .= 
	    $value =~ /^\$/ ? "$;$value" : "$;$res ".&groupedArg($value)
		if $value{$nr} ne "" || $allowEmpty =~ /\b$res\b/;
    }
    foreach (&topSort(&widgets)) {
	($type) = m/^(\D+)\d/;
	$props = $inlang eq 'perl' ? 
		join(" \\\\\n\t",split(/$;/,$props{$_})) :
 	        join(" \\\n\t",split(/$;/,&expandPerlVariables($props{$_})));
	$tcl .=  "$type $_ $father{$_} $props\n";
    }
    foreach $nc (keys %extra) {
	($name,$cmd) = split(/$;/,$nc);
	$tcl .= "$cmd $name $extra{$nc}\n" if $extra{$nc};
    }
    $tcl .= "realize\n";

#	print "tcl = <<$tcl>>\n\n";
    local($tclIntro);
    if ($inlang eq 'tcl') {
        $tclIntro = $defaultResources ? ";mergeResources $defaultResources\n" : "";
    } 

    $*=1; 
#    print "inlang <$inlang> currentLang <$currentLang> currentprog <$currentProgram>\n";
    ($program = 
              ($inlang eq $currentLang ? $currentProgram : "") || 
              ($inlang eq 'perl' ? 
		     $defaultPerlProgram : 
		     $defaultTclProgram)) =~ 
	    s/$BEGIN$END/$BEGIN$tcl$END/;
    $*=0;
    &wafe'tunnel("COMM",$program, "sV dmText type string string \$COMM");

    if ($filename) {
        &info("writing to $filename");
	open(OUT,">$filename") || warn "cannot save in $filename\n" && next;
	print OUT $program;
	close(OUT);
	system "chmod +x $filename";
	system "ln -s /usr/bin/X11/wafe ./x$filename" 
            if $inlang eq 'perl' && !-r "./x$filename" ;
#        print "saved: $program\n\n\n";  
    }
#        print $program;
}

# topological sort
# uses %father and %references
sub topSort {
    local(@toSort) = @_;
    local(@topNodes,%needs,@order) = ('topLevel');

    foreach $w (@toSort) {
	$needs{$w} = $father{$w};
	grep(/^$w$;/ && ($needs{$w}.=" $references{$_}"),keys %references);
    }
    while (@toSort) {
#       print "______ tosort = ",join(", ", @toSort),"\n";
	local(@top,%mark);
        # remove  each $topNode from dependencies and mark new topNodes 
	foreach $topNode (@topNodes) {
	    push(@top,sort grep($needs{$_} =~ s/\b$topNode\b// && 
			   $needs{$_} =~ m/^\s*$/ &&
			   ++$mark{$_}, @toSort));
	}
	push(@order,@topNodes = @top);
        # remove @topNodes from @toSort
	@toSort = grep(!$mark{$_},@toSort);
    }
#    print "topSort returns ",join(",",@order),"\n";
    return @order;
}

sub possibleChildren {
    local($w,$add) = @_;
    local($type) = &getType($w);
    return if !$typeIsComposite{$type};
    if ($add) {
	foreach(&types) {
	    $canBeChildOf{$_} .= " $w" 
		if $compositeWidgets{$type} =~ /\b$_\b/ &&
		    $canBeChildOf{$_} !~ /\b$w\b/;
	}
    } else {
	grep($canBeChildOf{$_} =~ s/\s+$w\b//, &types);
    }
    foreach(&types) {
#	print " canBeChildOf{$_} = $canBeChildOf{$_}\n";
	&wafe'sensitive($canBeChildOf{$_} ne "","w_$_");
    }
}

foreach (keys %compositeWidgets) {$typeIsComposite{$_} = 1;}
$name{"form"} = 1;
$father = "form1";
$father{"form1"} = "topLevel";
$widget{"form1"} = "passive";
$value{"form1$;sensitive"} = "true";

&possibleChildren("form1",1);

while(<STDIN>) {
    chop;
    print "---> <$_>\n";

    if (($type) = /^new w_(.*)$/) {
	local($father);
#	print "simple active: ", join("--",(&simple(&active(&widgets)))),"\n";
	foreach (&simple(&active(&widgets))) {
	    &Xui("unsetWidget $_ 0"); 
	    $widget{$_} = 'passive';
	}
        &newWidget($type,&newName($type),&findFather($type),"",1);
    }

    if (/^toggle (\S+)\s?(\d?)/) {
        local($state) = ($2 == 1) && "active" || ($2 == -1) && "passive";
        $widget{$1} = $state || $invert{$widget{$1}};
        &Xui(($widget{$1} eq "active" ? "setWidget" : "unsetWidget")." $1 1");
    }

    if (/^sV ([^:]+):\s+(\S+)\s+(.*)$/) {
        ($widgets,$res,$val) = ($1,$2,$3);
        $theValue = &expandPerlVariables($val);
        $theValue = $2 if $theValue =~ /^(\S+)\s+(.*)$/ && $1 eq $res;
	foreach $widget (split(/ /,$widgets)) {
            if (($cmd) = $res =~ /^\*(.*)$/) {
		$extra{"$widget$;$cmd"} = $val;
                &Xui("$cmd $widget $val");
                print "      executing: $cmd $widget $val\n";
	    } else {
		$value{"$widget$;$res"} = $val;
                &setValue($widget,$res,$theValue);
#                print "      sV $widget $res {$theValue}\n";
	    }
	}
    }

    if (($widgets,$type,$res) = /^set\s+([^:]+):\s+(\S+)\s+(.*)$/) {
        next if $res eq 'numberStrings';   # ignore attempts in list widget

	grep(($val = $value{"$_$;$res"}), split(/ /,$widgets));
        if ($domain{$type}) {
	    local($vals) = join(" ",grep($_ = "{$_ ".($_ eq $val ? 'True}':'False}'),
					 split(/\s+/,$domain{$type})));
	    &Xui("global r;set r {$res}; menu {Value for \"$res\":} {$vals}");
	} else {
	    &Xui("sV setvaltext value {$val} label \"Enter Ressource Value\\n$type: $res\";"
	     ."global r;set r {$res}; popup setvalmenu none");
	}
    } else {   # pseudo resources
	if (($widgets,$res) = /^set\s+([^:]+):\s+\*(\S+)$/) {
	    foreach $widget (split(/ /,$widgets)) {
		$val = $extra{"$widget$;$res"}; 
	    }
	    &Xui("sV setvaltext value {$val} label \"Enter Ressource Value\\n*$res:\";"
		 ."global r;set r {*$res}; popup setvalmenu none");
	}
    }

    &duplicateWidgets(1,&active(keys %widget)) if /^duplicate/;
    &deleteWidgets(&active(keys %widget)) if /^delete/;

    if (($l,$fileName) = /^dump\s*(\S*)\s*(\S*)$/) {
        if ($fileName) {  # we have a filename but no language
	    $saveUnder = $fileName;
	    $currentFileName = $fileName;
            $l = $lang;
	} elsif ($l) {  # we have no filename but a language
 	    $lang = $l;
	} else { #we have nothing
            $l = $currentLang || $lang;
        }
        &generateProgram($l,$fileName);
     }


    if (($mode,$fn) = /^file\s+(\S+)\s*(\S*)\s*$/) {
        local($tcl,$content,$newProgram);
        undef $/; 
        open(IN,"<$fn") && ($content= <IN>) && close(IN) || 
                warn "cannot open file $fn", next;
        $currentFileName = $fn;
        
        &deleteWidgets(&children('form1')), $mode = 'into',
        undef $currentProgram 
            if $mode eq 'new';

        $/ = "\n";
        if ($content =~ m|^(#!.*\n[\000-\377]*$BEGIN)([\000-\377]*)($END[\000-\377]*)$|) {
           $tcl = $2;
           local($prog) = $1 . $3;
           $lang = ($prog =~ /^.*perl/) ? 'perl' : 'tcl';
           if (!$currentProgram) {
               $currentProgram = $prog;
               $newProgram = 1;
               $currentProgramName = $fn;
               $currentLang = $lang;
	       &Xui("sV dmFn string $fn;sV preview title {Preview: $fn}"); 
           }
       } else {  ## program is not BEGIN END terminated. last chance
           ($tcl) = $content =~ m|^#!/.*wafe.*\n([\000-\377]*)$|;
           $lang = 'tcl';
       }

        &warn("$fn is not a valid wafe program!"),next if !$tcl;
        &loadWidgets($mode,$newProgram,split(/\n/,$tcl));
    }

    eval $1 if /^perl (.*)/; 
}
&wafe'cleanup; 




