Beefy Boxes and Bandwidth Generously Provided by pair Networks
Just another Perl shrine

(Golf) Minimizing the Bacon Number

by Masem (Monsignor)
on May 14, 2001 at 21:56 UTC ( #80272=perlmeditation: print w/replies, xml ) Need Help??

Note that this is related to, but certainly not the same problem, as Minimum Graph Distance.

First, the introduction. Unless you slept through the 90s, the so-called Bacon number is the number of actors between an actor and Kevin Bacon, where the connection between susseccive actors is a movie they co-starred in. Kevin Bacon's number would be 0, those that co-starred with him in any movie would be 1, and so forth. For example, UPDATING THIS PART, since I fudged up big time Nicholos Cage would have a Bacon Number of 2, since he starred in The Rock with Ed Harris, who co-starred with Bacon in Apollo 13.

Now, it's been shown that Bacon is truly not the best 'center' of the actor universe, as the average Bacon number using Bacon is around 4, while using the best center brings it down to about 3.5 (The center person changes often with new movies, but when I last checked, there's a good 4 or 5 near-center people). But people still play the game with Bacon.

To programmers, this task is pretty much optimizing the root node of a arbitarily-branched tree structure in order to minimize the average depth.

So the challenge is: Given an arbitary tree structure, stored as %t; the keys of %t are the names of the nodes, while the value for each key is a list of nodes that are connected to that node. There are no disjoint parts of the tree, and it's possible to go from any one node to another by following a link. However, there are no 'loops', that is, there is only one distinct path between any two nodes. (If there were loops, this becomes a graph, and can make the problem a bit harder). You can assume that if there is a link from 'a' to 'b', 'b' will have a link back to 'a'.

Find the perl golf solution (min. number of characters in program), for a subroutine b( %t ) that returns the name of the node that, if considered to be the central node, minimizes the average Bacon number/depth for all nodes. To clairify it, the Bacon number is defined as the number of links between the central node and any other node, with the central node being 0, nodes directly connected to it as 1, and so forth.

For a test case: update typo fixed

my %t = ( Chicago=>[ 'Detroit', 'Cleveland', 'Denver' ], Cleveland=>[ 'Chicago', 'NYC' ], Detroit=>[ 'Chicago' ], NYC=>[ 'Cleveland' ], SF=>[ 'Denver', 'Fairbanks' ], Fairbanks=>[ 'SF','Tokyo' ], Tokyo=>[ 'Fairbanks', 'Moscow' ], Moscow=>[ 'Tokyo' ], Denver=>[ 'SF', 'Chicago' ] );

Extra Credit: Assume there are loops, such that %t can be a graph as opposed to a tree. Find the solution in this case.

Dr. Michael K. Neylon - || "You've left the lens cap of your mind on again, Pinky" - The Brain

Replies are listed 'Best First'.
Re: (Golf) Minimizing the Bacon Number
by bjelli (Pilgrim) on May 15, 2001 at 02:35 UTC

    My first try at golf:

    sub b { $M = scalar keys %t; $m = $M *= $M; foreach ( keys %t ) { $r = c( $_ ); ($m,$n) = ($r, $_) if ($r < $m ); } $n; } sub c { @s=@_; %b = ( $s[0] => $b=$sum=0 ); while ( @s > 0 ) { $b ++; @s = grep { ! exists( $b{$_} ) } map { @{$t{$_}} } @s; @b{ @s } = ($b) x scalar(@s); $sum += $b * scalar(@s); return $M if $sum > $m } $sum; }

    works for graphs too, I think.

    Update: I can write that down in 196:

    sub b{$M=$m=@_*@_;for(keys %t){$r=c($_);($m,$n)=($r,$_)if($r<$m)}$n}su +b c{%b=($_[0]=>$b=$sum=1);while(@_){$b++;@_=grep{!$b{$_}}map{@{$t{$_} +}}@_;@b{@_}=($b)x@_;$sum+=$b*@_;return$M if$sum>$m}$sum}

    slower but shorter: down to 177:

    sub b{$M=$m=@_*@_;for(keys %t){$r=c($_);($m,$n)=($r,$_)if($r<$m)}$n}su +b c{%b=($_[0]=>$b=$sum=1);while(@_){$b++;@_=grep{!$b{$_}}map{@{$t{$_} +}}@_;@b{@_}=($b)x@_;$sum+=$b*@_}$sum}

    I never new how hard obfuscation is! </code>

    Brigitte    'I never met a chocolate I didnt like'    Jellinek
