OpenCores
URL https://opencores.org/ocsvn/an-fpga-implementation-of-low-latency-noc-based-mpsoc/an-fpga-implementation-of-low-latency-noc-based-mpsoc/trunk

Subversion Repositories an-fpga-implementation-of-low-latency-noc-based-mpsoc

[/] [an-fpga-implementation-of-low-latency-noc-based-mpsoc/] [trunk/] [mpsoc/] [perl_gui/] [lib/] [perl/] [tsort.pm] - Blame information for rev 48

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 48 alirezamon 
#!/usr/bin/perl
2 
 
3 
 
4 
 
5 
package Algorithm::TSort;
6 
use 5.007003;
7 
use strict;
8 
use warnings;
9 
require Exporter;
10 
our @ISA = qw(Exporter);
11 
 
12 
# Items to export into callers namespace by default. Note: do not export
13 
# names by default without a very good reason. Use EXPORT_OK instead.
14 
# Do not simply export all your public functions/methods/constants.
15 
 
16 
# This allows declaration       use Algorithm::TSort ':all';
17 
# If you do not need this, moving things directly into @EXPORT or @EXPORT_OK
18 
# will save memory.
19 
our %EXPORT_TAGS = ( 'all' => [ qw(
20 
        tsort
21 
        Graph
22 
) ] );
23 
 
24 
our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
25 
 
26 
our @EXPORT = qw( tsort );
27 
 
28 
our $VERSION = '0.05';
29 
{
30 
    package Algorithm::TSort::ADJ;
31 
    sub adj_nodes {
32 
        my $self = shift;
33 
        my $node = shift;
34 
        for ( $self->{$node} ) {
35 
            return @$_ if ref;
36 
        }
37 
        return ();
38 
    }
39 
 
40 
    sub nodes {
41 
        return keys %{ $_[0] };
42 
    }
43 
    package Algorithm::TSort::ADJSUB;
44 
    sub adj_nodes {
45 
        my $self = shift;
46 
        my $node = shift;
47 
        return $$self->($node);
48 
    }
49 
    package Algorithm::TSort::ADJSUB_ARRAYREF;
50 
    sub adj_nodes {
51 
        my $array = $_[0]->( $_[1] );
52 
        return $array ? @$array : ();
53 
    }
54 
    package Algorithm::TSort::Guard;
55 
    sub new{
56 
        return bless $_[1], $_[0];
57 
    }
58 
    sub DESTROY { $_[0]->() };
59 
}
60 
 
61 
sub Graph($$) {
62 
    my $what = shift;
63 
    my $data = shift;
64 
    die "Graph: undefined input" unless defined $what;
65 
    if ( $what eq 'IO' || $what eq 'SCALAR' ) {
66 
        my %c;
67 
        my $line;
68 
        my $fh;
69 
        if ( $what eq 'SCALAR' ) {
70 
            open $fh, "<", \$data;
71 
        }
72 
        else {
73 
            $fh = $data;
74 
        }
75 
        local $/ = "\n";
76 
        while ( defined( $line = <$fh> ) ) {
77 
            chomp $line;
78 
            next unless $line =~ m/\S/;
79 
            my ( $node, @deps ) = split ' ', $line;
80 
            $c{$node} = \@deps;
81 
        }
82 
        return bless \%c, 'Algorithm::TSort::ADJ';
83 
    }
84 
    elsif ( $what eq 'ADJSUB' ) {
85 
        return bless \( my $s = $data ), 'Algorithm::TSort::ADJSUB';
86 
    }
87 
    elsif ( $what eq 'ADJSUB_ARRAYREF' ) {
88 
        return bless $data, 'Algorithm::TSort::ADJSUB_ARRAYREF';
89 
    }
90 
    elsif ( $what eq 'ADJ' ) {
91 
        my %c = %$data;
92 
        return bless \%c, 'Algorithm::TSort::ADJ';
93 
    }
94 
    else {
95 
        require Carp;
96 
        Carp::croak("Graph: don't know about \$what='$what'");
97 
    }
98 
}
99 
 
100 
 
101 
# Preloaded methods go here.
102 
sub tsort($;@) {
103 
    my $object = shift;
104 
    my @nodes  = @_;
105 
    my @sorted;
106 
    my %seen;
107 
    my $req_sub;
108 
    my $guard;
109 
    unless (@nodes) {
110 
        if ( UNIVERSAL::can( $object, 'nodes') ) {
111 
            @nodes = $object->nodes();
112 
        }
113 
        else {
114 
            require Carp;
115 
            Carp::croak("tsort: no nodes for sort");
116 
        }
117 
    }
118 
    $guard = Algorithm::TSort::Guard->new(sub {
119 
        $req_sub = undef; # remove circular dependency;
120 
    });
121 
 
122 
 
123 
    $req_sub = sub {
124 
        my $node = shift;
125 
        if ( $seen{$node} ) {
126 
            die "Algorithm::TSort - can't tsort cicle detected" if ( $seen{$node} == 1 );
127 
            return;
128 
        }
129 
        $seen{$node} = 1;
130 
        for ( $object->adj_nodes($node) ) {
131 
            $req_sub->($_);
132 
        }
133 
        $seen{$node} = 2;
134 
        push @sorted, $node;
135 
    };
136 
 
137 
    for (@nodes) {
138 
        next if $seen{$_};
139 
        $req_sub->($_);
140 
    }
141 
    return reverse @sorted;
142 
}
143 
 
