-
Notifications
You must be signed in to change notification settings - Fork 0
/
Copy pathDVDCore.pm
executable file
·1790 lines (1581 loc) · 59.7 KB
/
DVDCore.pm
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
#!/usr/bin/perl
## Franziska Hinkelmann
# This module must be symlinked to /etc/perl/DVDCore.pm
package DVDCore;
use Cwd;
BEGIN {
use Exporter ();
our ( $VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS );
@ISA = qw(Exporter);
@EXPORT = qw(&dvd_session $Use_log);
%EXPORT_TAGS = ();
$VERSION = "0.12.1";
@EXPORT_OK
= qw(&translator &count_comps_final &sim, ®ulatory $N_nodes $P_value $Clientip $Function_data $Function_file $Pwd @Output_array &error_check &_log $Polynome $Stochastic);
# functions that the user may want to include in their namespace, but only if they don't want to use the
# dvd_session method (i.e. they want to manually input/keep track of their variables)
}
our @EXPORT_OK;
# exportable variables
our $N_nodes;
our $P_value;
our $Adj;
our $Clientip;
our @Function_data;
our $Function_file;
our $All_trajectories_flag;
our $Update_stochastic;
our $Update_sequential;
our $Update_schedule;
our $All_trajectories;
our $Initial_state;
# package/module exclusive globals
our @Output_array;
our $Last_status;
our $Current_program;
our $Session_on;
# this is an object that is accessed in nearly every script
our @Functions;
# $Pwd is set by user to define the current working directory
our $Pwd;
our $Polynome;
our $Stochastic;
our $Use_log;
#our $Use_log=1;
our $dot_filename;
# This is a double arraw #prob[i][i] with the probability for the jth function in the ith
# set.
our $prob;
# more localized variables
# none
# private variables
# none
# private functions
# none
# functions
sub dvd_session { }
sub translator { }
sub count_comps_final { }
sub count_comps_final_single_trajectories { }
sub count_comps_final_all_trajectories { }
sub sim { }
sub regulatory { }
sub recu { }
sub create_output { } # this collects information from the .dot file
END { }
## main code entry
# dvd_session serves as a wrapper for the DVD interface (think new_dvd11.pl), providing a
# single method for specifying all of the needed runtime variables
sub dvd_session {
#set path for graphviz for the server to use, this is necessary, because
# PATH variable on polymath does not include /usr
$ENV{'PATH'} = '/usr/local/bin:/bin:/etc:/usr/bin';
$ENV{'LD_LIBRARY_PATH'} = '/usr/local/lib/graphviz';
# eventually serialize a hash
# count the arguments
$count = scalar(@_);
my ($n_nodes, $p_value, $clientip,
$translate, $update_sequential, $update_schedule,
$all_trajectories_flag, $statespace, $ss_format,
$regulatory, $dg_format, $all_trajectories,
$initial_state, $update_stochastic, $debug
) = @_[ 0 .. 14 ];
$Use_log = $debug;
$Current_program = "dvd_session";
#print "\$regulatory $regulatory,";
print "\n<br>" if ($DEBUG);
_log("all trajectories: $All_trajectories");
_log( "Argument length: " . $count );
_log( "Arguments: " . join( ", ", @_[ 0 .. 13 ] ) );
@Output_array = [];
$Function_file = $_[-1];
$Clientip = $clientip;
_log( "Clientip is " . $Clientip );
$N_nodes = $n_nodes;
$P_value = $p_value;
$All_trajectories_flag = $all_trajectories_flag
; #plot phase space, not just trajectory for one state
$Update_stochastic = $update_stochastic
; # 1 if update stochastic (faked with random delays)
$Update_sequential
= $update_sequential; # 1 if we want update sequential system
$Update_schedule = $update_schedule; # update order with _ between
$All_trajectories = $all_trajectories
; #on for all trajectories, off for traj of one initial state
$Initial_state = $initial_state;
_log("\$Update_stochastic: $Update_stochastic");
$Session_on = 1;
# begin evaluation of input
if ( ( !$p_value ) & ( !$n_nodes ) ) {
return _package_error(
"Empty values for nodes and/or states. $n_nodes, $p_value");
# _error_and_exit("Empty values for nodes and/or states.", "dvd_session");
# return $Output_array;
}
# we need to define a vector for the function file data. It's probably best to get the data and keep it in memory, despite the load, and pass it through the functions. In order to keep from creating extra copies all the time, each function will reference the global memory allocation.
if ( !@Function_data && ( !defined($Function_file) ) && ($Clientip) ) {
$function_file_location
= _get_filelocation("$Clientip.functionfile.txt");
if ( $Clientip && -e $function_file_location ) {
# file handle should be <OPEN>
# my($file_location) = _get_filelocation("$Clientip.functionfile.txt");
open( $Function_file, $function_file_location );
}
else {
return _package_error(
"Please ensure that your clientip, $Clientip, corresponds to a file located in $function_file_location."
);
}
}
if ( $Function_file && scalar(@Function_data) == 0 ) {
_load_function_data($Function_file);
_log("Loaded functionfile.");
}
@response = error_check();
return _package_error( $response[1] ) unless ( $response[0] );
if ( $translate == 1 ) {
my ( $success, $message ) = dvd_translator();
return ( _package_error($message) ) unless ($success);
$Current_program = "dvd_session";
}
# we need to clean the file formats
if ($ss_format) {
$ss_format =~ s/\*\.//;
}
if ($dg_format) {
$dg_format =~ s/\*\.//;
}
$Current_program = "dvd_session";
if ( $regulatory == 1 ) {
#print "In regulatory \$dg_format $dg_format<br>";
my ( $success, $message )
= regulatory($dg_format); #create dependency graph
return _package_error($message) unless ($success);
}
if ( $update_stochastic == 1 ) {
_set_update_stochastic();
}
if ( $update_sequential == 1 ) {
unless ( update_schedule != "" ) {
$update_schedule = _sanitize_input($update_schedule);
_log("Update Schedule: $update_schedule");
my ( $success, $message )
= _check_and_set_update_schedule($update_schedule);
if ( $success == 0 ) {
return _package_error($message);
}
else {
$update_schedule = $success;
}
}
else {
return _package_error("Empty update schedule.");
}
}
if ( $All_trajectories == 1 ) {
$mode = 0
; # mode refers to the computation mode-- statespace, or initialization
my ( $success, $message )
= count_comps_final( $statespace, $ss_format );
return _package_error($message) unless ($success);
}
else {
$mode = 1;
unless ( $initial_state eq "" ) {
$initial_state = _sanitize_input($initial_state);
_log("initial $initial_state");
}
else {
_log("Initial state: $initial_state.");
return _package_error("Empty initial state.");
}
my ( $success, $message )
= sim( $initial_state, $update_sequential, $update_schedule,
$statespace, $ss_format );
return _package_error($message) unless ($success);
}
$Output_array[1] = $mode;
# cleanup globals
@Function_data = ();
$Function_file = "";
return 1; # user should then read $Output_array...
}
#identity has to be added to simulate a delay and the probabilites
#have to be set
sub _set_update_stochastic() {
$Current_program = "_set_update_stochastic";
for ( my $count = 1; $count <= $n_nodes; $count++ ) {
_log("Function @{ $Functions[$count-1] }");
my $identity = "\$x[" . $count . "]";
_log("\$identity $identity");
push( @{ $Functions[ $count - 1 ] }, $identity );
_log( "Increased number of elements in xFunctions[$count] to "
. scalar( @{ $Functions[ $count - 1 ] } ) );
_log("Adjusting \$prob[$count-1][_]");
# probability for using update function on node $count, should be
# 1/n_nodes
$prob[ $count - 1 ][0] = 1 / $n_nodes;
# all the other times delays should be used
$prob[ $count - 1 ][1] = 1 - $prob[ $count - 1 ][0];
}
}
# checks update schedule and sets @Functions to new functions
# So far this only works for a deterministic network - does it even make sense
# for a function stochastic network?
#
# common to both sim.pl and count_comps_final
# this function should be called after error_check (@Functions must be set)
#
# @Functions is changed, such that later a regular synchronuous
# update can be made, for example f1=x1+x2, f2=x1, 1_2 turns into
#($x[1])+($x[2])
#(($x[1])+($x[2]))
sub _check_and_set_update_schedule {
my ( $update_schedule, $n_nodes );
if ( $Session_on == 1 ) {
$update_schedule = $_[0];
$n_nodes = $N_nodes;
}
else {
( $update_schedule, $n_nodes ) = @_;
}
_log("Update Schedule: $update_schedule");
$update_schedule =~ s/_/ /g; #remove the underscores
my @prefArr = split( /\s+/, $update_schedule );
if ( ( scalar(@prefArr) != $n_nodes )
|| ( $update_schedule =~ m/[^(\d)(\s*)]/g ) )
{
return _package_error(
"Make sure the indices are non negative numbers separated by spaces and equal to the number of nodes."
);
}
for ( my $h = 0; $h < $n_nodes; $h++ ) {
if ( $prefArr[$h] > $n_nodes ) {
return _package_error(
"Make sure the range of each index of the update schedule is between 1 and number of nodes."
);
}
}
## Todo: check that numbers in update schedule are unique, or at least put
## it in tutorial
for ( my $i = 1; $i <= $n_nodes; $i++ ) {
push( @variables, "\$y[$i]" );
}
for ( my $curr = 0; $curr < $n_nodes; $curr++ ) {
my $varToUpdate = $prefArr[$curr]; #get the order number
for ( my $i = 1; $i <= $n_nodes; $i++ ) {
$Functions[ $varToUpdate - 1 ][0]
=~ s/\$x\[$i\]/\($variables[$i-1]\)/g;
}
$variables[ $varToUpdate - 1 ]
= $Functions[ $varToUpdate - 1 ][0]; # get the function
$Functions[ $varToUpdate - 1 ][0] =~ s/y/x/g; #replace ys back to x's
}
return 1;
}
sub _sanitize_input {
$value = $_[0];
$value =~ s/^\s+|\s+$//g; #remove all leading and trailing white spaces
$value =~ s/(\d+)\s+/$1 /g; # remove extra spaces in between the numbers
$value =~ s/ /_/g;
_log("_sanitize_input: $value");
return $value;
}
# deprecated, use return _package_error($error_message)
sub _error_and_exit {
my ( $error_message, $function ) = @_;
foreach (@Output_array) {
print $_ . "\n";
}
exit;
}
# should this be private? we're expecting @Function_data
# if exported, recognize that there are three modes-- $Session_on, $Session_on
# = 0, and the mode that should be defined when it is called from outside a
# particular function
# in the $Session_on == 0 inline function call, we want it to load the
# $Output_array, but return just 0 (we have a hanging or
sub error_check {
$Current_program = "error_check";
if ( $Session_on == 1 ) {
_log("<br>Session_on = 1");
$mode = 1;
( $n_nodes, $function_data ) = ( $N_nodes, \@Function_data );
}
else {
_log("<br>Session_on = 0");
my ( $n_nodes, $function_data ) = ( $_[0], \$_[ 1 .. -1 ] );
if ( $Current_program != "" ) {
$mode = 0;
}
else {
$mode = -1;
}
}
_log( "num_nodes: " . $n_nodes . ", global: " . $N_nodes );
@Functions = ()
; # make sure that this is +only+ run from dvd_session or to validate the function data
$found = 0;
$n = 1;
$fcount = 1;
_log( "Length of \@\$function_data in error_check: " . scalar(@$function_data) );
if ($Polynome) {
open( $poly_fix_file, ">poly_fix.txt" );
}
foreach (@$function_data) {
$fn = 0;
$max = 1;
_log("<BR><BR>$_<BR>");
$tmp1 = scalar($_);
_log("tmp1 $tmp1<BR>");
$tmp2 = scalar( @{$_} );
_log("tmp2 $tmp2<BR>");
if ( scalar($_) =~ /ARRAY/ ) {
$max = scalar( @{$_} );
_log( "Attempting to read from an array... (matching) 'ARRAY:' "
. scalar($_)
. "With length: $max" );
}
until ( $fn == $max ) {
if ( $max > 1 ) { #function stochastic
_log("<BR>Function stochastic<BR>");
_log("$fn<BR>");
$line = @{$_}[$fn];
#$line = ${ @{$_} }[$fn];
$n = ${ @{ $Function_lines[ $fcount - 1 ] } }[$fn];
_log("<br>Reading fn $fn, function: $line");
_log("@{$_}[0]");
_log("{@{$_}}[0]");
_log("<br>This is called when having multiple functions");
}
else { #not function stochastic
$line = $_;
$n = $Function_lines[ $fcount - 1 ] || $n;
_log("Reading function: $line");
_log("<br>This is called when having one function");
}
#remove newline character
chomp($line);
#remove all spaces
# split into function and probability
( my $temp, my $f_prob ) = split( /#/, $line );
#remove blanks
$f_prob =~ s/\s*//g;
chomp($f_prob);
#_log("\$f_prob: $f_prob after prob");
# Check whether probability matches 1.0 or 0.23432
if ( $f_prob =~ m/^((1(\.0+)?)|(0?\.\d+))$/ ) {
#_log("\$prob[$fcount-1][$fn]= $f_prob");
$prob[ $fcount - 1 ][$fn] = $f_prob;
}
else { #if no probability was given, assume equal distribution
$prob[ $fcount - 1 ][$fn] = 1 / $max;
}
# assign function to line
$line = $temp;
$line =~ s/\s*//g;
#remove repetitions of equals
$line =~ s/=+/=/g;
$count = 0;
_log(
"Starting check of function $fcount, which has $max
function(s)... f$fcount, $line<br>"
);
#line starts with fi=
_log("passes f check") if ( $line =~ m/^f$fcount=/i );
if ( ( ( $line ne "" ) && ( $line ne null ) )
&& ( $line =~ m/f$fcount=/i || $Polynome || $max => 1 ) )
{ ## && (@Functions < $n_nodes))
$func = ( split( /=/, $line ) )[-1]; # just read the function
_log( "Length of function:" . length($func) );
_log("<br>Function $func");
if ($Polynome) {
_log("Hola!");
@a_z{ 'a' .. 'z' } = ( 1 .. 26 );
# _log("Before translation, the function looks like this: $func") if (length($func) == 1);
_log( "Length of function:" . length($func) );
if ( $func =~ /[a-z][^\d]/ ) {
_log("Had to rewrite function.");
$func
=~ s/([a-z][^\d]|[a-z]$)/"x"."$a_z{substr($&, 0, 1)}".substr($&, 1)/ge;
}
### print $poly_fix_file $func, "\n";
# _log("After translation, the function looks like this: $func");
}
if ( length($func) == 0 ) {
_log("faili empy function");
$errString = "ERROR: Empty function no $fcount.";
$found = 1;
last;
}
if ( $func =~ m/[^(x)(\d)(\()(\))(\+)(\-)(\*)(\^)]/g ) {
_log("fail 1");
$func =~ s/[^(x)(\d)(\()(\))(\+)(\-)(\*)(\^)]/+/g;
_log( length($func) );
_log($func);
$errString
= "ERROR: Found unacceptable character(s) in line $n.";
$found = 1;
last;
}
# check to see if there are equal number of opening and closing paranthesis
if ( tr/\(/\(/ != tr/\)/\)/ ) {
_log("fail 2");
$errString = "ERROR: Missing paranthesis in line $n.";
$found = 1;
last;
}
#check to see if the index of x is acceptable
$err = 0;
while ( $func =~ m/x(\d+)/g ) {
if ( ( $1 > $n_nodes ) || ( $1 < 1 ) ) {
_log("fail 3");
$errString
= "ERROR: Index of x out of range in line $n.";
$err = 1;
last;
}
}
#check to see if there was any error in the above while loop
if ( $err == 1 ) {
_log("fail: $errString");
$found = 1;
last;
}
#Check to see if function is starting properly
if ( $func =~ m/^[\)\*\^]/ ) {
_log("fail 4");
$errString
= "ERROR: Incorrect syntax in line $n. Inappropriate char at start of function.";
$found = 1;
last;
}
#Check to see if function is ending properly
if ( $func =~ m/[^\)\d]$/ ) {
_log("fail 5");
$errString
= "ERROR: Incorrect syntax in line $n. Inappropriate char at end of function.";
$found = 1;
last;
}
#check to see if x always has an index
if ( $func =~ m/x\D/g ) {
_log("fail");
$errString
= "ERROR: Incorrect syntax in line $n. Check x variable.";
$found = 1;
last;
}
#check to see if ^ always has a number following
if ( $func =~ m/\^\D/g ) {
_log("fail");
$errString
= "ERROR: Incorrect syntax in line $n. Check exponent value.";
$found = 1;
last;
}
if ( ( $func =~ m/[\+\-\*\(][\)\+\-\*\^]/g )
|| ( $func =~ m/\)[\(\d x]/g )
|| ( $func =~ m/\d[\( x]/g ) )
{
_log("fail");
$errString
= "ERROR: Incorrect syntax in line $n. Read the tutorial for correct formatting rules.";
$found = 1;
last;
}
if ( $found == 0 ) {
_log("Line is good.");
$func =~ s/\^/\*\*/g; # replace carret with double stars
$func =~ s/x(\d+)/\$x\[$1\]/g; #for evaluation
_log("\$func: $func");
## Franziska made a change here, if a stochastic=1, and f_i has only
## one update function, then the indexing later of @functions is
##off, So I think this works, but I don't guarantee
# if ($max > 1)
if ( $max > 0 ) {
unless ( $Functions[$fcount] ) {
$Functions[$fcount] = [$func];
}
else {
push( @{ $Functions[$fcount] }, $func );
}
_log(
"Increased number of elements in xFunctions[x$fcount] to "
. scalar( @{ $Functions[$fcount] } ) );
}
else { ##Franziska: with the change we don't end up here
_log(
"NOT Increased number of elements in xFunctions[xn] to "
. scalar( @{ $Functions[$fcount] } ) );
push( @Functions, $func );
}
}
}
else {
if ( ( $line ne "" ) && ( $line ne null ) ) {
_log("fail 0");
$errString
= "ERROR: Incorrect start of function declaration in line $n.";
$found = 1;
last;
}
}
$fn++;
}
last if ( $found == 1 ); # Errors found
if ($Update_stochastic) {
if ( scalar( @{ $Functions[$fcount] } > 1 ) ) {
_log(
"ERROR, Update stochastic but more than one function for f_$fcount."
);
$errString
= "ERROR: Update stochastic but more than one function for f_$fcount.";
$found = 1;
last;
}
}
last if ( $found == 1 ); # Errors found
if ($Update_sequential) {
if ( scalar( @{ $Functions[$fcount] } > 1 ) ) {
_log(
"ERROR, Update sequential but more than one function for f_$fcount."
);
$errString
= "ERROR: Update sequential but more than one function for f_$fcount.";
$found = 1;
last;
}
}
last if ( $found == 1 ); # Errors found
if ( !$All_trajectories ) {
_log("blaall_trajectories $All_trajectories");
if ( scalar( @{ $Functions[$fcount] } > 1 ) ) {
_log(
"ERROR, Trajectory from a single initial state but more than one function for f_$fcount."
);
$errString
= "ERROR, Trajectory from a single initial state but more than one function for f_$fcount.";
$found = 1;
last;
}
}
last if ( $found == 1 ); # Errors found
$fcount++;
$n++
; # only works if the line number matches up (perhaps use a conversion table to get line #?)
}
if ( $found == 0 && ( $fcount - 1 ) < $N_nodes ) {
_log("fail 1");
$errString
= "ERROR: Insufficient number of functions in the input provided. Check your number of nodes field.";
$found = 1;
}
# if ($Stochastic) {
# shift(@Functions);
# }
### I changed the indexing above, therefore there should always be a shift
shift(@Functions);
_log( "Length of \@Functions: " . scalar(@Functions) );
foreach (@Functions) {
if ( scalar($_) =~ /ARRAY/ ) {
_log("{");
foreach ( @{$_} ) { _log($_) }
_log("}");
}
else {
_log($_);
}
}
if ( $found == 1 ) {
_log("Errors found with function file.");
if ( $mode == 1 || $mode == 0 ) {
return _package_error($errString);
}
return 0;
}
elsif ( $found == 0 ) {
_log("No errors found with function file.");
return 1;
}
}
# this function has been deprecated in favor of &dvd_session
sub new_dvd11 { }
# derived from translator.pl, renamed so as not to cause a name collision. Error checking has already been performed on the input file, significantly shortening the file.
# The functions referenced in evalutateInfix, and the function itself, are defined below the function regulatory
sub dvd_translator {
$Current_program = "dvd_translator";
if ( $Session_on == 1 ) {
_log("Session_on = 1");
my ( $n_nodes, $clientip ) = ( $N_nodes, $Clientip );
$function_data = \@Function_data;
}
else {
_log("<br>Session_on = 0");
my ($n_nodes) = $_[0];
$function_data = \@_[ 1 .. -1 ];
}
$found = 0;
@new_function_data = ();
foreach (@$function_data) {
$line = $_;
#remove newline character
chomp($line);
$func = ( split( /=/, $line ) )[1];
if ( $found == 0 ) {
@express = ();
@testarr = split( /([\(\)\*\+\~ ])/, $func );
for ( $i = 0; $i < scalar(@testarr); $i++ ) {
if ( $testarr[$i] ne "" && $testarr[$i] ne " " ) {
push( @express, $testarr[$i] );
}
}
push( @new_function_data,
"f$fcount = " . evaluateInfix(@express) . "\n" );
$fcount++;
}
}
if ($Session_on) {
@Function_data = @new_function_data;
return 1;
}
else {
return ( 1, @new_function_data );
}
}
# derived from count_comps_final.pl.
# This wrapper picks either the method that does creates the phase space that
# has all possible connections in it or a graph that shows one possible update
# for each function
sub count_comps_final {
_log("In Count rapper: $All_trajectories_flag");
if ($All_trajectories_flag) {
count_comps_final_all_trajectories(@_);
create_output();
}
else { #deprecated
count_comps_final_single_trajectories(@_);
}
}
# This function carries out the evaluation of networks that calculate the entire state space.
# rewritten by Franziska to include all possible connections instead of a
# random instance of the phase space in one graph
sub count_comps_final_all_trajectories {
$Current_program = "count_comps_final_all_trajectories";
#print "<br> $Current_program <br>";
$combi = 1; # all combinations of functions
$i = 0;
$k = 1;
foreach (@Functions) {
$l = scalar( @{$_} );
_log("SCALAR in loop $l");
for ( $j = 0; $j < $l; $j++ ) {
## The probablities has to be read in!
#$prob[$i][$j] = 1/$k;
$k += 1;
_log("prob SCALAR prob[$i][$j] = $prob[$i][$j]");
}
$i += 1;
$combi *= $l;
}
# $l = scalar( @{ $Functions[$my_N]} );
# _log("SCALAR combinations $combi");
if ( $Session_on == 1 ) {
( $clientip, $n_nodes, $p_value ) = ( $Clientip, $N_nodes, $P_value );
_log("session variables = $clientip $n_nodes, $p_value");
( $statespace, $ss_format ) = @_;
}
else {
my ( $clientip, $n_nodes, $p_value, $update_sequential,
$update_schedule, $statespace, $ss_format )
= @_[ 0 .. -2 ];
_load_function_data( \$_[-1] );
my ( $success, $message ) = error_check(@Function_data);
return _package_error($message) unless ($success);
# error_check(@Function_data)[0] or return $Output_array; # WHERE $Output_array is set by _package_error
}
_log("Got clientip as $clientip WHERE Session_on = $Session_on");
_log("session variables = $clientip, $n_nodes, $p_value");
#now for the main loop.
#we create a file ip.out.dot describing the state space
########### what to do here?
$dot_filename = _get_filelocation("$clientip.out.dot");
#print ("Got dot_filename as $dot_filename WHERE Session_on = $Session_on");
open( $Dot_file, ">$dot_filename" )
or return print("Could not open $dot_filename.");
#open($Dot_file, ">$dot_filename") or return _package_error("Could not open $dot_filename.");
print $Dot_file "digraph test {\n";
#we count both by $i and by @y which encodes $i in base $p_value
#first initialize @y, probably not needed
$y[$_] = 0 foreach ( 0 .. $n_nodes - 1 );
_log("starting loop");
@fixed_points = [];
# Iterate through all combinations of update functions by using recursive
# function
recu( 0, 1 );
_log("Adjacency matrix");
for ( my $x = 0; $x < $p_value**$n_nodes; $x++ ) {
for ( my $y = 0; $y < $p_value**$n_nodes; $y++ ) {
if ( scalar( $Adj[$x][$y] ) > 0 ) {
#printf "%.2f\t",$Adj[$x][$y];
if ( $x == $y ) { #fixed point
# add state number and probability
push( @fixed_points, [ $x, $Adj[$x][$y] ] );
}
if ( !$Stochastic ) { #make an edge from @y to @ans
# graph with arrows without probablities
print $Dot_file "node$x -> node$y\n";
}
else { # graph probablities
printf $Dot_file "node$x -> node$y [label= \"%.2f",
$Adj[$x][$y];
printf $Dot_file "\"];\n";
}
}
else { #print("0 \t");
}
}
#print("\n");
}
shift(@fixed_points);
_log("ended loop.");
# terminate and close ip.out.dot
print $Dot_file "}";
close($Dot_file);
}
sub create_output {
$Current_program = "create_output";
$Output_array[6] = $dot_filename;
# Initialize client side mapping variables needed for commmand
# line calls
my $client_wd = _get_filelocation($clientip);
$cwd = getcwd();
`mkdir -p $cwd\/$client_wd`;
`chmod 777 $client_wd`;
`mkdir -p $client_wd/tmp`;
`chmod 777 $client_wd/tmp`;
`mkdir -p $client_wd/dev` ;
`chmod 777 $client_wd/dev`;
#$pres = `pwd`;
#chomp($pres);
my $pres = "";
# dot_filename is .dot file
# count connected components
my $s = `gc -c $dot_filename`;
print "<br><br>s $s\n<br>" if ($DEBUG);
print "<br>" if ($DEBUG);
#remove trailing return
chomp $s;
#remove white space at beginning (\s+ matchs 1 or more spaces)
$s =~ s/\s+//;
_log("Output \$s $s");
#split off the number
my @tmp = split( / /, $s );
my $num_comps = $tmp[0];
# Get number of fixed points as length of fixed_points array
my $fp = $#fixed_points + 1;
_log("There are $num_comps components and $fp fixed point(s)");
$Output_array[2] = $num_comps;
$Output_array[3] = $fp;
# each connected component is written to a separated file (/tmp/component)
my $cwd = getcwd();
print "current dir $cwd\n<br>" if ($DEBUG);
`ccomps -x -o $client_wd/tmp/component $dot_filename`;
print "ccomps -x -o $client_wd/tmp/component $dot_filename\n<br>" if ($DEBUG);
print "return value of ccomps: $? \n<br>" if ($DEBUG);
system("mv $client_wd/tmp/component $client_wd/tmp/component_0");
#store the components in files /tmp/component, /tmp/component_1, etc
#FIXME: parse output of ccomps -v to get #components, then eliminate gc check
#above. Probably only saves a few percent of the time, though, so whatever
#NOTE: sccmap picks out the strongly connected component
# of a directed graph. In our case, that's the limit cycle.
# But sccmap doesn't consider self loops, so we add the fixed point in
#first process ./tmp/component (stupid naming scheme by ccomps)
#FIXME: this really should be broken into a procedure
# $size = `gc -n $client_wd/tmp/component`;
# print "gc -n $client_wd/tmp/component\n<br>" if ($DEBUG);
# print "$size\n<br>" if ($DEBUG);
# `sccmap $client_wd/tmp/component -o $client_wd/tmp/cycle_$i`
# $cycle
# = `sccmap $client_wd/tmp/component 2> $client_wd/dev/null | grep label | wc -l`;
# print "sccmap $client_wd/tmp/component 2> $client_wd/dev/null | grep label | wc -l\n" if ($DEBUG);
# chomp $size;
# chomp $cycle;
# $size =~ s/\s+//;
# $cycle =~ s/\s+//;
# if ( $cycle == 0 ) { $cycle++; }
### don't print any compononents and their cycles yet
#$Output_array[4] = "1 $size $cycle";
$total_size = 0;
$numCycles = 0;
$haveCycles = 0;
for ( $i = 0; $i < $num_comps; $i++ ) {
$size = `grep -c label $client_wd/tmp/component_$i`;
`sccmap $client_wd/tmp/component_$i -o $client_wd/tmp/cycle_$i`;
print "sccmap $client_wd/tmp/component_$i -o $client_wd/tmp/cycle_$i \n<br>" if ($DEBUG);
$cycle = `grep -c label $client_wd/tmp/cycle_$i`;
chomp $size;
chomp $cycle;
$size =~ s/\s+//;
$cycle =~ s/\s+//;
if ( $cycle == 0 ) {
$cycle++;
}
else {
if ($haveCycles == 0) {
$Output_array[4] = "Attractor, cycle length, component size<br>";
$haveCycles = 1;
}
## We need to create a textual representation fot the cycle.
my $edge = [];
my $state = [];
my $start = -1;
open(CYCLE, $client_wd . "/tmp/cycle_$i");
foreach $line (<CYCLE>) {
if ($line =~ /->/) {
$line =~ /node([0-9]+)\s*->\s*node([0-9]+)/;
$edge[$1] = $2;
}
elsif ($line =~ /label/) {
$line =~ /node([0-9]+).*" ([ 0-9]+)"/;
if ($start < 0) {
$start = $1;
}
$state[$1] = $2;
}
}
close(CYCLE);
$attractor = "($state[$start])";
$node = $edge[$start];
while ($node != $start) {
$attractor .= " -> ($state[$node])";
$node = $edge[$node];
}
$Output_array[4] .= "$attractor, $cycle, $size <br>";
print "$attractor, $cycle, $size <br>" if ($DEBUG);
}
# print "component_$i: nodes: $size, length: $cycle \n<br>";
### don't print any compononents and their cycles yet
# $Output_array[4] = $Output_array[4]."|$tmp $size $cycle";
$total_size += $size;
}
if ( $fp > 0 ) {
for ( $i = 0; $i < scalar(@fixed_points); $i++ ) {
_log("number of fixed points: $#fixed_points +1");
# fixed points
#once again convert base p back to decimal
# $num = 0;
# for ($j = 0 ; $j < $n_nodes; $j++)
# {
# $num += $fixed_points[$i][$j]*$p_value**($n_nodes-$j-1);
# }
#fixed_points has fixed point as decimal number
$num = $fixed_points[$i][0];
my $prob_f = sprintf( "%.2f", $fixed_points[$i][1] );
_log("Prob \$fixed_points[$i][1] $fixed_points[$i][1]");
_log("Prob \$prob_f $prob_f");
# this computes the connected component of node @fixed_points[$i]
_log(
"ccomps -Xnode$num $dot_filename -v > $client_wd/tmp/blah 2> $client_wd/dev/null"
);
`ccomps -Xnode$num $dot_filename > $client_wd/tmp/blah 2> $client_wd/dev/null`;
#`ccomps -Xnode$num $dot_filename -v > $client_wd/tmp/blah 2> $client_wd/dev/null`;
#then we count how many labels (and thus nodes) there are in the file
# don't count lines with -> in them
$s = `grep -c label $client_wd/tmp/blah`;