I just had to generalize the 'challange' to arbitrary n-sided polygons.
We define such a polygon to consist of points x_0, ..., x_{n-1},
where two adjacent points x_i and x_{i+1} (resp. x0 and x_{n-1}) must be
on a line. The polygon is not degenerate if additionally no point is on
any such line besides its two adjacent ones.
The list comprehension is generalized by using the list monad, which
allows to perform an (iterated) arbitrary number of steps, each time
choosing new candidates. In each step, we know the list of points and
lines so far. We add a new line from the last point, and a new point
from this line, provided that neither the new point is on any line
seen so far, nor any of the known points (except the last) is on the
new line. Thus the polygon will not be degenerate.
Aequivalent polygons are found by rotating the list of points, or by
changing direction. To fix the first, choose the 'smallest' point as
given by the arbitrary order imposed by 'choices'. To fix the second,
pick the second and the last point after the first point, and make
sure the second point is 'smaller' than the last point.
Hence, we have to pick the three points x0, x1 and x_{n-1} (which is
called xn for simplicity below) in advance. To make the function
simpler, we just iterate the steps as often as necessary and then
check that the last new point is identical to x_{n-1}, so we don't
have to redo all the checks for it. Hence, we cannot include the line
ln between x0 and x_{n-1} in the lines to check, so we still have to
check this line at the end. To do this, we have to exclude x0 from the
number of points xs found so far (it's inconvenient to remove a point
from the end of the list). This means we have to add x0 during the
check in the step. So we end up with [x1] as the initial list of
points, and [l1] as the initial list of lines.
> import Data.List
> import Control.Monad
> polygons n blocks =
> let
> choice = init . tails
> join x y = filter (\l -> x `elem` l && y `elem` l) blocks
> in do
> x1:p <- choice $ nub $ concat blocks
> x0:q <- choice p
> x2:_ <- choice q
> l1 <- join x0 x1
> l2 <- join x1 x2
> let
> start = [([x2,x1,x0], [l2,l1])]
> step (xs@(x:_), ls) = do
> l <- filter (x `elem`) blocks
> y <- intersect l (p\\xs)
> return (y:xs, l:ls)
> (xs@(x:_), ls) <- iterate (>>= step) start !! (n-3)
> ln <- join x x0
> guard (all ((==2) . length . intersect xs) (ln:ls))
> return xs
There are several ways to make this faster, but it's fast enough
for toy examples as it is.
Examples of blocks to test with.
Frank's figure:
> blocks =
> [[0,1],[0,2,4,6],[1,2,3,5],[0,3,7,9],[1,4,7,8],[0,5,8,10],[1,6,9,10]]
A square with one diagonal:
0 -- 1
| \ |
| \ |
2 -- 3
> blocks2 = [[0,1],[0,2],[0,3],[1,3],[2,3]]
A square with two diagonals:
0 -- 1
| \/ |
| /\ |
2 -- 3
> blocks3 = [[0,1],[0,2],[0,3],[1,3],[2,3],[1,2]]
We get for example
Main> polygons 3 blocks2
[[0,3,1],[0,3,2]]
Main> polygons 4 blocks2
[[0,2,3,1]]
Main> polygons 3 blocks3
[[0,2,1],[0,3,1],[0,3,2],[1,3,2]]
Main> polygons 4 blocks3
[[0,2,3,1],[0,3,2,1],[0,3,1,2]]
Frank's figure only admits triangles, quadrangles and hexagons:
Main> map (\n -> length $ polygons n blocks) [3..10]
[27,27,0,6,0,0,0,0]
Main> polygons 3 blocks
[[0,2,1],[0,4,1],[0,6,1],[0,3,1],[0,5,1],[0,7,1],[0,9,1],[0,8,1],[0,10,1],
[0,3,2],[0,5,2],[0,7,4],[0,8,4],[0,9,6],[0,10,6],[0,5,3],[0,8,7],[0,10,9],
[1,4,2],[1,6,2],[1,6,4],[1,7,3],[1,9,3],[1,8,5],[1,10,5],[1,9,7],[1,10,8]]
Main> polygons 4 blocks
[[0,7,1,2],[0,9,1,2],[0,8,1,2],[0,10,1,2],[0,3,1,4],[0,5,1,4],[0,9,1,4],
[0,10,1,4],[0,3,1,6],[0,5,1,6],[0,7,1,6],[0,8,1,6],[0,8,1,3],[0,10,1,3],
[0,7,1,5],[0,9,1,5],[0,10,1,7],[0,8,1,9],[2,3,7,4],[2,5,8,4],[2,3,9,6],
[2,5,10,6],[4,7,9,6],[4,8,10,6],[3,7,8,5],[3,9,10,5],[7,8,10,9]]
Main> polygons 6 blocks
[[2,3,9,10,8,4],[2,5,10,9,7,4],[2,3,7,8,10,6],[2,5,8,7,9,6],[4,7,3,5,10,6],
[4,8,5,3,9,6]]
For triangles (n=3) the iteration is empty and so the function reduces to
> triangles blocks =
> let
> choice = init . tails
> join x y = filter (\l -> x `elem` l && y `elem` l) blocks
> in do
> x1:p <- choice $ nub $ concat blocks
> x0:q <- choice p
> x2:_ <- choice q
> l1 <- join x0 x1
> l2 <- join x1 x2
> ln <- join x2 x0
> guard (all ((==2) . length . intersect [x2,x1,x0]) [ln,l2,l1])
> return xs
which further shortens to
> triangles blocks = [(x,y,z) | x:p <-choice$nub$concat blocks, y:q <-choice p,
> l <-join x y, z:_ <-choice (q\\l), _ <-join y z, _ <-join z x] where
> choice = init . tails
> join x y = filter (\l -> x `elem` l && y `elem` l) blocks