Skip to content

Commit 04b8990

Browse files
herrmannoherrmanno
committed
Fix a severe bug in 'hamilton' solver
Fixes #16 Fixes #17
1 parent 8bb405d commit 04b8990

File tree

5 files changed

+161
-23
lines changed

5 files changed

+161
-23
lines changed

‎examples/hamilton2.txt

+42
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,42 @@
1+
HamiltonDescription {
2+
graph = Graph
3+
{ knoten = mkSet
4+
[ 1
5+
, 2
6+
, 3
7+
, 4
8+
, 5
9+
, 6
10+
, 7
11+
, 8
12+
, 9
13+
, 10
14+
, 11
15+
, 12
16+
]
17+
, kanten = mkSet
18+
[ kante 1 2
19+
, kante 1 4
20+
, kante 1 6
21+
, kante 1 8
22+
, kante 1 10
23+
, kante 2 3
24+
, kante 2 5
25+
, kante 2 7
26+
, kante 2 8
27+
, kante 2 9
28+
, kante 3 6
29+
, kante 3 11
30+
, kante 3 12
31+
, kante 4 10
32+
, kante 5 7
33+
, kante 5 8
34+
, kante 5 9
35+
, kante 5 12
36+
, kante 6 9
37+
, kante 7 11
38+
, kante 8 11
39+
, kante 10 12
40+
]
41+
}
42+
}

‎examples/hamilton3.txt

+43
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,43 @@
1+
HamiltonDescription {
2+
graph = Graph
3+
{ knoten = mkSet
4+
[ 1
5+
, 2
6+
, 3
7+
, 4
8+
, 5
9+
, 6
10+
, 7
11+
, 8
12+
, 9
13+
, 10
14+
, 11
15+
, 12
16+
]
17+
, kanten = mkSet
18+
[ kante 1 4
19+
, kante 1 6
20+
, kante 1 8
21+
, kante 1 10
22+
, kante 1 12
23+
, kante 2 4
24+
, kante 2 7
25+
, kante 2 9
26+
, kante 2 10
27+
, kante 2 12
28+
, kante 3 4
29+
, kante 3 7
30+
, kante 3 10
31+
, kante 4 8
32+
, kante 5 6
33+
, kante 5 9
34+
, kante 5 12
35+
, kante 6 8
36+
, kante 6 9
37+
, kante 6 11
38+
, kante 7 10
39+
, kante 8 11
40+
, kante 9 11
41+
]
42+
}
43+
}

‎src/Autotool/Data/Graph.hs

+9-1
Original file line numberDiff line numberDiff line change
@@ -11,6 +11,8 @@ module Autotool.Data.Graph
1111
, vertices
1212
, edges
1313
, insertEdge
14+
, containsEdge
15+
, deleteVertex
1416
, similiar
1517
, neighbours
1618
, disconnectedSubgraphs
@@ -73,6 +75,12 @@ edges (_,es) = es
7375
insertEdge :: (Ord a) => Graph a -> (a,a) -> Graph a
7476
insertEdge (vs,es) e = (vs, S.insert e es)
7577

78+
-- | Removes a vertex and alle edges from / to it
79+
-- >>> deleteVertex (S.fromList [1,2,3], S.fromList [(1,2), (2,3), (3,1)]) 2
80+
-- (fromList [1,3],fromList [(3,1)])
81+
deleteVertex :: (Ord a) => Graph a -> a -> Graph a
82+
deleteVertex (vs,es) e = (S.delete e vs, S.filter (\(a,b) -> a /= e && b /= e) es)
83+
7684
-- | > containsEdge g (a,b) := (a,b) ∈ edges_G ∨ (b,a) ∈ edges_G
7785
containsEdge :: (Eq a) => Graph a -> (a,a) -> Bool
7886
containsEdge (_,es) (a,b) = (a,b) `elem` es || (b,a) `elem` es
@@ -241,4 +249,4 @@ breaksConstraint (Not c) g = satisfiesConstraint c g
241249

242250
-- Colors
243251

244-
data Color = A | B | C | D | E | F deriving (Eq, Ord, Enum, Show)
252+
data Color = A | B | C | D | E | F deriving (Eq, Ord, Enum, Show)

‎src/Autotool/Solver/Hamilton.hs

+13-19
Original file line numberDiff line numberDiff line change
@@ -1,31 +1,25 @@
1-
module Autotool.Solver.Hamilton (solve) where
1+
module Autotool.Solver.Hamilton (solve, isHamiltonCircle) where
22

33
import Data.Set (delete, toList, member, size)
4+
import qualified Data.Set as S
45
import Control.Monad (guard)
5-
import Autotool.Data.Graph (Graph)
6+
import Autotool.Data.Graph (Graph, neighbours, containsEdge)
67

