1package Viz;
2# pragmas
3use strict;
4use warnings;
5no warnings 'redefine';
6# Perl Modules
7use Class::Struct;
8# BNG Modules
9use Visualization::Viz;
10use Visualization::StructureGraph;
11use SpeciesGraph;
12
13struct NetworkGraph =>
14{
15	'NodeList' => '@', # array of strings
16	'EdgeList' => '@', # array of strings
17	'NodeType' => '%', # a hash indicating each node type
18	'NodeClass' => '%', # a hash indicating equivalence class
19	'Name' => '$', # a name which might come in handy to compare/combine rules
20	# of the form <transformationstring>:<atomicpatternstring>:<edgetype>
21	# or <wildcardpattern>:<atomicpatternstring>:Wildcard
22	'Merged'=> 0,
23	'Collapsed'=>0,
24	'Filtered'=>0,
25
26};
27# is methods for checking
28sub isWildcard{ return ($_[0] =~ /\!\+/) ? 1 : 0; }
29
30# basic make methods
31sub makeAtomicPattern
32{
33	my @nodelist = @{shift @_};
34	my $node = shift @_;
35
36	my $type = $node->{'Type'};
37	my $ap;
38	if ($type eq 'CompState')
39		{
40		my $comp = findNode(\@nodelist,${$node->{'Parents'}}[0]);
41		my $mol = findNode(\@nodelist,${$comp->{'Parents'}}[0]);
42		my $string = $mol->{'Name'}."(".$comp->{'Name'}."~".$node->{'Name'}.")";
43		$ap = ($node->{'Name'} ne '?') ?  $string : "";
44		}
45	elsif ($type eq 'BondState')
46		{
47		my @comps = map (findNode(\@nodelist,$_), @{$node->{'Parents'}}) ;
48		my @mols = map (findNode(\@nodelist,${$_->{'Parents'}}[0]), @comps) ;
49		if (scalar @comps == 1)
50			{
51			# it's a wildcard
52			my $string = $mols[0]->{'Name'}."(".$comps[0]->{'Name'}."!".$node->{'Name'}.")";
53			$ap = ($node->{'Name'} ne '?') ?  $string : "";
54			}
55		else
56			{
57			# it's a specified bond
58			my $string1 = $mols[0]->{'Name'}."(".$comps[0]->{'Name'}."!1)";
59			my $string2 = $mols[1]->{'Name'}."(".$comps[1]->{'Name'}."!1)";
60			$ap = join(".", sort {$a cmp $b} ($string1,$string2));
61			}
62		}
63	elsif ($type eq 'Comp')
64		{
65		# return the unbound state
66		# is it really unbound? check it external to this method
67		my $mol = findNode(\@nodelist,${$node->{'Parents'}}[0]);
68		my $string = $mol->{'Name'}."(".$node->{'Name'}.")";
69		$ap = $string;
70		}
71	elsif ($type eq 'Mol')
72		{
73		$ap = $node->{'Name'};
74		}
75	return $ap;
76}
77
78sub makeAtomicPatterns
79{
80	my $nodelist = shift @_;
81	my $nodes = shift @_;
82	my @aps = map { makeAtomicPattern($nodelist,$_)} @$nodes;
83	return @aps;
84}
85
86sub makeTransformation
87{
88	my @nodelist = @{shift @_};
89	my $node = shift @_;
90	my $type = $node->{'Type'};
91	my $name = $node->{'Name'};
92	my $arrow = "->";
93	my $comma = ",";
94	my $tr;
95	if ($type ne 'GraphOp') { return undef; }
96	if ($name eq 'ChangeState')
97		{
98		my @comps = map (findNode(\@nodelist,$_), @{$node->{'Parents'}});
99		my @left = grep( $_->{'Side'} eq 'left', @comps) ;
100		my @right = grep( $_->{'Side'} eq 'right', @comps) ;
101		my $leftstr = makeAtomicPattern(\@nodelist,$left[0]);
102		my $rightstr = makeAtomicPattern(\@nodelist,$right[0]);
103		$tr = $leftstr.$arrow.$rightstr;
104		}
105	elsif ($name eq 'AddBond')
106		{
107		my $bond = findNode(\@nodelist,${$node->{'Parents'}}[0]);
108		my @comps = map (findNode(\@nodelist,$_), @{$bond->{'Parents'}});
109		my @leftstr = sort map ( makeAtomicPattern(\@nodelist,$_),@comps);
110		my $rightstr = makeAtomicPattern(\@nodelist,$bond);
111		$tr = join($comma,@leftstr).$arrow.$rightstr;
112		}
113	elsif ($name eq 'DeleteBond')
114		{
115		my $bond = findNode(\@nodelist,${$node->{'Parents'}}[0]);
116		# bond wildcards are also being deleted when molecules are deleted
117		# how do you transform them into processes?
118		# need to talk to bngdev
119		my @comps = map (findNode(\@nodelist,$_), @{$bond->{'Parents'}});
120		if (scalar @comps == 1) { return ""; }
121		my @rightstr = sort map ( makeAtomicPattern(\@nodelist,$_),@comps);
122		my $leftstr = makeAtomicPattern(\@nodelist,$bond);
123		$tr = $leftstr.$arrow.join($comma,@rightstr);
124		}
125	elsif ($name eq 'AddMol')
126		{
127		my $mol = findNode(\@nodelist,${$node->{'Parents'}}[0]);
128		my $name = makeAtomicPattern(\@nodelist,$mol);
129		$tr = $arrow.$name;
130		}
131	elsif ($name eq 'DeleteMol')
132		{
133		# species deletion is interpreted as molecule deletion
134		# how to check? what to do?
135		my $mol = findNode(\@nodelist,${$node->{'Parents'}}[0]);
136		my $name = makeAtomicPattern(\@nodelist,$mol);
137		$tr = $name.$arrow;
138		}
139	return $tr;
140}
141
142sub makeTransformationDeleteBond
143{
144	my @nodelist = @{shift @_};
145	my $node = shift @_;
146	my $type = $node->{'Type'};
147	my $name = $node->{'Name'};
148	my $arrow = "->";
149	my $comma = ",";
150	my $tr;
151	if ($name eq 'DeleteBond')
152		{
153		my $bond = findNode(\@nodelist,${$node->{'Parents'}}[0]);
154		my @comps = grep {$_->{'Side'} eq 'both'} map (findNode(\@nodelist,$_), @{$bond->{'Parents'}});
155		my @rightstr = sort map ( makeAtomicPattern(\@nodelist,$_),@comps);
156		my $leftstr = makeAtomicPattern(\@nodelist,$bond);
157		$tr = $leftstr.$arrow.join($comma,@rightstr);
158		}
159	return $tr;
160
161}
162
163sub makeEdge
164{
165	my %shortname = ( 'r'=>"Reactant", 'p'=>"Product", 'c'=>"Context", 's'=>"Syndel", 'w'=>"Wildcard", 'pp'=>"ProcessPair", 'co'=>"Cotransform", 'os'=>"Onsite" );
166
167	my $node1 = shift @_;
168	my $node2 = shift @_;
169	my $rel = $shortname{shift @_};
170
171	my $string = $node1.":".$node2.":".$rel;
172	return $string;
173
174}
175
176# print for sanity check
177sub printNetworkGraph
178{
179	my $bpg = shift @_;
180	my @nodelist = @{$bpg->{'NodeList'}};
181	my %nodetype = %{$bpg->{'NodeType'}};
182
183	#get atomic patterns
184	my @ap = grep { $nodetype{$_} eq 'AtomicPattern' } @nodelist;
185	# get binding sites
186	my @bs = sort {$a cmp $b} grep { $_ !~ /~/ and $_ !~ /\!/ } @ap;
187	# get internal states
188	my @is = sort {$a cmp $b} grep {$_ =~ /~/ } @ap;
189	# get bonds
190	my @bonds = sort {$a cmp $b} grep { $_ =~ /\!/ and $_ !~ /\!\+/ } @ap;
191	# wildcards
192	my @wc = sort {$a cmp $b} grep { $_ =~ /\!\+/ } @ap;
193	# rules
194	my @rules = sort {$a cmp $b} grep { $nodetype{$_} eq 'Rule' } @nodelist;
195	# groups
196	my %classes;
197	if(defined $bpg->{'NodeClass'}) {%classes = %{$bpg->{'NodeClass'}};}
198
199	my @rulegroups;
200	my @patterngroups;
201	if($bpg->{'Collapsed'}==1)
202		{
203		@rulegroups = grep {$nodetype{$_} eq 'RuleGroup'} @nodelist;
204		@patterngroups = grep {$nodetype{$_} eq 'PatternGroup'} @nodelist;
205		}
206	else
207		{
208		my @classedrules = grep {$nodetype{$_} eq 'Rule'} keys %classes;
209		@rulegroups = 	map
210							{
211							my $x = $_;
212							$x.":".join(" ",
213								sort {$a cmp $b}
214								grep {$classes{$_} eq $x} @classedrules
215								);
216							}
217							sort {$a cmp $b}
218							uniq( map $classes{$_}, @classedrules);
219		my @classedpatterns = grep {$nodetype{$_} eq 'AtomicPattern'} keys %classes;
220		@patterngroups = map
221							{
222							my $x = $_;
223							$x.":".join(" ",
224								sort {$a cmp $b}
225								grep {$classes{$_} eq $x} @classedpatterns
226								);
227							}
228							sort {$a cmp $b}
229							uniq( map $classes{$_}, @classedpatterns);
230		}
231
232
233	my @str;
234	if(@bs) { push @str,"Binding Sites:\n".join("\n",@bs)."\n"; }
235	if(@is) { push @str,"Internal States:\n".join("\n",@is)."\n"; }
236	if(@bonds) { push @str,"Bonds:\n".join("\n",@bonds)."\n"; }
237	if(@wc) { push @str,"Wildcards:\n".join("\n",@wc)."\n"; }
238	if(@rules) { push @str,"Rules:\n".join("\n",@rules)."\n"; }
239	#if(@groups)
240	#	{
241	#	my @grpstrs = map {$names[$_].":".join(" ",@{$groups[$_]}) } 0..@groups-1;
242	#	push @str,"Groups:\n".join("\n",@grpstrs)."\n";
243	#	}
244	if(@patterngroups) { push @str,"Pattern Groups:\n".join("\n",@patterngroups)."\n"; }
245	if(@rulegroups) { push @str,"Rule Groups:\n".join("\n",@rulegroups)."\n"; }
246
247	my @edgelist = @{$bpg->{'EdgeList'}};
248	my @reac = sort {$a cmp $b} map {$_ =~ /(.*:.*):.*/} grep {$_ =~ /Reactant$/} @edgelist;
249	my @prod = sort {$a cmp $b} map {$_ =~ /(.*:.*):.*/} grep {$_ =~ /Product$/} @edgelist;
250	my @context = sort {$a cmp $b} map {$_ =~ /(.*:.*):.*/} grep {$_ =~ /Context$/} @edgelist;
251	my @wildcards = sort {$a cmp $b} map {$_ =~ /(.*:.*):.*/} grep {$_ =~ /Wildcard$/} @edgelist;
252
253	if(@reac) { push @str,"Reactant Relationships:\n".join("\n",@reac)."\n"; }
254	if(@prod) { push @str,"Product Relationships:\n".join("\n",@prod)."\n"; }
255	if(@context) { push @str,"Context Relationships:\n".join("\n",@context)."\n"; }
256	if(@wildcards) { push @str,"Wildcard Relationships:\n".join("\n",@wildcards)."\n"; }
257
258	return join("\n",@str);
259}
260# text cleaning for atomic patterns and transformations
261sub prettify
262{
263	my $string = shift @_;
264	my $arrow = '->';
265	#print ($string, $string =~ /$arrow/, "\n");
266	# check if it is a transformation
267	if ($string =~ /$arrow/)
268	{
269		# see if arrow has spaces already
270		if ($string =~ /\b$arrow\b/) { return $string;}
271		else
272		{
273			my @splits = split $arrow,$string;
274			if (scalar @splits == 1) { push @splits,"0"; }
275			elsif (length $splits[0] == 0) { $splits[0]="0";}
276			return join(" -> ",map prettify($_), @splits);
277		}
278	}
279	my $comma = ',';
280	if ($string =~ /$comma/)
281	{
282		if ($string =~ /\b$comma\b/) { return $string; }
283		else
284		{
285			my @splits = split $comma,$string;
286			return join(" , ", @splits);
287		}
288	}
289	if ($string =~ /$0^/) { return $string; }
290	#if ($string =~ /\(/)  { return $string; }
291	#else { return $string."\(\)"; }
292	return $string;
293}
294
295sub unprettify
296{
297	my $string = shift @_;
298	$string =~ s/\s//g;
299	$string =~ s/\(\)//g;
300	$string =~ s/^0//g;
301	$string =~ s/0$//g;
302	return $string;
303}
304
305
306
307
308sub combine3
309{
310	my @bpgs = @{shift @_};
311	my @nodelist = ();
312	my @edgelist = ();
313	my %nodetype;
314	foreach my $bpg(@bpgs)
315	{
316		push @nodelist, @{$bpg->{'NodeList'}};
317		push @edgelist, @{$bpg->{'EdgeList'}};
318		foreach my $node( keys %{$bpg->{'NodeType'}} )
319		{
320			$nodetype{$node} = $bpg->{'NodeType'}->{$node};
321		}
322
323	}
324	my $bpg = NetworkGraph->new();
325	$bpg->{'NodeList'} = [uniq(@nodelist)];
326	$bpg->{'EdgeList'} = [uniq(@edgelist)];
327	$bpg->{'NodeType'} = \%nodetype;
328	return $bpg;
329}
330sub addWildcards
331{
332	my $bpg = shift @_;
333	my @nodelist = @{$bpg->{'NodeList'}};
334	my %nodetype = %{$bpg->{'NodeType'}};
335
336	my @ap = grep {$nodetype{$_} eq 'AtomicPattern'} @nodelist;
337	my @wildcards = grep (isWildcard($_), @ap);
338	my @notwildcards = grep (!isWildcard($_), @ap);
339
340	foreach my $wc(@wildcards)
341		{
342		my @splits = split '\+', $wc;
343		my $string = $splits[0];
344
345		my @matches = grep(index($_, $string) != -1, @notwildcards);
346		foreach my $match(@matches)
347			{
348			my $edge = makeEdge($wc,$match,'w');
349			push @{$bpg->{'EdgeList'}},$edge;
350			}
351		}
352	return;
353}
354
355# get methods
356sub getReactantsProducts
357{
358	my $in = shift @_;
359	my $string = unprettify($in);
360	my @splits = split '->',$string;
361	my @reac = ();
362	my @prod = ();
363	if (scalar @splits == 1) { @reac = ($splits[0]); }
364	elsif (length $splits[0] == 0) { @prod = ($splits[1]); }
365	else { @reac = split ',',$splits[0]; @prod = split ',',$splits[1]; }
366	return (\@reac,\@prod);
367}
368
369sub getStructures
370{
371	my @nodelist = @{shift @_};
372	my %structures = ('Mol'=>1,'Comp'=>1,'CompState'=>1,'BondState'=>1,'GraphOp'=>0,'Rule'=>0);
373	my @nodes = grep( $structures{$_->{'Type'}}==1, @nodelist);
374	return @nodes;
375}
376sub getContext
377{
378	my @nodelist = @{shift @_};
379	my @exclude = ();
380	if (@_) { @exclude = @{shift @_} };
381	my @exclude_ids = ();
382	foreach my $exc (@exclude)
383	{
384		my @x = @$exc;
385		my $y = shift @x;
386		push @exclude_ids, map $_->{'ID'}, @x;
387	}
388	#print scalar @exclude_ids;
389	my @nodes_struct = getStructures(\@nodelist);
390	my @nodes = hasSide(\@nodes_struct,'both');
391	my @context = ();
392
393	# comp states
394	my @compstates = 	grep has(\@exclude_ids,$_->{'ID'})==0,
395						hasType(\@nodes,'CompState');
396	if (@compstates)
397	{
398		foreach my $node(@compstates)
399		{
400			my $string = makeAtomicPattern(\@nodes_struct,$node);
401			if ($string) { push @context,$string;}
402		}
403	}
404
405	# bond states
406	my @bondstates = 	grep has(\@exclude_ids,$_->{'ID'})==0,
407						hasType(\@nodes,'BondState');
408	foreach my $node(@bondstates)
409	{
410		my $string = makeAtomicPattern(\@nodes_struct,$node);
411		if ($string) { push @context,$string;}
412	}
413
414	# unbound states
415	my @comps =	grep has(\@exclude_ids,$_->{'ID'})==0,
416				hasType(\@nodes,'Comp');
417	my %unbound;
418	foreach my $x(@comps) { $unbound{$x->{'ID'}}=1; }
419	my @allbonds = hasType(\@nodelist,'BondState');
420	my @allbondparents;
421	foreach my $node(@allbonds) { push @allbondparents, @{$node->{'Parents'}}; }
422	foreach my $x(@allbondparents) { $unbound{$x}=0; }
423	foreach my $x(keys %unbound)
424	{
425		if ($unbound{$x})
426		{
427			my $node = findNode(\@comps,$x);
428			push @context,makeAtomicPattern(\@nodes_struct,$node);
429		}
430	}
431
432	# mol nodes that do not have any components (hence identified by only label)
433	my @mols = hasType(\@nodes,'Mol');
434	my %havenocomps;
435	foreach my $x(@mols) { $havenocomps{$x->{'ID'}}=1; }
436	my @allcompparents;
437	foreach my $node(hasType(\@nodes,'Comp'))
438		{ push @allcompparents, @{$node->{'Parents'}}; }
439	foreach my $x(@allcompparents) { $havenocomps{$x}=0; }
440	foreach my $x(keys %havenocomps)
441	{
442		if ($havenocomps{$x})
443		{
444			my $node = findNode(\@mols,$x);
445			push @context,makeAtomicPattern(\@nodes_struct,$node);
446		}
447	}
448
449	return @context;
450}
451
452sub getSyndelContext
453{
454	my @nodelist = @{shift @_};
455	my $op = shift @_;
456
457	my $mol = findNode(\@nodelist,${$op->{'Parents'}}[0]);
458
459	# get child components
460	my @allcomps = hasType(\@nodelist,'Comp');
461	my @comps = grep (${$_->{'Parents'}}[0] eq $mol->{'ID'}, @allcomps);
462	my @comps_ids = map $_->{'ID'}, @comps;
463
464	# get child component states
465	my @allcompstates = hasType(\@nodelist,'CompState');
466	my @compstates = ();
467	foreach my $x(@allcompstates)
468	{
469		foreach my $y (@comps_ids)
470			{
471				if (${$x->{'Parents'}}[0] eq $y) { push @compstates,$x; }
472			}
473	}
474
475	# get child bond states
476	my %unbound;
477	foreach my $y (@comps_ids) { $unbound{$y} = 1; }
478
479	my @allbondstates = hasType(\@nodelist,'BondState');
480	my @bondstates = ();
481	foreach my $x(@allbondstates)
482	{
483		my @parents = @{$x->{'Parents'}};
484		foreach my $y (@comps_ids)
485		{
486			foreach my $z(@parents)
487			{
488			if ($y eq $z)
489				{
490				push @bondstates,$x;
491				$unbound{$z} = 0;
492				}
493			}
494		}
495	}
496
497	my @unboundcomps = ();
498	foreach my $x(keys %unbound)
499	{
500	if ($unbound{$x})
501		{
502		my $node = findNode(\@nodelist,$x);
503		push @unboundcomps, $node;
504		}
505	}
506
507	my @syndelnodes = (@compstates,@bondstates,@unboundcomps);
508	my @syndel = ();
509	foreach my $node(@syndelnodes) { push @syndel, makeAtomicPattern(\@nodelist,$node); }
510
511	return @syndel;
512}
513
514sub getTransformations
515{
516	my $rsg = shift @_;
517	my @nodelist = @{$rsg->{'NodeList'}};
518	my @graphop = hasType(\@nodelist,'GraphOp');
519	my @tr = map {makeTransformation(\@nodelist,$_);} @graphop;
520	return @tr;
521}
522sub reverseTransformation
523{
524	my $tr = shift @_; #unprettified
525	my @splits = reverse split('->',prettify($tr));
526	#my @splits2 = map ( join(',',sort split(',',$_ =~ s/\s//g)), @splits);
527	sub clean { $_ =~ s/\s//g; return $_; }
528	my @splits2 = map ( join(',',sort split(',',clean($_))), @splits);
529	my $tr2 = unprettify(join '->',@splits2 );
530	return $tr2;
531}
532
533sub stringToAtomicPattern
534{
535		my $pat = shift @_;
536		my $patstr = $pat;
537		my $sg = SpeciesGraph->new();
538		my $err = SpeciesGraph::readString($sg,\$patstr);
539		my $psg = makePatternStructureGraph($sg);
540		my @nodes = @{$psg->{'NodeList'}};
541		my @ap = uniq(makeAtomicPatterns(\@nodes,\@nodes));
542		my @pats;
543		if($pat =~ /\!/ and $pat !~ /\!\+/)
544			{
545			@pats = grep { $_ =~ /\!/ } @ap;
546			}
547		elsif($pat =~ /\!\+/)
548			{
549			@pats = grep { $_ =~ /\!\+/ } @ap;
550			}
551		elsif($pat =~ /~/)
552			{
553			@pats = grep { $_ =~ /~/ } @ap;
554			}
555		elsif($pat =~ /\(.{1,}\)/)
556			{
557			@pats = grep { $_ =~ /\(.{1,}\)/ } @ap;
558			}
559		elsif($pat =~ /\(\)/)
560			{
561			@pats = @ap;
562			}
563		if (scalar @pats != 1)
564			{
565			return $pat;
566			}
567	return $pats[0];
568}
569
570# make graph methods
571sub makeRuleNetworkGraph
572{
573	# from a rule structure graph
574	my $rsg = shift @_;
575	my $name = shift @_;
576
577	my @nodelist = @{$rsg->{'NodeList'}};
578
579	my $bpg = NetworkGraph->new();
580	$bpg->{'Name'} = $name;
581
582	my @graphop = hasType(\@nodelist,'GraphOp');
583	my @contexts = getContext(\@nodelist);
584
585	# add node for rule
586	push @{$bpg->{'NodeList'}}, $name;
587	$bpg->{'NodeType'}->{$name} = 'Rule';
588
589	# add reactant and product edges
590	foreach my $op(@graphop)
591	{
592		my $tr = makeTransformation(\@nodelist,$op);
593		if($op->{'Name'} eq 'DeleteBond')
594		{
595			$tr = makeTransformationDeleteBond(\@nodelist,$op);
596			# bond deletion is treated here
597			# if there's a deletemol, AB -> A, then it shows only A as the product
598			# wildcard delete! if A!+ -> A, then this shows A as the product
599		}
600
601		if(length $tr == 0) { next; }
602		my ($reac,$prod) = getReactantsProducts($tr);
603		push @{$bpg->{'NodeList'}}, @$reac, @$prod;
604		foreach my $reactant (@$reac)
605		{
606			if (length $reactant == 0) {next;}
607			my $edge = makeEdge($name,$reactant,'r');
608			push @{$bpg->{'NodeList'}}, $reactant;
609			push @{$bpg->{'EdgeList'}}, $edge;
610			$bpg->{'NodeType'}->{$reactant} = 'AtomicPattern';
611
612		}
613		foreach my $product (@$prod)
614		{
615			if (length $product == 0) {next;}
616			my $edge = makeEdge($name,$product,'p');
617			push @{$bpg->{'NodeList'}}, $product;
618			push @{$bpg->{'EdgeList'}}, $edge;
619			$bpg->{'NodeType'}->{$product} = 'AtomicPattern';
620		}
621	}
622	# add context edges
623	foreach my $context(@contexts)
624	{
625		if (length $context == 0) {next;}
626		my $edge = makeEdge($name,$context,'c');
627		push @{$bpg->{'NodeList'}}, $context;
628		push @{$bpg->{'EdgeList'}}, $edge;
629		$bpg->{'NodeType'}->{$context} = 'AtomicPattern';
630	}
631	# add syndel edges
632	foreach my $op(@graphop)
633	{
634		if ($op->{'Name'} =~ /Mol/)
635		{
636			my $rel = ($op->{'Name'} =~ /Add/) ? 'p' : 'r';
637			my @syndels = getSyndelContext(\@nodelist,$op);
638			foreach my $syndel(@syndels)
639			{
640				if (length $syndel == 0) {next;}
641				my $edge = makeEdge($name,$syndel,$rel);
642				push @{$bpg->{'NodeList'}}, $syndel;
643				push @{$bpg->{'EdgeList'}}, $edge;
644				$bpg->{'NodeType'}->{$syndel} = 'AtomicPattern';
645			}
646		}
647	}
648
649	uniqNetworkGraph($bpg);
650	addWildcards($bpg);
651	uniqNetworkGraph($bpg);
652	return $bpg;
653
654}
655
656
657sub makeRuleNetworkGraph_simple
658{
659	my @nodes = @{shift @_};
660	my @edges = @{shift @_};
661	my %nodetype = %{shift @_};
662	my $name = shift @_;
663
664	my $bpg = NetworkGraph->new();
665	$bpg->{'NodeType'} = \%nodetype;
666	$bpg->{'NodeList'} = \@nodes;
667	$bpg->{'EdgeList'} = \@edges;
668	$bpg->{'Name'} = $name;
669	return $bpg;
670
671}
672
673sub makeRuleNetworkGraphFromEdges
674{
675	my @edges = @{shift @_};
676	my %nodetype = %{shift @_};
677	my $name = shift @_;
678
679	my @nodes = uniq(map {$_=~ /^(.*):(.*):.*/; ($1,$2);} @edges);
680	my %types;
681	updateDict(\%types,\%nodetype,\@nodes);
682	my $bpg = NetworkGraph->new();
683	$bpg->{'NodeType'} = \%nodetype;
684	$bpg->{'NodeList'} = \@nodes;
685	$bpg->{'EdgeList'} = \@edges;
686	$bpg->{'Name'} = $name;
687	return $bpg;
688
689}
690
691
692# do things to network graphs
693sub uniqNetworkGraph
694{
695	my $bpg = shift(@_);
696	$bpg->{'NodeList'} = [uniq(@{$bpg->{'NodeList'}})];
697	$bpg->{'EdgeList'} = [uniq(@{$bpg->{'EdgeList'}})];
698	return;
699}
700sub mergeNetworkGraphs
701{
702	my @x = @_;
703	my $bpg = combine3(\@x);
704	uniqNetworkGraph($bpg);
705	addWildcards($bpg);
706	uniqNetworkGraph($bpg);
707	$bpg->{'Merged'} =1;
708	return $bpg;
709}
710
711sub filterNetworkGraph
712{
713	# when $reverse is not mentioned, it simply removes the nodes that are
714	# included in @$filter from the bpg
715	# when $reverse eq 'reverse', it removes everything BUT those nodes
716	my $bpg = shift @_;
717	my $filter = shift @_;
718	my $reverse = @_ ? shift @_ : '';
719	my $includegroups = @_ ? shift @_ : 0;
720
721	my @nodelist = @{$bpg->{'NodeList'}};
722	my @edgelist = @{$bpg->{'EdgeList'}};
723	my %nodetype = %{$bpg->{'NodeType'}};
724
725
726	if( $reverse eq 'reverse' )
727	{
728		# this is if a reverse
729		my @filter2 = grep { has($filter,$_)==0; } @nodelist;
730		$filter = \@filter2;
731	}
732
733	my @new_nodelist = grep { has($filter,$_)==0; } @nodelist;
734	my %new_nodetype = map { $_=>$nodetype{$_} } @new_nodelist;
735
736
737	my @removed_edges;
738	my @remove1 = 	grep {
739					my $x = $_;
740					$x =~ /.*:(.*):.*/;
741					has($filter,$1)==1;
742					} @edgelist;
743	my @remove2 = 	grep {
744					my $x = $_;
745					$x =~ /(.*):.*:.*/;
746					has($filter,$1)==1;
747					} @edgelist;
748	my @new_edgelist = grep { has([(@remove1,@remove2)],$_)==0;} @edgelist;
749
750	my $bpg2 = NetworkGraph->new();
751	$bpg2->{'NodeList'} = \@new_nodelist;
752	$bpg2->{'EdgeList'} = \@new_edgelist;
753	$bpg2->{'NodeType'} = \%new_nodetype;
754	$bpg2->{'Merged'} = $bpg->{'Merged'};
755	$bpg2->{'Filtered'} = 1;
756	$bpg2->{'Collapsed'} = $bpg->{'Collapsed'};
757
758	if($includegroups and defined $bpg->{'NodeClass'})
759	{
760	my %nodeclass = %{$bpg->{'NodeClass'}};
761	my %new_nodeclass = map { $_=>$nodeclass{$_} } @new_nodelist;
762	$bpg2->{'NodeClass'} = \%new_nodeclass;
763	}
764
765	return $bpg2;
766}
767
768sub filterNetworkGraphByList
769{
770	my $bpg = shift @_;
771	my @items = @{shift @_};
772	my $level = @_ ? shift @_ : 1;
773
774	my @nodes = @{$bpg->{'NodeList'}};
775	my @edges = @{$bpg->{'EdgeList'}};
776
777	for (my $i=1; $i<=$level; $i++)
778	{
779		my @items2=();
780		foreach my $edge(@edges)
781		{
782			$edge =~ /(.*):(.*):.*/;
783			my $x = $1; my $y = $2;
784			next if(has(\@items,$x)==has(\@items,$y));
785			if(has(\@items,$x)==0) { push @items2,$x; }
786			if(has(\@items,$y)==0) { push @items2,$y; }
787			#print scalar @items2;print "\n";
788		}
789		push @items,uniq(@items2);
790	}
791	#print @items;
792	@items = uniq(@items);
793	my @remove = grep { has(\@items,$_)==0; } @{$bpg->{'NodeList'}};
794	my $bpg2 = filterNetworkGraph($bpg,\@remove);
795	uniqNetworkGraph($bpg2);
796	if(defined $bpg->{'NodeClass'})
797	{
798		my %classes;
799		updateDict(\%classes,$bpg->{'NodeClass'},$bpg2->{'NodeList'});
800		$bpg2->{'NodeClass'} = \%classes;
801	}
802	return $bpg2;
803}
804
805sub collapseNetworkGraph
806{
807
808	my $bpg = shift @_;
809	my %classes = %{$bpg->{'NodeClass'}};
810
811
812	my @classed = keys %classes;
813	my @edges = @{$bpg->{'EdgeList'}};
814
815	my @classed_rules = grep {$bpg->{'NodeType'}->{$_} eq 'Rule'} keys %classes;
816	my @classed_patterns = grep {$bpg->{'NodeType'}->{$_} eq 'AtomicPattern'} keys %classes;
817	my @rule_classes = uniq(map $classes{$_}, @classed_rules);
818	my @pattern_classes = uniq(map $classes{$_}, @classed_patterns);
819
820	my @nodelist2;
821	my @edgelist2;
822	my %nodetype2;
823	foreach my $edge(@edges)
824	{
825		# deconstruct edge
826		$edge =~ /^(.*):(.*):(.*)$/;
827		my $x = $1;
828		my $y = $2;
829		my $z = $3;
830
831		if(has([qw(Reactant Product Context)],$z) )
832		{
833			if(has(\@classed_rules,$x)) { $x = $classes{$x}; }
834			if(has(\@classed_patterns,$y)) { $y = $classes{$y}; }
835		}
836		if($z eq 'Wildcard')
837		{
838			if(has(\@classed_patterns,$x)) { $x = $classes{$x}; };
839			if(has(\@classed_patterns,$y)) { $y = $classes{$y}; };
840			next if($x eq $y);
841		}
842
843		#pushy stuff
844		push @nodelist2, $x;
845		push @nodelist2, $y;
846		push @edgelist2, join(":",($x,$y,$z));
847
848		if(has(\@rule_classes,$x)) { $nodetype2{$x} = 'RuleGroup'; }
849		elsif(has(\@pattern_classes,$x)) { $nodetype2{$x} = 'PatternGroup'; }
850		else {$nodetype2{$x} = $bpg->{'NodeType'}->{$x}; }
851
852		if(has(\@pattern_classes,$y)) { $nodetype2{$y} = 'PatternGroup'; }
853		else {$nodetype2{$y} = $bpg->{'NodeType'}->{$y}; }
854	}
855
856	@nodelist2=  uniq(@nodelist2);
857	@edgelist2 = uniq(@edgelist2);
858
859
860	my $bpg2 = NetworkGraph->new();
861	$bpg2->{'NodeList'} = \@nodelist2;
862	$bpg2->{'EdgeList'} = \@edgelist2;
863	$bpg2->{'NodeType'} = \%nodetype2;
864	$bpg2->{'Merged'} = $bpg->{'Merged'};
865	$bpg2->{'Collapsed'} = 1;
866
867	return $bpg2;
868}
869
870sub updateDict
871{
872	my $update_this = shift @_;
873	my $update_using  = shift @_;
874	my $update_list = shift @_;
875
876	#my @keys1 = keys %{$update_this};
877	my @keys2 = keys %{$update_using};
878	my @common_keys = grep { has(\@keys2,$_)  } @{$update_list};
879
880	map { $update_this->{$_} = $update_using->{$_} } @common_keys;
881	return;
882}
883
884sub duplicateNetworkGraph
885{
886	my $bpg = shift @_;
887	my $bpg2 = NetworkGraph->new();
888
889	$bpg2->{'NodeList'} = \@{$bpg->{'NodeList'}};
890	$bpg2->{'EdgeList'} = \@{$bpg->{'EdgeList'}};
891	$bpg2->{'NodeType'} = \%{$bpg->{'NodeType'}};
892	if(defined $bpg->{'NodeClass'})
893	 { $bpg2->{'NodeClass'} = \%{$bpg->{'NodeClass'}}; }
894	$bpg2->{'Merged'} = $bpg->{'Merged'};
895	$bpg2->{'Collapsed'} = $bpg->{'Collapsed'};
896	$bpg2->{'Filtered'} = $bpg->{'Filtered'};
897	return $bpg2;
898
899}
9001;
901
902