144 
 
145 
 
146 
 
147 
sub  cicle_detect($;@) {
148 
    my $object = shift;
149 
    my @nodes  = @_;
150 
    my @sorted;
151 
    my %seen;
152 
    my $req_sub;
153 
    my $guard;
154 
    my $cyclic=0;
155 
    unless (@nodes) {
156 
        if ( UNIVERSAL::can( $object, 'nodes') ) {
157 
            @nodes = $object->nodes();
158 
        }
159 
        else {
160 
            require Carp;
161 
            Carp::croak("tsort: no nodes for sort");
162 
        }
163 
    }
164 
    $guard = Algorithm::TSort::Guard->new(sub {
165 
        $req_sub = undef; # remove circular dependency;
166 
    });
167 
 
168 
 
169 
    $req_sub = sub {
170 
        my $node = shift;
171 
        if ( $seen{$node} ) {
172 
            #die "Algorithm::TSort - can't tsort cicle detected" if ( $seen{$node} == 1 );
173 
             $cyclic=1 if ( $seen{$node} == 1 );
174 
                return;
175 
        }
176 
        $seen{$node} = 1;
177 
        for ( $object->adj_nodes($node) ) {
178 
            $req_sub->($_);
179 
        }
180 
        $seen{$node} = 2;
181 
        push @sorted, $node;
182 
    };
183 
 
184 
    for (@nodes) {
185 
        next if $seen{$_};
186 
        $req_sub->($_);
187 
    }
188 
    return $cyclic;
189 
}
190 
 
191 
 
192 
 
193 
 
194 
 
195 
 
196 
 
197 
 
198 
 
199 
 
200 
 
201 
 
202 
 
203 
1;
204 
__END__
205 
# Below is stub documentation for your module. You'd better edit it!
206 
 
207 
=head1 NAME
208 
 
209 
Algorithm::TSort - Perl extension for topological sort
210 
 
211 
=head1 SYNOPSIS
212 
 
213 
  use Algorithm::TSort;
214 
 
215 
 
216 
  #  $adj = { 1 => [ 2, 3], 2 => [4], 3 => [4]  } ;
217 
  my (@sorted ) = tsort( Graph( ADJ => $adj ). keys %$adj );
218 
  say for @sorted;
219 
 
220 
  # -- OR --
221 
 
222 
  # $adj_sub = sub { return unless $adj->{ $_[0] } ; return @{$adj->{$_[0]}}; };
223 
  my (@sorted) = tsort( Graph( ADJSUB => $adj_sub ), @nodes_for_sort );
224 
 
225 
  # -- OR --
226 
 
227 
  # $sub_arrayref = sub { $adj->{ $_[0] } };
228 
  my (@sorted) = tsort( Graph( ADJSUB_ARRAYREF => $adj_sub ), @nodes_for_sort );
229 
 
230 
  # -- OR --
231 
 
232 
  # $buf  =
233 
  #  "1 2 3
234 
  #   2 4
235 
  #   3 4";
236 
 
237 
  my (@sorted) = tsort( Graph ( SCALAR => $buf ));
238 
 
239 
 
240 
  # -- OR --
241 
  #
242 
 
243 
  my (@sorted) = tsort( Graph ( IO => \*STDIN) );
244 
  print "$_\n" for @sorted;
245 
 
246 
  # -- OR --
247 
 
248 
  # Write your own class for graph with 'adj_nodes' method
249 
  # my $graph = MyGraph->new;
250 
  # # Initialization ...
251 
 
252 
  my (@sorted ) = tsort( $graph, @nodes_for_sort );
253 
 
254 
 
255 
=head1 DESCRIPTION
256 
 
257 
Topological sort for varing inputs
258 
 
259 
=head2 EXPORT
260 
 
261 
Graph, tsort
262 
 
263 
=head1 SEE ALSO
264 
 
265 
L<Sort::Topological>, L<Graph>
266 
 
267 
=head1 AUTHOR
268 
 
269 
A. G. Grishaev, E<lt>grian@cpan.orgE<gt>
270 
 
271 
=head1 COPYRIGHT AND LICENSE
272 
 
273 
Copyright (C) 2010-2016 by A. G. Grishaev
274 
 
275 
This library is free software; you can redistribute it and/or modify
276 
it under the same terms as Perl itself, either Perl version 5.10.1 or,
277 
at your option, any later version of Perl 5 you may have available.
278 
 
279 
=cut

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.