XP is just a number PerlMonks

### How many triangles does your perl script "see"?

by Skeeve (Vicar)
 on Oct 27, 2005 at 15:02 UTC 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)
[download]```

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
[download]```
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;
}
}
}
[download]```

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@/
[download]```
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;
}
}
}
[download]```
*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";
[download]```

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 (Vicar) 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.

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;
[download]```

___________
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);
}
[download]```
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
Node Status?
node history
Node Type: perlquestion [id://503366]
Approved by virtualsue
Front-paged by tye
help
Chatterbox?
and the grasshoppers chirp...

How do I use this? | Other CB clients
Other Users?
Others romping around the Monastery: (14)
As of 2018-03-19 17:45 GMT
Sections?
Information?
Find Nodes?
Leftovers?
Voting Booth?
When I think of a mole I think of:

Results (245 votes). Check out past polls.

Notices?