Beefy Boxes and Bandwidth Generously Provided by pair Networks
No such thing as a small change
 
PerlMonks  

How many triangles does your perl script "see"?

by Skeeve (Parson)
on Oct 27, 2005 at 15:02 UTC ( [id://503366]=perlquestion: print w/replies, xml ) Need Help??

Skeeve has asked for the wisdom of the Perl Monks concerning the following question:

You know these puzzles!? There is a drawing and you have to find out how many triangles one can see.

But that's boring. More interesting is it to write a perl script that will solve it for you.

I once did so and will post my solution as a reply to this.

Let's see your scripts. Solve the puzzle given at the page linked above. Should it not be there anymore, here is an ASCII-"Drawing" of it.

(A) /\ / /\ \ / / \ \ / / \ \ / / \ \ / (C)/ \(D) \ (B)/_______/__________\_______\(E) | \__ / \ __/ | | (F)X__ __X(G) | | / \___ ___/ \ | | / ___><___ \ | | / __/ (H) \__ \ | | / __/ \__ \ | |/_/____________________\_\| (I) (J)

The letters given in my "Drawing" are those I used in my script to mark the nodes.


s$$([},&%#}/&/]+}%&{})*;#$&&s&&$^X.($'^"%]=\&(|?*{%
+.+=%;.#_}\&"^"-+%*).}%:##%}={~=~:.")&e&&s""`$''`"e

Replies are listed 'Best First'.
Re: How many triangles does your perl script "see"?
by Perl Mouse (Chaplain) on Oct 27, 2005 at 16:24 UTC
    Here's my solution, finding 35 triangles.
    #!/usr/bin/perl use strict; use warnings; # # Input, lines of the figure. # my @l = ( [qw [A B]], [qw [A C F I]], [qw [A D G J]], [qw [A E]], [qw [B C D E]], [qw [B F H J]], [qw [B I]], [qw [E G H I]], [qw [E J]], [qw [I J]], ); # Process the lines. Create a datastructure with nodes as keys. # For each node, record which nodes are reachable in one step, # and which nodes are passed to get there. my $g; foreach my $l (@l) { for (my $i1 = 0; $i1 < @$l-1; $i1++) { for (my $i2 = $i1+1; $i2 < @$l; $i2++) { $$g{$$l[$i1]}{$$l[$i2]} = {map {$_, 1} @$l[$i1+1 .. $i2-1] +}; $$g{$$l[$i2]}{$$l[$i1]} = {map {$_, 1} @$l[$i1+1 .. $i2-1] +}; } } } # Find all non-trivial 3-cycles. local $" = " - "; my @n = sort keys %$g; for (my $i1 = 0; $i1 < @n-2; $i1++) { for (my $i2 = $i1+1; $i2 < @n-1; $i2++) { for (my $i3 = $i2+1; $i3 < @n; $i3++) { # Form a cycle print "@n[$i1,$i2,$i3]\n" if $$g{$n[$i1]}{$n[$i2]} && $$g{$n[$i2]}{$n[$i3]} && $$g{$n[$i3]}{$n[$i1]} && # Avoid trivial cycle !$$g{$n[$i1]}{$n[$i2]}{$n[$i3] +} && !$$g{$n[$i1]}{$n[$i3]}{$n[$i2] +} && !$$g{$n[$i2]}{$n[$i3]}{$n[$i1] +}; } } } __END__ A - B - C A - B - D A - B - E A - B - F A - B - I A - B - J A - C - D A - C - E A - D - E A - E - G A - E - I A - E - J A - F - J A - G - I A - I - J B - C - F B - C - I B - D - J B - E - H B - E - I B - E - J B - F - I B - H - I B - I - J C - E - I D - E - G D - E - J E - G - J E - H - J E - I - J F - H - I F - I - J G - H - J G - I - J H - I - J
    Perl --((8:>*
      Wow that's wordy. Here's a shorter version; I borrowed (i.e. "ripped off") your initial configuration array:
      #!/usr/bin/perl use strict; use warnings; # Input, lines of the figure. my @l = ( [qw [A B]], [qw [A C F I]], [qw [A D G J]], [qw [A E]], [qw [B C D E]], [qw [B F H J]], [qw [B I]], [qw [E G H I]], [qw [E J]], [qw [I J]], ); my %line = (); my %flat = (); for my $l (@l) { for my $p (@$l) { for my $q (@$l) { $line{$p,$q}=1; for my $r (@$l) {$flat{$p,$q,$r}=1} } } } my @p = 'A'..'J'; for my $p (@p) { for my $q (@p) { if ($q gt $p and $line{$p,$q}) { print "[$p,$q,$_]\n" for grep {$_ gt $q and $line{$p,$_} and $line{$q,$_} and not $flat{$p,$q,$_}} @p; } } }

      None of that double-$, three-level-deep hashref stuff.

      --
      @/=map{[/./g]}qw/.h_nJ Xapou cets krht ele_ r_ra/; map{y/X_/\n /;print}map{pop@$_}@/for@/
        None of that double-$, three-level-deep hashref stuff.
        True, your solution doesn't use Perl5 style nested hashes. Instead, your code used Perl4 style nested hashes - which aren't really nested and depend on a global variable instead.

        I've put Perl4 behind me. A long, long time ago.

        Perl --((8:>*
      I don't understand it (yet) but I really like it!

      s$$([},&%#}/&/]+}%&{})*;#$&&s&&$^X.($'^"%]=\&(|?*{%
      +.+=%;.#_}\&"^"-+%*).}%:##%}={~=~:.")&e&&s""`$''`"e
Re: How many triangles does your perl script "see"?
by jdalbec (Deacon) on Oct 28, 2005 at 01:02 UTC
    my @lines = ("AB","ACFI","ADGJ","AE","BCDE","BFHJ","BI","EGHI","EJ","I +J"); foreach my $i ("A".."H") { foreach my $j (++(my $ii = $i) .. "I") { foreach my $k (++(my $jj = $j) .. "J") { print "$i$j$k\n" if 3 == grep {/$i.*$j|$i.*$k| +$j.*$k/} @lines; } } }
      *WOW* The shortest solution! Clean, simple and really cool!

      s$$([},&%#}/&/]+}%&{})*;#$&&s&&$^X.($'^"%]=\&(|?*{%
      +.+=%;.#_}\&"^"-+%*).}%:##%}={~=~:.")&e&&s""`$''`"e
Re: How many triangles does your perl script "see"?
by !1 (Hermit) on Oct 28, 2005 at 05:14 UTC

    How about a regex?

    #!/usr/bin/perl -l "AB~ACFI~ADGJ~AE~BCDE~BFHJ~BI~EGHI~EJ~IJ" =~ /([^~])[^~]*([^~]).*~[^~] +*([^~])[^~]*([^~])(?{local$z=$1 and local$y=$2 and local$x=$1 eq$3?$4 +:$1 eq$4?$3:($z=$2)&&($y=$1)&&$2 eq$3?$4:$2 eq$4?$3:0}).*~[^~]*((??{$ +y})[^~]*(??{$x})|(??{$x})[^~]*(??{$y}))(?{$x{join" - ",sort$x,$y,$z}+ ++})(?!)/; print for sort(keys %x), keys(%x) . " triangles found";

    Sure it's overkill but it was fun =P

    Only tested on perl 5.8.7 on windows and freebsd.

      ++!!!
      Ever considered taking part in a perl golf contest?

      s$$([},&%#}/&/]+}%&{})*;#$&&s&&$^X.($'^"%]=\&(|?*{%
      +.+=%;.#_}\&"^"-+%*).}%:##%}={~=~:.")&e&&s""`$''`"e
Re: How many triangles does your perl script "see"?
by Skeeve (Parson) on Oct 27, 2005 at 15:08 UTC
    So here is my solution. In order not to spoil the puzzle, I've put a readmore around it.

    s$$([},&%#}/&/]+}%&{})*;#$&&s&&$^X.($'^"%]=\&(|?*{%
    +.+=%;.#_}\&"^"-+%*).}%:##%}={~=~:.")&e&&s""`$''`"e
Re: How many triangles does your perl script "see"?
by diotalevi (Canon) on Oct 27, 2005 at 15:38 UTC

    35 triangles found when I quit ignoring some lines in a misguided optimization. Thanks again to Perl Mouse for posting something which showed that I was missing some results.

    27 triangles found when I accounted for lines that don't actually exist. This corrects the problem that Perl Mouse found.

    46 triangles found when I stopped to remove lines. Again, this takes no time worth reporting.

    $" = ''; $\ = "\n"; chomp( my @edges = map /--/ ? join( '', sort /\w/g ) : (), <DATA> ); my @nodes = sort { $a cmp $b } uniq( map /\w/g, @edges ); for $node ( @nodes ) { my $edge_rx = qr/$node/; my @other_nodes = map /$edge_rx/ ? grep( $_ ge $node, split( //, $_ ) ) : (), @edges; my $last_step = qr/(.).*(.)(?{print "$node -- $1 -- $2"})(?!)/; my $node_rx = qr/$node/; my $third_edge_rx = qr/[@other_nodes].*[@other_nodes]/; grep $_ ge $node && ! /$node_rx/ && /$third_edge_rx/ && /$last_step/, @edges; } sub uniq { my %seen; grep !$seen{$_}++, @_ } __DATA__ graph triangles { A -- B A -- C -- F -- I A -- D -- G -- J A -- E B -- C -- D -- E B -- F -- H -- J B -- I E -- G -- H -- I E -- J I -- J }

    51 triangles found, no runtime worth reporting. Except that drat, I didn't notice that some "triangles" are actually just line segments.

      If I run your program, it tells me that 'A - B - H' is a triangle - however, there's no line between A and H.
      Perl --((8:>*
Re: How many triangles does your perl script "see"?
by eric256 (Parson) on Oct 27, 2005 at 22:43 UTC

    Fun puzzle. Here is my kind of hybrid answer. 4 nested loops + some regex to weed out straight lines.

    use strict; use warnings; my $data = { A => [qw/B C D E F I G J/], B => [qw/A C D E F H J I/], C => [qw/A B F I D E/], D => [qw/A C B G J E/], E => [qw/A D C B G H I J/], F => [qw/A C B I H J/], G => [qw/D A E H I J/], H => [qw/F B I J G E/], I => [qw/B F C A H G E J/], J => [qw/A B F H I E/], }; my $line = qr/[ACFI]{3}|[ADGJ]{3}|[BCDE]{3}|[BFHJ]{3}|[EGHI]{3}/; my $triangles = {}; for my $p1 (keys %$data) { for my $p2 (@{$data->{$p1}}) { for my $p3 (@{$data->{$p2}}) { next if $p3 eq $p1; for my $p4 (@{$data->{$p3}}) { if ($p4 eq $p1) { my $tri = join( "", sort @{[$p1,$p2, $p3]}); $triangles->{$tri}++ unless $tri =~ $line; } } } } } print $_,"\n" for sort keys %$triangles; print 0+keys %$triangles;


    ___________
    Eric Hodges $_='y==QAe=e?y==QG@>@?iy==QVq?f?=a@iG?=QQ=Q?9'; s/(.)/ord($1)-50/eigs;tr/6123457/- \/|\\\_\n/;print;
Re: How many triangles does your perl script "see"?
by Thelonius (Priest) on Oct 28, 2005 at 00:25 UTC
    #!perl -w use strict; sub choose { my ($str, $n) = @_; my @result; choose1(\@result, "", $str, $n, 0); return @result; } sub choose1 { my ($parray, $this, $str, $n, $x) = @_; if ($n == 0) { push @{$parray}, $this; return; } return if $x + $n > length($str); choose1($parray, $this . substr($str, $x, 1), $str, $n - 1, $x+1); choose1($parray, $this, $str, $n, $x+1); } my %edges; my %nodes; my %collinear; for (qw(ab acfi adgj ae bcde bfhj bi ej eghi ij)) { $nodes{$_} = 1 for choose($_, 1); $edges{$_} = 1 for choose($_, 2); $collinear{$_} = 1 for choose($_, 3); } my $allnodes = join "", sort keys %nodes; for my $triple (grep {!$collinear{$_}} choose($allnodes, 3)) { print "$triple\n" if 3 == grep { $edges{$_} } choose($triple, 2); }
Re: How many triangles does your perl script "see"?
by tye (Sage) on Oct 27, 2005 at 20:05 UTC
Re: How many triangles does your perl script "see"?
by Perl Mouse (Chaplain) on Oct 27, 2005 at 15:20 UTC
    What's the puzzle? Is the puzzle to scan the image can reconstruct the graph - and once you've done so, count the triangles? Or can you just give the edges and vertices to the program as input? In the latter case, the puzzle becomes really simple, as any non-trivial 3-cycle will be a triangle. (JH - HF - FJ is a trivial cycle, but JB - BI - IJ isn't).
    Perl --((8:>*

      Actually the latter case can not be logically resolved, as the number of triangles not only depends on the linkage, but also the geo-location of each point (things like what if three points are located on one straight line etc.)

      In the latter case, the question needs to be changed to something like "what is the maximum number of triangles can be formed" or something similar.

        Actually the latter case can not be logically resolved, as the number of triangles not only depends on the linkage, but also the geo-location of each point (things like what if three points are located on one straight line etc.)
        That's what I wrote, wasn't it? Three co-linear points form a trivial 3-cycle. And we want to avoid those.
        Perl --((8:>*

      Don't scan. Just put in whatever you think is needed by you program (except for the solution of course).

      When I wrote my script I gave it much information like: Which nodes are linked with which other nodes, which nodes are on one line and so on.


      s$$([},&%#}/&/]+}%&{})*;#$&&s&&$^X.($'^"%]=\&(|?*{%
      +.+=%;.#_}\&"^"-+%*).}%:##%}={~=~:.")&e&&s""`$''`"e
Re: How many triangles does your perl script "see"?
by kwaping (Priest) on Oct 27, 2005 at 19:42 UTC
    I think this'd be better in CUFP. :)

Log In?
Username:
Password:

What's my password?
Create A New User
Domain Nodelet?
Node Status?
node history
Node Type: perlquestion [id://503366]
Approved by virtualsue
Front-paged by tye
help
Chatterbox?
and the web crawler heard nothing...

How do I use this?Last hourOther CB clients
Other Users?
Others having a coffee break in the Monastery: (4)
As of 2024-03-29 06:37 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    No recent polls found