Skip to content

Commit 02e20a5

Browse files
leynierleynier
committed
Merge branch 'leynier' into main
2 parents dc46f5c + d9e4b64 commit 02e20a5

File tree

2 files changed

+95
-38
lines changed

2 files changed

+95
-38
lines changed

‎src/Algorithms.hs‎

Lines changed: 84 additions & 37 deletions
Original file line numberDiff line numberDiff line change
@@ -5,6 +5,7 @@ module Algorithms
55
, solveAll
66
, generateGame
77
, generateRandom
8+
, validateTemplate
89
) where
910

1011
import System.Random
@@ -14,12 +15,14 @@ import qualified Data.Set as Set
1415
import Debug.Trace
1516
import Data.Map (Map)
1617
import qualified Data.Map as Map
18+
import System.Timeout
19+
import Data.Maybe
1720

1821
genRCell :: Int -> Int -> Int -> IO Cell
1922
genRCell rn cn val = do
20-
r <- randomRIO (1, rn)
21-
c <- randomRIO (1, cn)
22-
return (Cell r c val)
23+
r <- randomRIO (1, rn)
24+
c <- randomRIO (1, cn)
25+
return $ Cell r c val
2326

2427
genRCellFromSet :: Set Cell -> IO [Cell]
2528
genRCellFromSet set = if Set.null set
@@ -35,14 +38,19 @@ genRCellFromSet set = if Set.null set
3538

3639
generateRandom :: Int -> Int -> Float -> IO Matrix
3740
generateRandom rn cn ratio = do
38-
let obs_ratio = if ratio < 0 || ratio > 1 then 0.33 else ratio
39-
let cant_obs = floor $ fromIntegral rn * fromIntegral cn * obs_ratio
40-
let (Matrix _ _ cells) = darkMatrix rn cn
41-
randomCells <- genRCellFromSet cells
42-
let matrix = blankMatrix rn cn
43-
let obs_matrix = foldl editMatrixCell matrix (take cant_obs randomCells)
44-
first_cell <- genRCell rn cn 1
45-
return $ editMatrixCell obs_matrix first_cell
41+
let obs_ratio = if ratio < 0 || ratio > 1 then 0.33 else ratio
42+
let cant_obs = floor $ fromIntegral rn * fromIntegral cn * obs_ratio
43+
let (Matrix _ _ cells) = darkMatrix rn cn
44+
randomCells <- genRCellFromSet cells
45+
let matrix = blankMatrix rn cn
46+
let obs_matrix = foldl editMatrixCell matrix (take cant_obs randomCells)
47+
first_cell <- genRCell rn cn 1
48+
let newMatrix = editMatrixCell obs_matrix first_cell
49+
if validateTemplate newMatrix then do
50+
return newMatrix
51+
else do
52+
result <- generateRandom rn cn ratio
53+
return result
4654

4755
data Dificulty = Easy | Normal | Hard deriving (Ord, Eq, Show, Read)
4856

@@ -51,44 +59,83 @@ emptyRatio Easy = 50/100
5159
emptyRatio Normal = 60/100
5260
emptyRatio Hard = 70/100
5361

62+
generateRandomGame :: Int -> Int -> Float -> IO Matrix
63+
generateRandomGame rn cn ratio = do
64+
maybeTemplate <- timeout 1000000 $ generateRandom rn cn ratio
65+
if isNothing maybeTemplate then do
66+
game <- generateRandomGame rn cn ratio
67+
return game
68+
else do
69+
let template = maybe (blankMatrix rn cn) (\x -> x) maybeTemplate
70+
seed <- randomIO :: IO Int
71+
let gen = mkStdGen seed
72+
let seeds = randoms gen :: [Int]
73+
let solutions = solveAll template seeds
74+
if null solutions then do
75+
game <- generateRandomGame rn cn ratio
76+
return game
77+
else do
78+
return $ head solutions
79+
80+
removeCells :: Matrix -> [Cell] -> Int -> Int -> [Int] -> Matrix
81+
removeCells sol@(Matrix rn cn cs) cells ite n seeds =
82+
if null cells || ite >= n then
83+
sol
84+
else
85+
let (headCell: tailCells) = cells
86+
rowCell = row headCell
87+
colCell = column headCell
88+
empty = Cell rowCell colCell 0
89+
matrix = editMatrixCell sol empty
90+
solutions = solveAll matrix seeds
91+
isUnix = length (take 2 solutions) < 2
92+
in if isUnix then
93+
removeCells matrix tailCells (ite + 1) n seeds
94+
else
95+
removeCells sol tailCells (ite + 1) n seeds
96+
5497
generateGame :: Int -> Int -> Float -> Dificulty -> IO Matrix
5598
generateGame rn cn ratio dif = do
56-
template <- generateRandom rn cn ratio
57-
seed <- randomIO :: IO Int
58-
let gen = mkStdGen seed
59-
let seeds = randoms gen :: [Int]
60-
let solution = solve template seeds
61-
let setForRemove = Set.filter (\x -> let v = value x in v > 1 && v < rn * cn) (matrix solution) :: Set Cell
62-
randomCells <- genRCellFromSet setForRemove
63-
let total = Set.size setForRemove
64-
let cant_empty = floor $ fromIntegral total * emptyRatio dif
65-
let game = foldl editMatrixCell solution ([Cell r c 0 | x <- take cant_empty randomCells, let r = row x, let c = column x])
66-
return game
99+
maybeMatrix <- timeout 60000000 $ generateRandomGame rn cn ratio
100+
if isNothing maybeMatrix then do
101+
return $ error "Game not found"
102+
else do
103+
let solution = maybe (blankMatrix rn cn) (\x -> x) maybeMatrix
104+
let setForRemove = Set.filter (\x -> let v = value x in v > 1 && v < rn * cn) (matrix solution) :: Set Cell
105+
randomCells <- genRCellFromSet setForRemove
106+
let total = Set.size setForRemove
107+
let cant_empty = floor $ fromIntegral total * emptyRatio dif
108+
seed <- randomIO :: IO Int
109+
let gen = mkStdGen seed
110+
let seeds = randoms gen :: [Int]
111+
let game = removeCells solution randomCells 0 cant_empty seeds
112+
return game
67113