Re: (Golf) Minimizing the Bacon Number
by MeowChow (Vicar) on May 15, 2001 at 05:16 UTC
    Here's a solution (plus extra credit :) at 151:
    sub bacon { (%g,%d)=@_;for$k(keys%g){($i,@l,%v)=(0,$k);{!$v{$_}++and$d{$k}+=$i f +or@l;$i++;(@l=map{grep!$v{$_},@{$g{$_}}}@l)&&redo}}(sort{$d{$a}<=>$d{ +$b}}keys%d)[0] }
    It runs in O(n^2).
                   s aamecha.s a..a\u$&owag.print
Re: (Golf) Minimizing the Bacon Number
by no_slogan (Deacon) on May 15, 2001 at 06:07 UTC
    Down to 97 characters. Works for arbitrary graphs, i think.
    sub b { $a=@_*@_;for(@_){%t=@_;$t=@r=$_;$t+=%t while@r=map@{delete$t{$_}},@r;$ +a=$t,$b=$_ if!ref&&$t<$a}$b }

    Update: Thanks to MeowChow for crawling through that thoroughly fetid blob of code and discovering that I need to say $t+=keys%t instead of $t+=%t. And here I thought I was being so clever.

      Interestingly, this causes both my 5.6 Win32 ActiveState Perl and my 5.6.1 Linux to segfault, but appears to work under 5.00503. Hmmm....

      update: I think this is a garbage-collection issue, stemming from your deletion of a hash key will simultaneously dereferencing it. Ingenious, and dangerous.

      update2: Err, that wasn't the problem, the problem was that my test hash was already %t, so it was getting reset inside the sub, and I ran into this.

                     s aamecha.s a..a\u$&owag.print
Re: (Golf) Minimizing the Bacon Number
by MeowChow (Vicar) on May 14, 2001 at 23:08 UTC
    Damn you and your NP-complete problems! =) Well, I'm lazy, and decided to implement a greedy, suboptimal heuristic:
    sub bacon { my%t=@_;(sort{@{$t{$b}}<=>@{$t{$a}}}keys%t)[0] }
    At least it's fast, if not correct. :)
                   s aamecha.s a..a\u$&owag.print
      This problem shouldn't be NP-complete. A well-rounded algorithm is going to be, I believe, O(N^2) or O(N^3). However, the golf solution will probably be NP.
      Dr. Michael K. Neylon - || "You've left the lens cap of your mind on again, Pinky" - The Brain
        Sorry to ask but my curiosity is too big...
        What is NP (or NP-complete) ?

        BobiOne KenoBi ;)

Re: (Golf) Minimizing the Bacon Number
by larsen (Parson) on May 15, 2001 at 13:08 UTC
    The obvious link for those who are interested in the source of these Bacon Numbers: Erdös numbers.

    BTW, if mathematicians measure theis distance from number from Erdös, and musicians from Elvis, who can be used by Perl Programmers as 0?

Log In?

What's my password?
Create A New User
Domain Nodelet?
Node Status?
node history
Node Type: perlmeditation [id://80272]
Approved by root
and the web crawler heard nothing...

How do I use this?Last hourOther CB clients
Other Users?
Others imbibing at the Monastery: (4)
As of 2023-12-01 13:09 GMT
Find Nodes?
    Voting Booth?

    No recent polls found