78
solve :: (Eq a, Ord a, Show a) => Graph a -> [a]
8-
solve g@(vs,_) = take (size vs) $ go g [] where
9+
solve g@(vs,alles) = take (size vs) $ go g [] where
910
go :: (Eq a, Ord a, Show a) => Graph a -> [a] -> [a]
1011
go g@(vs, es) p
1112
| null vs = p
13+
| null p = let v0 = S.findMin vs in go (rm g v0) [v0]
1214
| otherwise = do
13-
let vs' = toList vs
14-
v <- vs'
15+
let pn = head p
16+
v <- toList vs
1517
guard $ v `notElem` p
16-
guard $
17-
null p ||
18-
(size vs == 1 && let x = last p in (v,x) `member` es || (x,v) `member` es) ||
19-
(size vs > 1 && let x = head p in (v,x) `member` es || (x,v) `member` es)
20-
let vs' = delete v vs
21-
let g' = (vs', es)
22-
let p' = v:p
23-
go g' p'
24-
25-
-- hamilton :: (Eq a, Ord a, Show a) => Graph a -> [a]
26-
-- hamilton g@(vs, es) = let perms = permutations (toList vs) in head $ filter (isHamiltonCircle g) perms
18+
guard $ containsEdge g (v, pn)
19+
guard $ size vs > 1 || containsEdge g (v, last p)
20+
go (rm g v) (v:p)
21+
rm (vs,es) v = (S.delete v vs, es)
2722

2823
isHamiltonCircle :: (Ord a) => Graph a -> [a] -> Bool
29-
isHamiltonCircle (_, es) p = all f p' where
30-
p' = (head p, last p) : zip p (drop 1 p)
31-
f (a,b) = (a,b) `member` es || (b,a) `member` es
24+
isHamiltonCircle g@(_, es) p = all (containsEdge g) p' where
25+
p' = (head p, last p) : zip p (drop 1 p)

‎test/Autotool/Solver/HamiltonSpec.hs

+54-3
Original file line numberDiff line numberDiff line change
@@ -2,7 +2,7 @@ module Autotool.Solver.HamiltonSpec (spec) where
22

33
import Test.Hspec
44
import Autotool.Data.Graph (mkGraph, kante)
5-
import Autotool.Solver.Hamilton (solve)
5+
import Autotool.Solver.Hamilton (solve, isHamiltonCircle)
66

77
spec = do
88
describe "hamilton path" $ do
@@ -28,7 +28,7 @@ spec = do
2828
, kante 8 10
2929
, kante 9 10
3030
]
31-
in solve g `shouldBe` [7,9,10,8,2,5,6,3,4,1]
31+
in isHamiltonCircle g (solve g) `shouldBe` True
3232
it "finds a hamilton path in a graph (2)" $
3333
let g = mkGraph [1..12] [ kante 1 2
3434
, kante 1 5
@@ -56,5 +56,56 @@ spec = do
5656
, kante 10 12
5757
, kante 11 12
5858
]
59-
in solve g `shouldBe` [11,7,6,10,8,9,12,3,4,5,2,1]
59+
in isHamiltonCircle g (solve g) `shouldBe` True
60+
it "finds a hamilton path in a graph (3)" $
61+
let g = mkGraph [1..12] [ kante 1 2
62+
, kante 1 4
63+
, kante 1 6
64+
, kante 1 8
65+
, kante 1 10
66+
, kante 2 3
67+
, kante 2 5
68+
, kante 2 7
69+
, kante 2 8
70+
, kante 2 9
71+
, kante 3 6
72+
, kante 3 11
73+
, kante 3 12
74+
, kante 4 10
75+
, kante 5 7
76+
, kante 5 8
77+
, kante 5 9
78+
, kante 5 12
79+
, kante 6 9
80+
, kante 7 11
81+
, kante 8 11
82+
, kante 10 12
83+
]
84+
in isHamiltonCircle g (solve g) `shouldBe` True
85+
it "finds a hamilton path in a graph (4)" $
86+
let g = mkGraph [1..12] [ kante 1 4
87+
, kante 1 6
88+
, kante 1 8
89+
, kante 1 10
90+
, kante 1 12
91+
, kante 2 4
92+
, kante 2 7
93+
, kante 2 9
94+
, kante 2 10
95+
, kante 2 12
96+
, kante 3 4
97+
, kante 3 7
98+
, kante 3 10
99+
, kante 4 8
100+
, kante 5 6
101+
, kante 5 9
102+
, kante 5 12
103+
, kante 6 8
104+
, kante 6 9
105+
, kante 6 11
106+
, kante 7 10
107+
, kante 8 11
108+
, kante 9 11
109+
]
110+
in isHamiltonCircle g (solve g) `shouldBe` True
60111

0 commit comments

Comments
 (0)