#!/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($_=&wafe'read) {
    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";
&Xui( <<"__");
form top topLevel 
  label info top label {} width 700 $infoColors
  form paned top width 700 height 520 \\
      left chainLeft right chainRight bottom chainBottom fromVert info 
    form widgets paned defaultDistance 0 borderWidth 0
      label titleWidgets widgets label {Widgets:} borderWidth 0 $top $boldFont
      list resList widgets {
	 verticalList true forceColumns true 
         $top height 549 width 300 
         horizDistance 120 fromVert titleWidgets bottom chainBottom 
         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 Remove $buttonAtts \\
         callback {echo %w} \\
         fromVert form1 fromHoriz duplicate 

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

   transientShell  filemenu topLevel 
   callback filemenu popupCallback position top:100/250
      form fmform filemenu
      list fmlist fmform defaultColumns 5 callback {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

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
}
__

&Xui(<<'__');
proc doDir {ndir} {global dir
    set dir $ndir
    sV fmdir string $dir
    listChange fmlist 0 0 1 List [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
          }
     }
     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 topLevel {
    *resizable true
    *AtPlotter.width 100
    *AtPlotter.height 100 
}

set dir {*}
set w {}
__

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

$tcl = 'mergeResources topLevel ';
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 borderWidth 0
    panner pan theTree top chainTop width 50 height 50
    action theTree override {\\
       <Key>d: exec(echo duplicate)
       <Key>r: exec(echo delete)
    }
    label titleTree theTree {
       label {Tree:} borderWidth 0 
       $top $boldFont fromHoriz pan
    }
    porthole hole theTree {
       height 510 width 250 
       $top bottom chainBottom 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; deleteWindowProtocol quit; 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";
    return @activeCandidates[$[] if @activeCandidates>0;
    return @candidates[$[] if @candidates>0;
    return "form1";
}
sub expandPerlVariables {
    local($_) = @_;
    local($theValue);
    s/\"/\\\"/g;
    eval '$theValue =  "' . $_ . '";';
    warn $@ if $@;
    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}]";
    } elsif ($res eq 'label') {
	&Xui("sV t_$widget label {$widget: $theValue}");
    }
    $references{"$widget$;$res"} = $theValue if $widgetReference{$res};
    &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($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,$f,$u) = @_;
    local($label) = 
	defined($value{"$w$;label"}) ?  "{$w: ".$value{"$w$;label"}."}" : $w;
    &Xui("box b_$w b_$f $u hSpace 20 orientation vertical borderWidth 0 vSpace 1;"
	 ."toggle t_$w b_$w $u label $label width 200 $buttonAtts callback {echo toggle $w}"),
	return "b_$w t_$w" if $R4;
    &Xui("toggle t_$w tree $u treeParent t_$f label $label $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/ && $name !~ /^sme/;
    &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);
    local($newFather,$newName,$treeChildren,$unManaged);
    foreach (@line) {
	next if /^[#;]/ || /^\s*$/ || /^\s*realize/;
        $line .= $`,next if m/\\?\\\s*$/;
        $line .= $_;
#	print "assembled line = <$line>\n";

        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+)\b\s*(\S*.*)$/;
	local($newRes) = &substituteNames($res);

	if ($mode eq 'into' && $oldFather eq 'topLevel') {
	    &Xui('sV form1 '.&expandPerlVariables(
		     join(" ",&setProps("form1",&parseProps($newRes)))));
	    next;
	}
	$newName = $substituteName{$oldName};
#   print "oldfather <$oldFather> subst <$substituteName{$oldFather}>\n";
	$newFather = 
		   $substituteName{$oldFather} 
		   || $defaultFather
		   || ($defaultFather = &findFather($cmd));

	($treeChildren,$unManaged) =
		   &newWidget($cmd,$newName,$newFather,'unmanaged',0,
		   join(" ",&setProps($newName,&parseProps($newRes))));

	$unManaged{$newFather} .= " ".$unManaged;
	$unManaged{"tree"} .= " ".$treeChildren;
	 
    }
    $currentProgram = &substituteNames($currentProgram) if $newProgram;

    foreach (keys %unManaged) {
	&Xui("manageChild $unManaged{$_}");
    }
    undef %substituteName;
}

sub deleteWidgets {
    local(@widgets) = @_;
    local(%unManage);
    foreach (@widgets) { $unManage{$father{$_}} .= " $_"; }
    foreach (keys %unManage) {
	&Xui("unmanageChild $unManage{$_}");
    }
    undef %unManage;
    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($R4 ? "unsetWidget $w 1;destroyWidget $w b_$w" :
		 "unsetWidget $w 1;destroyWidget $w t_$w");
	}
	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 "";
}


sub findNonEscaped {
    local($_,$char,$pos) = @_;
    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);
		$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 topLevel $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} !~ /\b$references{$_}\b/)
	     && ($needs{$w}.=" $references{$_}")
	     ,keys %references);
#	print "<$w> needs <$needs{$w}>\n";
    }
    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($_=&wafe'read) {
    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; 




