our $VERSION = "2021.03.04.13"; our $K_DRIVE=1; ## 0 normal, 1 kdrive only update my @N = split(/[\/\\]/,$0); my $DEBUG=0; $|=1; =begin comment ... Pod Style Block Comments Blah Blah blah .... =end comment =cut use Getopt::Long; require "c:\\bin\\hegpublish.pl"; use Tk; use File::Basename; use File::Temp qw/ tempfile /; use Config::General qw(ParseConfig SaveConfig); use Tk::DragDrop; use Tk::DropSite; use Tk::Table; use Tk::Dialog; use strict; use warnings; my $APPDATA = $ENV{'APPDATA'}; my $ACTIVE; my %CONFIG; my $CONFIG; my $DIE; my %HASH; my $HELP; my $RESET; my @STAT; my $FILENAME; my $SHUFFLE=0; my $HELP_TEXT = "$0 - $VERSION\n Command Line: -debug Debug Mode -filename \"filename\" Command Line Open \"filename\". -help This Text. -reset Reset Options. -Shuffle -NoShuffle AutoShuffle Specials -version Version Info Gui Help: Minions, Lts, Bosses, Others - Select the subtype of critter. Drag and Drop - to Reorder Lists Reread - Reread and Resync the Current File. Rebuild - Rebuild the .critter files from the .cvg Recompile - Rebuild the .cvg file from the .critter files Shuffle - Shuffle the current Critter type. Split - Split the deck to attempt to remove pairs. Sort - Sort the Critters by name. Merge - Merge two cvg files. Ratio - Ratio how many to grab from each file. EX 1:2 will result in 1 from file1 for every 2 from file2. 0 is do not merge this Critter type. Truncate - Truncate if either file1 or file2 runs out of Critters. Merge File - Press to Select file2. "; $HELP = 1 if (!GetOptions( 'Filename=s{0,1}' => \$FILENAME, 'HELP' => \$HELP, 'RESET' => \$RESET, 'Shuffle!' => \$SHUFFLE, 'VERSION' => sub {print "$0 - $VERSION\n\n"; $DIE++;}, 'DEBUG' => \$DEBUG, )); if ($DIE) { ## for some reason you can't exit or die inside GetOptions. exit; } if ($HELP) { print "$HELP_TEXT"; exit;} { my ($name,$path,$suffix) = fileparse($0,(".pl")); $CONFIG = "$APPDATA\\heg\\$name.cfg"; } if (! -d "$APPDATA\\heg") { mkdir("$APPDATA\\heg") or die; } if (! $RESET && -f $CONFIG) { ## print "Reading Config\n"; %CONFIG = ParseConfig($CONFIG); ## SaveConfig("rcfile", \%some_hash); } else { print "Loading Defaults\n"; %CONFIG = ( 'filename' => '', ); } if (defined $FILENAME && $FILENAME ne '') { $CONFIG{filename}=$FILENAME; } ## let !-f pass to cvg_read so it can post cvg_warn to the gui ## MAINWINDOW my $MW = MainWindow->new(); ## $MW->focusFollowsMouse; ## Use explicit bindinds instad, otherwise the merge popup is a pita. global_set_title(""); $MW->geometry("800x650+65+5"); my $MWF = $MW->Frame()->pack(-side=>'left', -fill => 'y'); my $MWG = $MWF->Frame()->pack(-side => 'top', -fill => 'x'); my $MWH = $MWF->Frame()->pack(-side => 'top', -fill => 'y', -expand => 1); my $MW_TOP = $MWG->Frame()->pack(-side => 'left', -fill => 'x',); my $MW_HELP = $MWG->Frame()->pack(-side => 'right',); my $MW_BODY = $MWH->Frame()->pack(-side => 'top', -fill => 'y', -expand => 1); my $MIN_BOX; my @MIN_ARRAY; ## Menu Buttons $MW_TOP->Button(-text => "Open", -command => sub { $CONFIG{filename} = "" unless (defined $CONFIG{filename} && -f $CONFIG{filename}); my ($name,$path,$suffix) = fileparse($CONFIG{filename},(".cvg")); my ($tmp) = $MW->getOpenFile( -initialdir => $path, -filetypes => [['Custom Villain Group', ['.cvg',]],['All Files','.*']], -defaultextension => '.cvg', -multiple => 0, ); if (defined $tmp && -f $tmp) { @STAT = stat($tmp); splice(@STAT,8,1) if ($#STAT >= 8); %HASH = cvg_read($tmp) or cvg_die(__LINE__); $CONFIG{filename} = $tmp; global_set_title($tmp); global_set_listbox($MIN_BOX,\@MIN_ARRAY,\%HASH,'minions'); } })->pack(-side => 'left'); $MW_TOP->Button(-text => "Reread", -command => sub { my $tmp = $HASH{filename}; if (defined $tmp && -f $tmp) { @STAT = stat($tmp); splice(@STAT,8,1) if ($#STAT >= 8); %HASH = cvg_read($tmp) or cvg_die(__LINE__); $CONFIG{filename} = $tmp; global_set_title($tmp); global_set_listbox($MIN_BOX,\@MIN_ARRAY,\%HASH,'minions'); } })->pack(-side => 'left'); $MW_TOP->Button(-text => "Save", -command => sub { cvg_write ($HASH{filename},%HASH); @STAT = stat($HASH{filename}); splice(@STAT,8,1) if ($#STAT >= 8); })->pack(-side => 'left'); $MW_TOP->Button(-text => "Saveas", -command => sub { $CONFIG{filename} = "" unless (defined $CONFIG{filename} && -f $CONFIG{filename}); my ($name,$path,$suffix) = fileparse($CONFIG{filename},(".cvg")); my ($tmp) = $MW->getSaveFile( -initialfile => $CONFIG{filename}, -filetypes => [['Custom Villain Group', ['.cvg',]],['All Files','.*']], -defaultextension => '.cvg', ); if (defined $tmp) { $HASH{filename} = $CONFIG{filename} = $tmp; cvg_write ($HASH{filename},%HASH); @STAT = stat($HASH{filename}); splice(@STAT,8,1) if ($#STAT >= 8); global_set_title($tmp); global_set_listbox($MIN_BOX,\@MIN_ARRAY,\%HASH,'minions'); } })->pack(-side => 'left'); $MW_TOP->Label(-text => "\t", )->pack(-side => 'left'); ## flat, groove, raised, ridge, sunken, solid ## groove, ridge, solid $MW_TOP->Label(-textvariable => \$ACTIVE, -relief => 'groove', -width => 7)->pack(-side => 'left', ); $MW_TOP->Label(-text => "\t", )->pack(-side => 'left'); $MW_TOP->Button(-text => "Minions", -command => sub { global_set_listbox($MIN_BOX,\@MIN_ARRAY,\%HASH,'minions'); })->pack(-side => 'left'); $MW_TOP->Button(-text => "Lts", -command => sub { global_set_listbox($MIN_BOX,\@MIN_ARRAY,\%HASH,'lts'); })->pack(-side => 'left'); $MW_TOP->Button(-text => "Bosses", -command => sub { global_set_listbox($MIN_BOX,\@MIN_ARRAY,\%HASH,'bosses'); })->pack(-side => 'left'); $MW_TOP->Button(-text => "Others", -command => sub { global_set_listbox($MIN_BOX,\@MIN_ARRAY,\%HASH,'others'); })->pack(-side => 'left'); $MW_TOP->Label(-text => "\t", )->pack(-side => 'left'); $MW_TOP->Button(-text => "Shuffle", -command => sub { cvg_shuffle ($MIN_BOX,\@MIN_ARRAY, \%HASH, $ACTIVE); })->pack(-side => 'left'); $MW_TOP->Button(-text => "Split", -command => sub { return unless defined $HASH{$ACTIVE}; $HASH{$ACTIVE} = cvg_split($HASH{$ACTIVE}); global_set_listbox($MIN_BOX,\@MIN_ARRAY,\%HASH,$ACTIVE); })->pack(-side => 'left'); $MW_TOP->Button(-text => "Sort", -command => sub { cvg_sort ($MIN_BOX,\@MIN_ARRAY, \%HASH, $ACTIVE); })->pack(-side => 'left'); $MW_TOP->Button(-text => "Special", -command => sub { cvg_special_sort ($MIN_BOX,\@MIN_ARRAY, \%HASH, $ACTIVE); })->pack(-side => 'left'); my $cmcpop; $MW_TOP->Button(-text => "Merge", -command => sub { cvg_merge_controls($MW,\$cmcpop); })->pack(-side => 'left'); $MW_TOP->Button(-text => "Rebuild", -command => sub { my $answer = $MW->Dialog( -title => 'Rebuild .Critter Files?', -text => 'Are you sure you want to rebuild all .critter files?', -default_button => 'NO', -buttons => [ 'Yes', 'NO'], -bitmap => 'question', )->Show( ); if (defined $answer && $answer eq 'Yes') { cvg_rebuild_critters($MW,\%HASH);} })->pack(-side => 'left'); $MW_TOP->Label(-text => "\t", )->pack(-side => 'left'); $MW_HELP->Button(-text => "Exit", -command => sub { exit; })->pack(-side => 'right'); $MW_HELP->Button(-text => "Help", -command => sub { cvg_info(__LINE__,split(/\n/,$HELP_TEXT)); $ACTIVE='Help' })->pack(-side => 'right'); { my $lb = $MIN_BOX = $MW_BODY->Scrolled('Listbox', -scrollbars => 'se', -height => 50, -width => 110,-font => '{Lucida Console} 8', -selectmode => 'single')->pack(-side => 'left', -fill => 'y', ); $lb->focus; my $dnd_token = { parent => $lb, dnd => undef, text => undef, tmpptr => undef, idx => undef, hash => \%HASH, active => \$ACTIVE, }; $dnd_token->{dnd} = $lb->DragDrop( ## -event => '', ## this is the default event so we don't need to bind it. -sitetypes => ['Local'], -startcommand => [\&DragStart,$dnd_token], ); $lb->DropSite( -droptypes => ['Local'], -dropcommand => [ \&Drop, $dnd_token ], ); $lb->bind('', sub { ## print "Delete, "; print "@_, "; print $Tk::event,"\n"; my ($x) = $lb->curselection; return unless defined $x && defined $ACTIVE && $ACTIVE ne '' && defined $HASH{$ACTIVE}; $lb->delete($x); splice(@{$HASH{$ACTIVE}},$x,1); }); $lb->bind('', sub { ## print "Up, "; print "@_, "; print $Tk::event,"\n"; my ($x) = $lb->curselection; return unless defined $x && $x > 0 && defined $ACTIVE && $ACTIVE ne '' && defined $HASH{$ACTIVE}; my $tmp = $lb->get($x); $lb->delete($x); $lb->insert($x-1,$tmp); $lb->activate($x-1); $lb->selectionSet($x-1); $tmp = splice(@{$HASH{$ACTIVE}},$x,1); splice(@{$HASH{$ACTIVE}},$x-1,0,$tmp); }); $lb->bind('', sub {## print "Down, "; print "@_, "; print $Tk::event,"\n"; my ($x) = $lb->curselection; return unless defined $x && $x < $lb->size - 1 && defined $ACTIVE && $ACTIVE ne '' && defined $HASH{$ACTIVE}; my $tmp = $lb->get($x); $lb->delete($x); $lb->insert($x+1,$tmp); $lb->activate($x+1); $lb->selectionSet($x+1); $tmp = splice(@{$HASH{$ACTIVE}},$x,1); splice(@{$HASH{$ACTIVE}},$x+1,0,$tmp); }); $lb->bind('', sub { ## additional sub-binding, original class bindinds remain. my $x = $lb->index('active'); my ($y) = $lb->curselection; return unless defined $x; if (!defined $y || $x != $y) { $lb->selectionSet($x); } else {$lb->selectionClear($x);}; }); $lb->bind('Tk::Listbox', '', sub { ## global default unbinding, using more specific syntax. my $x = $lb->index('active'); my ($y) = $lb->curselection; return unless defined $x; if (!defined $y || $x != $y) { $lb->selectionSet($x); } else {$lb->selectionClear($x);}; }); } $MW->repeat(7000, sub{ if (defined $CONFIG{filename}) { ## && -f $CONFIG{filename}) { ## let !-f go ahead and send cvg_read so it can cvg_warn to the gui. my @x = stat($CONFIG{filename}); splice(@x,8,1) if ($#x >= 8); if (join("",@x) ne join("",@STAT)) { @STAT = @x; %HASH = cvg_read($CONFIG{filename}) or cvg_die(__LINE__); global_set_title($HASH{filename}); cvg_info(__LINE__,"File Change Detected. Re-Reading File: $CONFIG{filename}"); } } }); ## call this this way so that it can send die to the gui. $MW->after( 1, sub{ my $tmp; if (defined $CONFIG{filename}) {$tmp = $CONFIG{filename}; } if (defined $tmp) { ## && -f $tmp) { ## let !-f go ahead and call cvg_read so it can send cvg_warn to the gui. @STAT = stat($CONFIG{filename}); splice(@STAT,8,1) if ($#STAT >= 8); %HASH = cvg_read($tmp) or cvg_die(__LINE__); global_set_title($HASH{filename}); global_set_listbox($MIN_BOX,\@MIN_ARRAY,\%HASH,'minions'); } }); MainLoop; exit; sub cvg_read { my ($filename) = @_; my $debug = $DEBUG; $filename = "" unless defined $filename; print "Reading: $filename\n" if $debug; my $header; my $flag_h=0; my @list; my $buf; my $indent=0; my $IFP; if (!defined $filename || !-f $filename ) {cvg_warn (__LINE__,"File does not exist: $filename\n ");} else { $filename =~ m/.*\.cvg/ or cvg_warn(__LINE__,"File is not .cvg: $filename\n "); } open ($IFP,"<",$filename) or cvg_warn(__LINE__,"Error opening file: $filename\n "); while (<$IFP>) { if (m/^DisplayName\s+[\w_\-\"]+\s+/i) { $header = $_; print "Header : $header" if $debug; cvg_warn(__LINE__,"flag_h exception") if $flag_h; $flag_h=1;} if ( m/^CustomVillains$/i ) { $list[$#list+1] = $buf = []; } if (m/\s*\{\s*/) { $indent++; } if (m/\s*\}\s*/) { $indent=$indent-1; } ${$buf}[$#{$buf}+1] = $_ unless $indent < 1; } close ($IFP); cvg_warn(__LINE__,"flag_h exception") if not $flag_h; cvg_warn(__LINE__,"indent exception or incomplete file.") if $indent != 0; print "Read [",$#list+1,"] entities.\n"; my ($minions, $lts, $bosses, $others) = split_list(@list); my @minions = @{$minions}; my @lts = @{$lts}; my @bosses = @{$bosses}; my @others = @{$others}; my %hash = ( 'filename' => $filename, 'header' => $header, 'display' => [], 'minions' => [@minions], 'lts' => [@lts], 'bosses' => [@bosses], 'others' => [@others], ); return %hash; } sub split_list { my @list = @_; my (@minions,@lts,@bosses,@others); my %hash = ( minion => 1, lieutentant => 1, boss => 1, eliteboss => 1, archvillain => 1, contact => 1, ); foreach (@list) { my ($name,$rank,$primary,$val1,$secondary,$val2,$group) = powparse($_); $rank=lc($rank); if ($rank eq 'minion') {$minions[$#minions+1]=$_;} elsif ($rank eq 'lieutenant') {$lts[$#lts+1]=$_;} elsif ($rank eq 'boss') {$bosses[$#bosses+1]=$_;} elsif ($rank eq 'eliteboss') {$others[$#others+1]=$_;} else { if (! defined $hash{$rank}) {$hash{$rank}=1; warn "Warning: $rank\n ";}; $others[$#others+1]=$_; } } return ([@minions],[@lts],[@bosses],[@others]); } sub powparse { my ($arrayptr)=@_; my $buf; foreach (@{$arrayptr}) { $buf .= $_; } $buf =~ m/\t+Name\s*([\S "]*)[\r\n]/i or cvg_warn(__LINE__,"powparse exception"); my $name = $1; $name =~ s/\"//g; my $rank; if ($buf =~ m/Designation ([\S ]*)/i) {$rank = $1;} else {$rank = "Minion"; } $buf =~ m/PrimaryPower (\S*)/i; my $primary = $1; $primary =~ s/Mission_Maker_\w*\.//i; $buf =~ m/SelectedPowers (\S*)/i; my $val1 = $1; $buf =~ m/SecondaryPower (\S*)/i; my $secondary = $1; $secondary =~ s/Mission_Maker_\w*\.//i; $buf =~ m/SelectedPowers2 (\d*)/i; my $val2 = $1; $buf =~ m/VillainGroup\s*([\S "]*)/i; my $group = $1; ## ReferenceFile "IC3 MKS_6006.CRITTER" $buf =~ m/\tReferenceFile\s*([\S "]*)/i; my $referencefile = $1; ## print "($name,$rank,$primary,$val1,$secondary,$val2,$group)\n"; return ($name,$rank,$primary,$val1,$secondary,$val2,$group,$referencefile); } sub global_set_title { my ($filename) = @_; my ($BASENAME,undef,undef) = fileparse($0,(".pl",".cvg")); my $TITLE = sprintf("%s: %-50.50s - %s %s",$BASENAME,length($filename) > 50 ? "..." . substr("$filename",length($filename) - 47) : $filename,$VERSION,'@Linea'); $MW->configure( -title => $TITLE, ); SaveConfig($CONFIG,\%CONFIG) if (defined $filename && -f $filename); } sub listboxnames { my @list = @_; my @names; foreach (@list) { $names[$#names+1] = listboxname($_); } return @names; } sub listboxname { my ($ptr) = @_; my ($name,$rank,$primary,$val1,$secondary,$val2,$group,$file) = powparse($_); $file =~ s/\"//ig; $file =~ s/\.critter//i; $group =~ s/\"//ig; my $buf = sprintf(" %-20.20s (%1.1s) %-20.20s %20.20s/%-20.20s %20.20s ",$name,$rank,$group,$primary,$secondary,$file); ## print "$buf\n"; return $buf; } ## global_set_listbox($MIN_BOX,\@MIN_ARRAY,\%HASH,'minions'); sub global_set_listbox { my ($listbox,$arrayptr,$hashptr,$active) = @_; cvg_warn(__LINE__,"hashptr exception") unless defined $hashptr; cvg_warn(__LINE__,"array exception: $active")unless defined $hashptr->{display}; $ACTIVE = $active; @{$hashptr->{display}} = listboxnames(@{$hashptr->{$active}}); $listbox->delete(0,'end'); $listbox->insert('end',@{$hashptr->{display}}); } sub cvg_die { warn "cvg_die: ", join(" ",@_), "\n"; if (defined $MW) { $MW->exit; } exit; } sub cvg_warn { my @array = @_; cvg_die(@array) unless (defined $MIN_BOX); warn "cvg_warn: ", join(" ",@array), "\n"; $MIN_BOX->delete(0,'end'); $MIN_BOX->insert('end',@array); $ACTIVE = 'Warn'; die; } sub cvg_info { my @array = @_; cvg_die(@array) unless (defined $MIN_BOX); $MIN_BOX->delete(0,'end'); $MIN_BOX->insert('end',@array); $ACTIVE = 'Info'; } sub shuffle { my @array = @_; return @array unless $#array >= 0; for (my $i = @array; -- $i;) { my $r = int rand (1 + $i); @array [$i, $r] = @array [$r, $i] unless $r == $i; } return @array; } ## global_set_listbox($MIN_BOX,\@MIN_ARRAY,\%HASH,'minions'); sub cvg_shuffle { my ($listbox,$arrayptr, $hashptr, $active) = @_; return unless defined $active; return unless $active ne ''; return unless defined $hashptr; return unless defined $hashptr->{$active}; my @array = @{$hashptr->{$active}}; @array = shuffle(@array); $hashptr->{$active} = [@array]; @array = listboxnames(@array); $hashptr->{$active."_display"} = [@array]; global_set_listbox($listbox,$arrayptr,$hashptr,$active); } # sort cvg_cmp @bosses sub cvg_sort { my ($listbox,$arrayptr, $hashptr, $active) = @_; return unless defined $active; return unless $active ne ''; return unless defined $hashptr; return unless defined $hashptr->{$active}; my @array = @{$hashptr->{$active}}; @array = sort cvg_cmp @array; $hashptr->{$active} = [@array]; @array = listboxnames(@array); $hashptr->{$active."_display"} = [@array]; global_set_listbox($listbox,$arrayptr,$hashptr,$active); } sub cvg_cmp { our ($a,$b); my ($name,$rank,$primary,$val1,$secondary,$val2,$group,$filename) = powparse($a); my $A = "$name $filename"; ($name,$rank,$primary,$val1,$secondary,$val2,$group,$filename) = powparse($b); my $B = "$name $filename"; return $A cmp $B; } sub cvg_write { my ($filename, %hash) = @_; my $debug = $DEBUG; if (!defined $filename ) {cvg_warn (__LINE__,"Undefined File Name\n ");} print "Checking Data\n" if $debug; my %fhash; my $flag=0; foreach (@{$hash{minions}},@{$hash{lts}},@{$hash{bosses}},@{$hash{others}}) { my ($name,$rank,$primary,$val1,$secondary,$val2,$group,$referencefile)=powparse($_); if (defined $fhash{$referencefile}) { if (!$flag) { $flag=1; warn "Warning: Duplicates Found, Purging Duplicates\n "; } @{$_}=(); print "." if $debug; ## print "Duplicate: $referencefile\n"; } else { $fhash{$referencefile} = 1; } } if ($flag) {print "\n";} if (-f $filename) { $filename =~ m/.*\.cvg/ or cvg_warn(__LINE__,"File is not .cvg: $filename\n "); my $BACKUP = $filename; $BACKUP =~ s/\.cvg$/.bak/ or cvg_warn(__LINE__,"Backup file name error: $BACKUP\n "); print "Backup : $filename\n to : $BACKUP\n" if $debug; copy($filename,$BACKUP) or cvg_warn(__LINE__,"Backup copy erorr: $BACKUP\n "); } my ($name,$path,$suffix) = fileparse($filename,(".cvg")); if ($name =~ m/\./) { cvg_warn(__LINE__,"Error determining output display name"," $filename"," $path + $name + $suffix" ); } my $header = "DisplayName \"$name\"\n"; print "Header : $header" if $debug; if (length($name) > 20) { cvg_warn(__LINE__,"Displayname is too long"," $name"," Length: " . length($name),); } print "Writing: $filename\n" if $debug; my $IFP; open ($IFP,">",$filename) or cvg_warn(__LINE__,"Error opening file: $filename\n "); ## Print Header print $IFP "\n{\n$header"; foreach (@{$hash{minions}}) { my @tmp = @{$_}; foreach (@tmp) { print $IFP $_; } } foreach (@{$hash{lts}}) { my @tmp = @{$_}; foreach (@tmp) { print $IFP $_; } } foreach (@{$hash{bosses}}) { my @tmp = @{$_}; foreach (@tmp) { print $IFP $_; } } foreach (@{$hash{others}}) { my @tmp = @{$_}; foreach (@tmp) { print $IFP $_; } } print $IFP "}\n\n"; close ($IFP); } ## https://perldoc.perl.org/functions/splice.html sub DragStart { my $debug = $DEBUG; my ($dndptr) = @_; if ($debug) { foreach (keys %{$dndptr}) { print "$_: ",$dndptr->{$_}?$dndptr->{$_}:'undef',"\n"; } } my $token = $dndptr->{dnd}; my $site = $token->parent; my $e = $site->XEvent; my $idx = $dndptr->{idx} = $site->index( '@' . $e->x . ',' . $e->y ); if ( defined $idx ) { $token->configure( -text => $site->get($idx), -font => '{Lucida Console} 8' ); $dndptr->{text} = $site->get($idx); $site->delete($idx); my $arrayptr = $dndptr->{hash}->{${$dndptr->{active}}}; $dndptr->{tmpptr} = splice(@{$arrayptr},$idx,1); ## delete and return the deleted value my ( $X, $Y ) = ( $e->X, $e->Y ); $token->MoveToplevelWindow( $X, $Y ); $token->raise; $token->deiconify; $token->FindSite( $X, $Y, $e ); } } sub Drop { my $debug = $DEBUG; my ( $dndptr ) = @_; if ($debug) { foreach (keys %{$dndptr}) { print "$_: ",$dndptr->{$_}?$dndptr->{$_}:'undef',"\n"; } } my $token = $dndptr->{dnd}; my $site = $dndptr->{parent}; my $text = $token->cget('-text'); my $y = $site->pointery - $site->rooty; my $nearest = $site->nearest($y); if ( defined $nearest ) { my @xy = $site->bbox($nearest); if ( $xy[1] + $xy[3] > $y ) { $site->insert( $nearest, $text ); my $arrayptr = $dndptr->{hash}->{${$dndptr->{active}}}; $dndptr->{tmpptr} = splice(@{$arrayptr},$nearest,0,$dndptr->{tmpptr}); } else { $site->insert( 'end', $text ); my $arrayptr = $dndptr->{hash}->{${$dndptr->{active}}}; $dndptr->{tmpptr} = splice(@{$arrayptr},@{$arrayptr},0,$dndptr->{tmpptr}); } } } sub cvg_merge_controls { my ($parent,$ptr) = @_; my $debug = $DEBUG; my $pop = $$ptr; if (defined $pop && Exists($pop)) {$pop->destroy; $pop = $$ptr = undef;} $pop = $$ptr = $parent->Toplevel(-title => 'Merge Controls'); ## ->Show(-popover => 'cursor', -popanchor => 'w',); my ($x,$y) = $parent->pointerxy; $x = "+$x" if ($x>=0); $y = "+$y" if ($y>=0); $pop->geometry("$x$y"); $pop->resizable(0,0); $pop->attributes(-topmost => 1); my $table = $pop->Table( -rows => 7, -columns => 3, -scrollbars => '', ##-fixedrows => 7, ## -fixedcolumns => 2, -takefocus => 1, )->pack(); $table->put(0,1,"Ratio"); $table->put(0,2,"Truncate"); $table->put(1,0,"Minions"); $table->put(2,0,"Lieutenants"); $table->put(3,0,"Bosses"); $table->put(4,0,"Others"); my ($min,$lts,$bosses,$others) = (1,1,1,1); my ($min_t,$lts_t,$bosses_t,$others_t) = (0,0,0,0); my $tmp = $table->Entry(-textvariable => \$min, -width => 5, -justify => 'center'); $table->put(1,1,$tmp); $table->see($tmp); $tmp = $table->Checkbutton(-variable => \$min_t, -justify => 'center'); $table->put(1,2,$tmp); $table->see($tmp); $tmp = $table->Entry(-textvariable => \$lts, -width => 5, -justify => 'center'); $table->put(2,1,$tmp); $table->see($tmp); $tmp = $table->Checkbutton(-variable => \$lts_t, -justify => 'center'); $table->put(2,2,$tmp); $table->see($tmp); $tmp = $table->Entry(-textvariable => \$bosses, -width => 5, -justify => 'center'); $table->put(3,1,$tmp); $table->see($tmp); $tmp = $table->Checkbutton(-variable => \$bosses_t, -justify => 'center'); $table->put(3,2,$tmp); $table->see($tmp); $tmp = $table->Entry(-textvariable => \$others, -width => 5, -justify => 'center'); $table->put(4,1,$tmp); $table->see($tmp); $tmp = $table->Checkbutton(-variable => \$others_t, -justify => 'center'); $table->put(4,2,$tmp); $table->see($tmp); my $filename=""; my $mf; $mf = $pop->Button(-text => "Merge File", -command => sub { $CONFIG{filename} = "" unless (defined $CONFIG{filename} && -f $CONFIG{filename}); my ($name,$path,$suffix) = fileparse($CONFIG{filename},(".cvg")); my ($tmp) = $pop->getOpenFile( -initialdir => $path, -filetypes => [['Custom Villain Group', ['.cvg',]],['All Files','.*']], -defaultextension => '.cvg', -multiple => 0, ); if (defined $tmp && -f $tmp) { $filename = $tmp; ($name,$path,$suffix) = fileparse($filename,(".cvg")); $mf->configure(-text => "$name.$suffix"); } })->pack(); my %hash; $pop->Button(-text => "Execute Merge", -command => sub { if ($debug) { print "Merge File: $filename\n"; print "Minions: $min, $min_t\n"; print "Lieutenants: $lts, $lts_t\n"; print "Bosses: $bosses, $bosses_t\n"; print "Others: $others, $others_t\n"; } if (defined $filename && -f $filename) { %hash = cvg_read($filename) or cvg_die(__LINE__); global_cvg_merge($min,$min_t,$lts,$lts_t,$bosses,$bosses_t,$others,$others_t,%hash,); global_set_listbox($MIN_BOX,\@MIN_ARRAY,\%HASH,'minions'); ## Global Variables Fix this $pop->destroy; $pop = $$ptr = undef; } })->pack(); } ## global_cvg_merge(%hash,$min,$min_t,$lts,$lts_t,$bosses,$bosses_t,$others,$others_t); sub global_cvg_merge { my ($min,$min_t,$lts,$lts_t,$bosses,$bosses_t,$others,$others_t,%hash) = @_; my $debug = 1; $HASH{minions} = [cvg_array_merge($HASH{minions},$hash{minions},$min,$min_t)]; ## Global Variables Fix this $HASH{lts} = [cvg_array_merge($HASH{lts},$hash{lts},$lts,$lts_t)]; $HASH{bosses} = [cvg_array_merge($HASH{bosses},$hash{bosses},$bosses,$bosses_t)]; $HASH{others} = [cvg_array_merge($HASH{others},$hash{others},$others,$others_t)]; } sub cvg_array_merge { my ($arrayptr1, $arrayptr2, $ratio, $truncate) = @_; my $debug = $DEBUG; if ($debug) { print "A: $arrayptr1\n"; print "B: $arrayptr2\n"; print "C: $ratio,$truncate\n"; } my @list1 = @{$arrayptr1}; my @list2 = @{$arrayptr2}; if (defined $ratio && $ratio =~ m/^\s*def\D*\s*$/i) { if ($#list1+1>0 && $#list2+1>0) { $ratio = ($#list1+1) / ($#list2+1); } else {$ratio = 1;} if ($debug) {printf("Setting Default Ratio: %6.3f = (%i) / (%i)\n",$ratio,$#list1+1,$#list2+1);} } elsif (defined $ratio) { my $i=0; my $tmp = $ratio; while($tmp =~ s/[^\d\/\.]/\//g){cvg_warn(__LINE__,"Error Reading Ratio: $ratio as $tmp\n") if $i++>100;}; $i=0; while($tmp =~ s/\/\//\//g){cvg_warn(__LINE__,"Error Reading Ratio: $ratio as $tmp\n") if $i++>100;}; $@ = undef; $tmp = eval($tmp); if ($@) {cvg_warn(__LINE__,"Error Reading Ratio: $ratio\n Error: $@ "); } $ratio = $tmp; } else { $ratio = 0; cvg_warn(__LINE__,"Error. Setting Ratio to Zero. Merge Canceled.\n"); return; } printf("Ratio: %6.3f\n", $ratio) if $debug; cvg_warn(__LINE__, "Ratio Parsing Error, or Range Error: $ratio\n ") if (! defined $ratio || $ratio > 99 || $ratio < 0); if ($ratio == 0) { @list2 = (); $ratio = 1;} ## Zero means do not merge if ($ratio < 1) { $ratio = 1/$ratio; my @tmp=@list1; @list1=@list2; @list2=@tmp; } if ($#list2 < 0 && $debug) { print "Warning: Empty List2 in Merge Function\n"; } if ($#list1 < 0 && $debug) { print "Warning: Empty List1 in Merge Function\n"; @list1 = @list2; @list2 = (); } if ($#list1 < 0 && $debug) { print "Warning: Empty Lists in Merge Function\n";} my ($i,$j,$k)=(0,-1,-1); my @list3=(); my $name; my $x; my $bounds; my ($file); my $flag=0; my %fash=(); for($i=0;$truncate ? ($x = $i/$ratio)<$#list2+1&&$i<=$#list1 : ($x = $i/$ratio)<$#list2+1||$i<=$#list1;$i++) { if ($debug) {printf("%3.3i: ",$i);} $name = "undef"; if (defined $list1[int($i)] && int($i) != $j) { $j = int($i); ($name,undef,undef,undef,undef,undef,undef,$file) = powparse($list1[$j]); if (defined $fash{$file}) { $name = "*** Duplicate Entry ***" if $debug; } else { @list3[$#list3+1]=$list1[$j]; $fash{$file}=1; } if ($debug) { printf("[%5.1f, %3.3i, %20.20s] : ",$j,$j,$name);} } $name = "undef"; if (defined $list2[int($x)] && int($x) != $k) { $k = int($x); ($name,undef,undef,undef,undef,undef,undef,$file) = powparse($list2[$k]); if (defined $fash{$file}) {$name = "*** Duplicate Entry ***" if $debug;} else { @list3[$#list3+1]=$list2[$k]; $fash{$file}=1;} } if ($debug) { printf("[%5.1f, %3.3i, %20.20s] : \n",$x,$x,$name);} } if ($debug) {print "\n";} return @list3; } sub cvg_split { my ($ptr) = @_; my $debug = $DEBUG; return unless defined $ptr; my @list = @{$ptr}; my $repeat=0; my $oops; do { $oops = 0; for (my $i=0; $i <= $#list; $i++) { if (($i>0 && cvg_name($list[$i-1]) eq cvg_name($list[$i])) || ($i+1 <= $#list && cvg_name($list[$i+1]) eq cvg_name($list[$i]))) { my $B = splice(@list,$i,1); my $b = cvg_name($B); my $flag=0; for (my $j=0; $j <= $#list + 1 ; $j++) { if (($j > $#list || $b ne cvg_name($list[$j])) && ($j-1 < 0 || $b ne cvg_name($list[$j-1])) && ( $j> 0 || $j+1 > $#list || $b ne cvg_name($list[$j+1]))) { splice(@list,$j,0,$B); $flag++; $j=$#list+1; } } if (!$flag) { splice(@list,$i,0,$B); $oops++; print "Split Error: Index($i) Name($b)\n" if ($debug && ! $repeat);} } } } while ($oops and $repeat++ < 3); return [@list]; } sub cvg_name { my ($ptr) = @_; my ($name) = powparse($ptr); return $name; } sub cvg_rebuild_critters { my ($mw,$hash) = @_; my $debug = $DEBUG; my @array; my $target = "..\\Custom_Critter"; if (! -e $target) { my ($tmp) = $mw->getSaveFile( -initialfile => "$target\\target.critter", -filetypes => [['Custom Villain Group', ['.critter'],['.cvg',]],['All Files','.*']], -defaultextension => '.cvg', ); if (defined $tmp) { (undef,$target,undef) = fileparse($tmp,(".pl",".cvg")); if (!-e $target) {cvg_warn(__LINE__,"Directory Does not Exist","\t$target")} } else {cvg_warn(__LINE__,"Rebuild Cancelled");}; } foreach (@{$hash->{minions}},@{$hash->{lts}},@{$hash->{bosses}},@{$hash->{others}}) { my ($name,$rank,$primary,$val1,$secondary,$val2,$group,$referencefile)=powparse($_); if (defined $referencefile) { if ($debug) { print "Rebuilding: $target\\$referencefile\n"; } $referencefile =~ s/\"//gi; $array[$#array+1]="$target\\$referencefile"; my $FP; open ($FP, ">", "$target\\$referencefile") or cvg_warn(__LINE__,"Error opening .critter file\n","\t$target\\$referencefile\n"); print $FP "\n"; foreach (@{$_}) { s/^\s*CustomVillains\s*$//i; print $FP $_; } close ($FP); } } if ($debug) { print "Rebuild Complete\n"; } cvg_info(__LINE__,"Rebuild Complete",@array); } ## global_set_listbox($MIN_BOX,\@MIN_ARRAY,\%HASH,'minions'); sub cvg_special_sort { my ($listbox,$arrayptr, $hashptr, $active) = @_; return unless defined $active; return unless $active ne ''; return unless defined $hashptr; return unless defined $hashptr->{$active}; my @array = @{$hashptr->{$active}}; @array = cvg_special_array(@array); $hashptr->{$active} = [@array]; @array = listboxnames(@array); $hashptr->{$active."_display"} = [@array]; global_set_listbox($listbox,$arrayptr,$hashptr,$active); } sub cvg_special_array { my @array = @_; my @bins; my $bins=9; my $debug=1; print "cvg_special_array: $#array\n" if ($debug); return @array unless $#array >= 0; for (my $i=0;$i<$bins;$i++) { $bins[$i] = []; } print "Sorting ($SHUFFLE) ...\n" if ($debug); foreach(@array) { my $name = c_name(@{$_}); print "$name\n" if ($debug); ## cjm =begin comment ## New Version 1. EA-* Buffs/Debuffs A - BA 2. EB-* Buffs/Debuffs B - BB 3. EC-* Control - BC 4. DA-* Dangerous Damage - Ranger, Commando, Scout, Operative, ... Disruptor 5. DB-* Standard Damage - Sergeant, Corporal, Gunner 6. DC-* Alternate Damage - Rifleman, Marksman 7. DD-* Alternate Damage 0. NS-* No Auto-Spawn =end comment =cut ## NEW Version using Name Prefixes ## (1, 4,5,6,7), (2, 4,5,6,7), (3, 4,5,6,7), .... if ($name =~ m/EA-/ ) { my $bin=1; ${$bins[$bin]}[$#{$bins[$bin]}+1] = $_; } elsif ($name =~ m/EB-/ ) { my $bin=2; ${$bins[$bin]}[$#{$bins[$bin]}+1] = $_; } elsif ($name =~ m/EC-/ ) { my $bin=3; ${$bins[$bin]}[$#{$bins[$bin]}+1] = $_; } elsif ($name =~ m/BA-/ ) { my $bin=1; ${$bins[$bin]}[$#{$bins[$bin]}+1] = $_; } elsif ($name =~ m/BB-/ ) { my $bin=2; ${$bins[$bin]}[$#{$bins[$bin]}+1] = $_; } elsif ($name =~ m/BC-/ ) { my $bin=3; ${$bins[$bin]}[$#{$bins[$bin]}+1] = $_; } elsif ($name =~ m/DA-/ ) { my $bin=4; ${$bins[$bin]}[$#{$bins[$bin]}+1] = $_; } elsif ($name =~ m/DB-/ ) { my $bin=5; ${$bins[$bin]}[$#{$bins[$bin]}+1] = $_; } elsif ($name =~ m/DC-/ ) { my $bin=6; ${$bins[$bin]}[$#{$bins[$bin]}+1] = $_; } elsif ($name =~ m/DD-/ ) { my $bin=7; ${$bins[$bin]}[$#{$bins[$bin]}+1] = $_; } elsif ($name =~ m/FA-/ ) { my $bin=8; ${$bins[$bin]}[$#{$bins[$bin]}+1] = $_; } elsif ($name =~ m/AA-/ ) { my $bin=8; ${$bins[$bin]}[$#{$bins[$bin]}+1] = $_; } elsif ($name =~ m/NS-/ ) { my $bin=0; ${$bins[$bin]}[$#{$bins[$bin]}+1] = $_; } ## 6014 Named elsif ($name =~ m/Engineer/ ) { my $bin=1; ${$bins[$bin]}[$#{$bins[$bin]}+1] = $_; } elsif ($name =~ m/Ranger/ ) { my $bin=4; ${$bins[$bin]}[$#{$bins[$bin]}+1] = $_; } elsif ($name =~ m/Commando/ ) { my $bin=4; ${$bins[$bin]}[$#{$bins[$bin]}+1] = $_; } elsif ($name =~ m/Operative/ ) { my $bin=4; ${$bins[$bin]}[$#{$bins[$bin]}+1] = $_; } elsif ($name =~ m/Scout/ ) { my $bin=4; ${$bins[$bin]}[$#{$bins[$bin]}+1] = $_; } elsif ($name =~ m/Sergeant/ ) { my $bin=5; ${$bins[$bin]}[$#{$bins[$bin]}+1] = $_; } elsif ($name =~ m/Corporal/ ) { my $bin=5; ${$bins[$bin]}[$#{$bins[$bin]}+1] = $_; } elsif ($name =~ m/Gunner/ ) { my $bin=5; ${$bins[$bin]}[$#{$bins[$bin]}+1] = $_; } elsif ($name =~ m/Rifle/ ) { my $bin=6; ${$bins[$bin]}[$#{$bins[$bin]}+1] = $_; } elsif ($name =~ m/Marksman/ ) { my $bin=6; ${$bins[$bin]}[$#{$bins[$bin]}+1] = $_; } ## Old Version elsif ($name =~ m/Voidbringer/i || $name =~ m/shocker/i || $name =~ m/lifter/i || $name =~ m/EB-86.*Raider/i || $name =~ m/E-78.*Marauder/i ) { my $bin=3; ${$bins[$bin]}[$#{$bins[$bin]}+1] = $_; } elsif ($name =~ m/Marauder/i || $name =~ m/E-77a Heavy Archer/i ) { my $bin=1; ${$bins[$bin]}[$#{$bins[$bin]}+1] = $_; } elsif ($name =~ m/Raider/i) { my $bin=2; ${$bins[$bin]}[$#{$bins[$bin]}+1] = $_; } elsif ($name =~ m/Grenadier/i || $name =~ m/Sniper/i || $name =~ m/Crusher/i || $name =~ m/Devastator/i || $name =~ m/Javelin/i || $name =~ m/EA.*Cannon/i || $name =~ m/EA.*Heavy Gunner/i ) { my $bin=4; ${$bins[$bin]}[$#{$bins[$bin]}+1] = $_; } elsif ($name =~ m/Ranger/i || $name =~ m/Commando/i || $name =~ m/Disruptor/i || $name =~ m/Archer/i || $name =~ m/Destroyer/i || $name =~ m/Harpoon/i ) { my $bin=4; ${$bins[$bin]}[$#{$bins[$bin]}+1] = $_; } elsif ($name =~ m/Corporal/i ) { my $bin=5; ${$bins[$bin]}[$#{$bins[$bin]}+1] = $_; } elsif ($name =~ m/Sergeant/i || $name =~ /gunner/i ) { my $bin=5; ${$bins[$bin]}[$#{$bins[$bin]}+1] = $_; } else { ${$bins[0]}[$#{$bins[0]}+1] = $_; } } for (my $i=0;$i<$bins;$i++) { $bins[$i]= [shuffle(@{$bins[$i]})] if ($SHUFFLE); } ## print bins if ($debug) { print "\n"; for (my $i=0;$i<$bins;$i++) { print "Bin[$i] := $#{$bins[$i]}\n"; foreach(@{$bins[$i]}) { my $name = c_name(@{$_}); print "$name, "; } print "\n"; } } ## create a new @array; @array = (); { my $loop; my $i=0; do { foreach ($bins[1],$bins[4],$bins[5],$bins[6],$bins[7], $bins[2],$bins[4],$bins[5],$bins[6],$bins[7], $bins[3],$bins[4],$bins[5],$bins[6],$bins[7], $bins[8],$bins[0]) { my $tmp = pop(@{$_}); if (defined $tmp) { $array[$#array+1]=$tmp;} } $loop=0; foreach(@bins) { $loop += $#{$_} >= 0 ? 1 : 0; } } while ($loop && $i++ < 100); if ($i>=100) {die; exit;} } ## print bins if ($debug) { print "\n"; for (my $i=0;$i<$bins;$i++) { print "Bin[$i] := $#{$bins[$i]}\n"; foreach(@{$bins[$i]}) { my $name = c_name(@{$_}); print "$name, "; } print "\n"; } print "Array\n"; foreach(@array) { my $name = c_name(@{$_}); print "$name, "; } print "\n"; } return @array; } sub c_name { my @array = @_; my $buf = join("\n",@array); ## $buf =~ m/ReferenceFile (\"?[\w\ \-\_]*.critter\"?)/i; $buf =~ m/\sname\s+(\"?[\w\ \-\_]*\"?)/i; my $name; if (defined $1) { $name=$1; } else {$name = "n/a";} return $name; }