68114
generate :: Matrix
69115
generate = read "{. x x x x x x x x \n . 8 x x x x x x x \n . . 11 x x x x x x \n 29 . 10 . x x x x x \n 30 . . . . x x x x \n . 31 1 38 . . x x x \n . 32 . . 39 41 . x x \n . . . 22 . . 42 . x \n . . . . . . . 44 45}" :: Matrix
70116

71117
stepMatrix :: Int -> Matrix -> Cell -> Map Int Cell -> [Int] -> [(Matrix, Cell)]
72118
stepMatrix step m@(Matrix rs cs ma) prevCell map seeds = if Map.notMember step map
73-
then [
74-
newMatrix | cell <- getAdjacents prevCell rs cs step seeds,
75-
let actCell = Set.elemAt (Set.findIndex cell ma) ma,
76-
value actCell == 0,
77-
let newMatrix = (Matrix rs cs (Set.insert cell ma), cell)
78-
]
79-
else let actCell = map Map.! step
80-
in [newMatrix | isAdjacent actCell prevCell || value actCell == 1, let newMatrix = (m, actCell)]
119+
then [
120+
newMatrix | cell <- getAdjacents prevCell rs cs step seeds,
121+
let actCell = Set.elemAt (Set.findIndex cell ma) ma,
122+
value actCell == 0,
123+
let newMatrix = (Matrix rs cs (Set.insert cell ma), cell)
124+
]
125+
else let actCell = map Map.! step
126+
in [newMatrix | isAdjacent actCell prevCell || value actCell == 1, let newMatrix = (m, actCell)]
81127

82128
buildMap :: Matrix -> Map Int Cell
83129
buildMap ma@(Matrix r c m) = Set.foldl (\acc cell -> Map.insert (value cell) cell acc) Map.empty m
84130

85-
-- solveRecursiveBFS :: [(Matrix, Int)] -> [Matrix]
86-
-- solveRecursiveBFS [] = []
87-
-- solveRecursiveBFS ((actualMatrix, step):queue)
88-
-- | isFinalMatrix actualMatrix = actualMatrix:solveRecursiveBFS queue
89-
-- | otherwise = let toAdd = [ (matrix, step + 1)
90-
-- | matrix <- stepMatrix step actualMatrix]
91-
-- in solveRecursiveBFS (queue ++ toAdd)
131+
validateTemplate :: Matrix -> Bool
132+
validateTemplate (Matrix rn cn cells)
133+
| sum [ 1 | degree <- degrees, degree == 0 ] > 0 = False
134+
| sum [ 1 | degree <- degrees, degree == 1 ] > 2 = False
135+
| otherwise = True
136+
where degrees = [ length adjacents | cell <- Set.toList cells, value cell >= 0,
137+
let adjacents = [ adjR | adj <- getAdjacents cell rn cn 0 [1..],
138+
let Just adjR = Set.lookupGE adj cells, adjR /= cell, value adjR == 0]]
92139

93140
solveRecursiveDFS :: Matrix -> Int -> Cell -> Int -> Map Int Cell -> [Int] -> [Matrix]
94141
solveRecursiveDFS actualMatrix step prevCell obs map seeds

‎src/Structures.hs‎

Lines changed: 11 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -58,7 +58,17 @@ instance Read Cell where
5858
opar == '(' && comma1 == comma2 && comma2 == ',' && cpar == ')']
5959

6060
getAdjacents :: Cell -> Int -> Int -> Int -> [Int] -> [Cell]
61-
getAdjacents (Cell r c v) rs cs s seeds = [Cell nr nc s | dr <- genShuffle seeds [-1, 0, 1], dc <- genShuffle seeds [-1, 0, 1], let (nr, nc) = (r + dr, c + dc), nr > 0, nr <= rs, nc > 0, nc <= cs]
61+
getAdjacents (Cell r c v) rs cs s seeds = [
62+
Cell nr nc s |
63+
dr <- genShuffle seeds [-1, 0, 1],
64+
dc <- genShuffle seeds [-1, 0, 1],
65+
let (nr, nc) = (r + dr, c + dc),
66+
nr > 0,
67+
nr <= rs,
68+
nc > 0,
69+
nc <= cs,
70+
not $ dr == 0 && dc == 0
71+
]
6272

6373
fisherYatesStep :: RandomGen g => (Map Int Int, g) -> (Int, Int) -> (Map Int Int, g)
6474
fisherYatesStep (m, gen) (i, x) = ((Map.insert j x . Map.insert i (m Map.! j)) m, gen')

0 commit comments

Comments
 (0)