# parse-wiki.pl
# (c) Alexandr A Alexeev 2012 | http://remontka.com/

use strict ;
use warnings ;
use LWP :: UserAgent ;

main (
[ ‘Perl’ ] ,
{
Perl => { url => ‘http://en.wikipedia.org/wiki/Perl’ }
}
) ;

sub main {
my ( $queue , $lang_info ) = @_ ;
my %influenced_table ; # {Perl}{Python} = 1

while ( @ { $queue } ) {
my $lang = shift @ { $queue } ;
my $url = $lang_info -> { $lang } { url } ;

warn «Queue size: » . scalar ( @ { $queue } ) .
«, fetching $lang info, url: $url n » ;
my $data = getUrl ( $url ) ;

$lang_info -> { $lang } { year } = parseYear ( $data ) ;

my $influenced = parseInfluenced ( $data ) ;
for my $new_lang ( keys % { $influenced } ) {
$influenced_table { $lang } { $new_lang } = 1 ;
# in queue or allready parsed
next if defined $lang_info -> { $new_lang } ;
$lang_info -> { $new_lang } = {
url => $influenced -> { $new_lang }
} ;
push @ { $queue } , $new_lang ;
}

my $influencedBy = parseInfluencedBy ( $data ) ;
for my $new_lang ( keys % { $influencedBy } ) {
$influenced_table { $new_lang } { $lang } = 1 ;
# in queue or allready parsed
next if defined $lang_info -> { $new_lang } ;
$lang_info -> { $new_lang } = {
url => $influencedBy -> { $new_lang }
} ;
push @ { $queue } , $new_lang ;
}
}
warn «All done, writing result n » ;
dumpInfo ( $lang_info , %influenced_table ) ;
}

sub dumpInfo {
my ( $lang_info , $influenced ) = @_ ;
for my $lang ( keys % { $lang_info } ) {
my $inf_list = join ( «,» , keys % { $influenced -> { $lang } } ) ;
my $year = $lang_info -> { $lang } { year } ;
my $url = $lang_info -> { $lang } { url } ;
print «$year:$lang:$url:$inf_list n » ;
}
}

sub parseYear {
my ( $data ) = @_ ;
my ( $year ) = $data =~ m ! Appeared in </ th > [ ^< ] *< td [ ^> ] *> ( ?:< a [ ^> ] *> ) ? ( ( ?: 19 | 20 ) d { 2 } ) ! si ;
$year = «unknown» unless defined $year ;
return $year ;
}

sub parseInfluenced {
my ( $data ) = @_ ;
return parseLangList ( «Influenced» , $data ) ;
}

sub parseInfluencedBy {
my ( $data ) = @_ ;
return parseLangList ( «Influenced by» , $data ) ;
}

sub parseLangList {
my ( $key , $data ) = @_ ;
my %lang_table ;
my ( $inf_block ) = $data =~ m !< th [ ^> ] *> $key </ th > [ ^< ] *< td class = «» style = «» > ( .*? ) </ td >! si ;
if ( defined $inf_block ) {
while ( my ( $url , $lang , $rest ) = $inf_block =~ m ‘^<a href=»/([^»]+)»[^>]*>([^<]+)</a>(?:, )?(.*)$’ si ) {
$inf_block = $rest ;
next unless ( $url =~ m !^ wiki /! ) ;
$url = «http://en.wikipedia.org/$url» ;
warn »    $key $lang, url: $url n » ;
$lang_table { $lang } = $url ;
}
}
return %lang_table ;
}

sub getUrl {
my ( $url ) = @_ ;
my $lwp = LWP :: UserAgent -> new (
timeout => 30 ,
agent => ‘Opera/9.80 (X11; FreeBSD 8.2-RELEASE i386; U; ru) Presto/2.9.168 Version/11.52’ ,
) ;
my $res = $lwp -> get ( $url ) ;
unless ( $res -> is_success ) {
die «Failed to download $url (» . $res -> status_line . «)» ;
}
return $res -> as_string ;
}

# gen-gv.pl
# (c) Alexandr A Alexeev 2012 | http://remontka.com/

use strict ;
use warnings ;

my $fname = shift ;
unless ( $fname ) {
die «Usage: $0 <fname> n » ;
}

my $graph = loadGraph ( $fname ) ;
optimizeGraph ( $graph ) ;
printGraph ( $graph ) ;

sub optimizeGraph {
my ( $graph ) = @_ ;
my $rev_graph = reverseGraph ( $graph ) ;
# для каждой дуги ($from, $to);
for my $from ( keys % { $graph } ) {
for my $to ( keys % { $graph -> { $from } } ) {
# если есть обратный путь без использования этой дуги
my %used_paths ;
$used_paths { $to } { $from } = 1 ;
if ( pathExists ( $rev_graph , $to , $from , %used_paths ) ) {
# то это транзитивная дуга — удаляем ее
delete $graph -> { $from } { $to } ;
delete $rev_graph -> { $to } { $from } ;
}
}
}
}

sub pathExists { # поиск в ширину пути в $graph из $from в $to
my ( $graph , $from , $to , $used_patchs ) = @_ ;
my @open_patchs ;
# перебираем вершины, соседние с начальной
for my $new_to ( keys % { $graph -> { $from } } ) {
unless ( $used_patchs -> { $from } { $new_to } ) {
return 1 if ( $new_to eq $to ) ;
push @open_patchs , [ $from , $new_to ] ;
}
}

while ( @open_patchs ) {
my $path = shift @open_patchs ;
my $curr_from = $path -> [ 0 ] ;
my $curr_to = $path -> [ 1 ] ; # придумать имя получше?
$used_patchs -> { $curr_from } { $curr_to } = 1 ;
for my $new_to ( keys % { $graph -> { $curr_to } } ) {
unless ( $used_patchs -> { $curr_to } { $new_to } ) {
return 1 if ( $new_to eq $to ) ;
push @open_patchs , [ $curr_to , $new_to ] ;
}
}
}
return 0 ;
}

sub reverseGraph {
my ( $graph ) = @_ ;
my %rslt ;
for my $from ( keys % { $graph } ) {
for my $to ( keys % { $graph -> { $from } } ) {
$rslt { $to } { $from } = 1 ;
}
}
return %rslt ;
}

sub loadGraph {
my ( $fname ) = @_ ;
my %graph ;
open my $fid , «<» , $fname or die $! ;
# my $i = 0;
while ( my $line = < $fid > ) {
# last if(++$i > 50);
chomp ( $line ) ;
my ( $year , $lang , $url1 , $url2 , $influenced ) = split /:/ , $line ;
next if ( $year eq «unknown» ) ;
my @influenced_list = split /,/ , $influenced ;
for my $infl_lang ( @influenced_list ) {
$graph { $lang } { $infl_lang } = 1 ;
}
}
close $fid ;
return %graph ;
}

sub printGraph {
my ( $graph ) = @_ ;
print «digraph G { n nodesep=1; n mindist=1; n » ;
for my $from ( keys % { $graph } ) {
for my $to ( keys % { $graph -> { $from } } ) {
print qq { «$from» -> «$to» ; n } ;
}
}
print «} n » ;
}