Advertisement
Not a member of Pastebin yet?
Sign Up,
it unlocks many cool features!
- ############################################# MODUL
- #!/usr/bin/perl
- package graflib;
- # objekt grafu
- sub new {
- my $class = shift;
- my $object = {
- a => shift, # parametr a
- b => shift, # parametr b
- c => shift, # parametr c
- node_list => {}, # seznam uzlu
- link_types => {}, # seznam typu hran
- };
- bless $object, $class;
- return $object;
- }
- # zadavani typu hran do seznamu typu hran
- sub link_type {
- my($self, $type, $reciprocal) = @_;
- $self->{link_types}{$type}{weight} = 0;
- $self->{link_types}{$type}{reciprocal} = $reciprocal;
- }
- # dodani vah do seznamu typu hran
- sub link_weight {
- my($self, $type, $weight) = @_;
- $self->{link_types}{$type}{weight} = $weight;
- }
- # pridani konkretnich hran
- sub add_link {
- my($self, $from, $to, $type) = @_;
- my $weight = $self->{link_types}{$type}{weight};
- # pridani vystupni hrany
- push @{$self->{node_list}{$from}{out}{$to}}, $weight;
- if ($self->{link_types}{$type}{reciprocal}) {
- push @{$self->{node_list}{$to}{out}{$from}}, $weight;
- }
- # pridani vstupni hrany
- push @{$self->{node_list}{$to}{in}{$from}}, $weight;
- if ($self->{link_types}{$type}{reciprocal}) {
- push @{$self->{node_list}{$from}{in}{$to}}, $weight;
- }
- }
- # pridani konkretnich uzlu
- sub add_node {
- my($self, $name, $type) = @_;
- $self->{node_list}{$name}{type} = $type;
- $self->{node_list}{$name}{level} = 0;
- $self->{node_list}{$name}{initial} = 0;
- }
- # dodani hodnoty uzlu
- sub set_value {
- my($self, $name, $level) = @_;
- $self->{node_list}{$name}{level} = $level;
- if ($level > 0) {$self->{node_list}{$name}{initial} = $level;}
- }
- # sireni signalu do hran dle vzorce Xi * 1 / outdegree(i)^b
- # !!! vzorec nesedi s referencnimi hodnotami, nutno vynasobit sqrt(pocet vystupnich hran) !!!
- sub signal_wave {
- my($self, $node) = @_;
- my $xi = $$node->{level};
- my $out_links = 0;
- # pocet vystupnich hran
- for my $nodes (keys %{$$node->{out}}) {
- $out_links += scalar @{$$node->{out}{$nodes}};
- }
- # aplikace vzorce
- if ($xi != 0 && $out_links != 0) {
- ($xi * 1 / $out_links ** $self->{b})* sqrt($out_links); # zminena nekonzistence zadani
- }
- else {$xi;}
- }
- # pruchod hranou
- sub throught_link {
- my($self, $signal, $weight) = @_;
- $signal * $weight;
- }
- # vypocet nove hodnoty dle vzorce a*X(i) + b*Input(i) + c*Output(i)
- sub new_value {
- my($self, $node) = @_;
- my $node = \$self->{node_list}{$node};
- my $xi = $$node->{level};
- my $nodes;
- my $weight;
- # vypocet prichazejicich signalu
- my $input = 0;
- for $nodes (keys %{$$node->{in}}) {
- my $signal = $self->{node_list}{$nodes}{signal};
- for my $weight (@{$$$node{in}{$nodes}}) {
- $input += $self->throught_link($signal, $weight);
- }
- }
- # vypocet poslanych signalu
- my $output = 0;
- for $nodes (keys %{$$node->{out}}) {
- for $weight (@{$$$node{out}{$nodes}}) {
- $output += $$node->{signal};
- }
- }
- # aplikace vzorce
- return $self->{a} * $xi + $self->{b} * $input + $self->{c} * $output;
- }
- # smazani uzlu
- sub delete_node {
- my($self, $node) = @_;
- delete $self->{node_list}{$node};
- for my $nodes (keys %{$self->{node_list}}){
- delete $self->{node_list}{$nodes}{in}{$node};
- delete $self->{node_list}{$nodes}{out}{$node};
- }
- }
- 1;
- ############################################################### Main program
- #!/usr/bin/perl
- use graflib;
- use strict;
- use encoding 'UTF-8';
- my $a; # parametr a
- my $b; # parametr b
- my $c; # parametr c
- my $i; # pocet iteraci
- my $t; # redukcni konstanta
- my $k; # zpusob kalibrace
- # otevreni souboru zadaneho parametrem
- open FILE, "<:encoding(UTF-8)", @ARGV[0] or die "$!\n";
- while (<FILE>) { # hledani parametru a
- @_ = split /\s+/;
- my $keyword = shift @_;
- if ($keyword eq "a") {$a = shift @_;}
- }
- seek FILE, 0, 0;
- while (<FILE>) { # hledani parametru b
- @_ = split /\s+/;
- my $keyword = shift @_;
- if ($keyword eq "b") {$b = shift @_;}
- }
- seek FILE, 0, 0;
- while (<FILE>) { # hledani parametru c
- @_ = split /\s+/;
- my $keyword = shift @_;
- if ($keyword eq "c") {$c = shift @_;}
- }
- seek FILE, 0, 0;
- # pouziti parametru k vytvoreni objektu
- my $graf = graflib->new($a,$b,$c);
- while (<FILE>) { # hledani poctu iteraci
- @_ = split /\s+/;
- my $keyword = shift @_;
- if ($keyword eq "IterationsNo") {$i = shift @_;}
- }
- seek FILE, 0, 0;
- while (<FILE>) { # hledani redukcni konstanty
- @_ = split /\s+/;
- my $keyword = shift @_;
- if ($keyword eq "t") {$t = shift @_;}
- }
- seek FILE, 0, 0;
- while (<FILE>) { # hledani zpusobu kalibrace
- @_ = split /\s+/;
- my $keyword = shift @_;
- if ($keyword eq "Calibration") {$k = shift @_;}
- }
- seek FILE, 0, 0;
- while (<FILE>) { # pridani typu hran
- @_ = split /\s+/;
- my $keyword = shift @_;
- if ($keyword eq "ltra") {$graf->link_type(@_);}
- }
- seek FILE, 0, 0;
- while (<FILE>) { # pridani vahy vazeb
- @_ = split /\s+/;
- my $keyword = shift @_;
- if ($keyword eq "lw") {$graf->link_weight(@_);}
- }
- seek FILE, 0, 0;
- while (<FILE>) { # pridani konkretnich uzlu
- @_ = split /\s+/;
- my $keyword = shift @_;
- if ($keyword eq "n") {$graf->add_node(@_);}
- }
- seek FILE, 0, 0;
- while (<FILE>) { # pridani konkretnich hran
- @_ = split /\s+/;
- my $keyword = shift @_;
- if ($keyword eq "l") {$graf->add_link(@_);}
- }
- seek FILE, 0, 0;
- while (<FILE>) { # nastaveni pocatecnich hodnot
- @_ = split /\s+/;
- my $keyword = shift @_;
- if ($keyword eq "ia") {$graf->set_value(@_);}
- }
- # zavreni souboru
- close FILE;
- # vypsani prvniho radku s nazvy uzlu
- print "iter. ";
- for my $nodes (sort(keys %{$graf->{node_list}})) {print "$nodes ";}
- print "\n";
- # iterovani
- for (my $j = 0; $j <= $i; $j++){
- my $node;
- my $calibsum;
- my $calibsumall;
- # tisk hodnot uzlu
- print "$j ";
- for my $nodes (sort(keys %{$graf->{node_list}})) {
- printf "%.3f ", $graf->{node_list}{$nodes}{level};
- }
- print "\n";
- # kalibrace 2: zapamatuji si sumu v pocatku aktivovanych uzlu
- for my $nodes (keys %{$graf->{node_list}}) {
- if ($k eq "ConservationOfTotalActivation" && $graf->{node_list}{$nodes}{initial} > 0) {
- $calibsum += $graf->{node_list}{$nodes}{initial};
- }
- }
- # vypocet signalu v uzlech
- for my $nodes (keys %{$graf->{node_list}}) {
- $node = \$graf->{node_list}{$nodes};
- my $signal = $graf->signal_wave($node);
- $graf->{node_list}{$nodes}{signal} = $signal;
- }
- # vypocet nove hodnoty uzlu
- for my $nodes (keys %{$graf->{node_list}}) {
- my $new = $graf->new_value($nodes);
- $graf->{node_list}{$nodes}{level} = $new;
- }
- # kalibrace 1: zmenim v pocatku aktivovane uzly na aktivacni hodnoty a pamatuji pomer
- for my $nodes (keys %{$graf->{node_list}}) {
- if ($k eq "ConservationOfInitialActivation" && $graf->{node_list}{$nodes}{initial} > 0) {
- $calibsum += $graf->{node_list}{$nodes}{level} / $graf->{node_list}{$nodes}{initial};
- $graf->{node_list}{$nodes}{level} = $graf->{node_list}{$nodes}{initial};
- }
- }
- # kalibrace 1: vydelim vsechny uzly neaktivovane v pocatku pomerem v pocatku aktivovanych uzlu
- for my $nodes (keys %{$graf->{node_list}}) {
- if ($k eq "ConservationOfInitialActivation" && $graf->{node_list}{$nodes}{initial} == 0) {
- if ($calibsum != 0) {
- $graf->{node_list}{$nodes}{level} = $graf->{node_list}{$nodes}{level} / $calibsum;
- }
- }
- }
- # kalibrace 2: zapamatuji si sumu vsech uzlu
- for my $nodes (keys %{$graf->{node_list}}) {
- if ($k eq "ConservationOfTotalActivation") {
- $calibsumall += $graf->{node_list}{$nodes}{level};
- }
- }
- # kalibrace 2: vydelim vsechny uzly pomerem sumy vsech uzlu a sumy pocatecnich uzlu
- for my $nodes (keys %{$graf->{node_list}}) {
- if ($k eq "ConservationOfTotalActivation") {
- $graf->{node_list}{$nodes}{level} = $graf->{node_list}{$nodes}{level} / ($calibsumall / $calibsum);
- }
- }
- # redukce uzlu podle konstanty t
- for my $nodes (keys %{$graf->{node_list}}) {
- $graf->delete_node($nodes) unless ($graf->{node_list}{$nodes}{level} >= $t);
- }
- }
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement