Skip to content

Commit d9e4b64

Browse files
leynierleynier
committed
Implement unix checking
1 parent 8617920 commit d9e4b64

File tree

2 files changed

+88
-41
lines changed

2 files changed

+88
-41
lines changed

‎src/Algorithms.hs‎

Lines changed: 77 additions & 40 deletions
Original file line numberDiff line numberDiff line change
@@ -15,12 +15,14 @@ import qualified Data.Set as Set
1515
import Debug.Trace
1616
import Data.Map (Map)
1717
import qualified Data.Map as Map
18+
import System.Timeout
19+
import Data.Maybe
1820

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

2527
genRCellFromSet :: Set Cell -> IO [Cell]
2628
genRCellFromSet set = if Set.null set
@@ -36,14 +38,19 @@ genRCellFromSet set = if Set.null set
3638

3739
generateRandom :: Int -> Int -> Float -> IO Matrix
3840
generateRandom rn cn ratio = do
39-
let obs_ratio = if ratio < 0 || ratio > 1 then 0.33 else ratio
40-
let cant_obs = floor $ fromIntegral rn * fromIntegral cn * obs_ratio
41-
let (Matrix _ _ cells) = darkMatrix rn cn
42-
randomCells <- genRCellFromSet cells
43-
let matrix = blankMatrix rn cn
44-
let obs_matrix = foldl editMatrixCell matrix (take cant_obs randomCells)
45-
first_cell <- genRCell rn cn 1
46-
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
4754

4855
data Dificulty = Easy | Normal | Hard deriving (Ord, Eq, Show, Read)
4956

@@ -52,33 +59,71 @@ emptyRatio Easy = 50/100
5259
emptyRatio Normal = 60/100
5360
emptyRatio Hard = 70/100
5461

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+
5597
generateGame :: Int -> Int -> Float -> Dificulty -> IO Matrix
5698
generateGame rn cn ratio dif = do
57-
template <- generateRandom rn cn ratio
58-
seed <- randomIO :: IO Int
59-
let gen = mkStdGen seed
60-
let seeds = randoms gen :: [Int]
61-
let solution = solve template seeds
62-
let setForRemove = Set.filter (\x -> let v = value x in v > 1 && v < rn * cn) (matrix solution) :: Set Cell
63-
randomCells <- genRCellFromSet setForRemove
64-
let total = Set.size setForRemove
65-
let cant_empty = floor $ fromIntegral total * emptyRatio dif
66-
let game = foldl editMatrixCell solution ([Cell r c 0 | x <- take cant_empty randomCells, let r = row x, let c = column x])
67-
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
68113

69114
generate :: Matrix
70115
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
71116

72117
stepMatrix :: Int -> Matrix -> Cell -> Map Int Cell -> [Int] -> [(Matrix, Cell)]
73118
stepMatrix step m@(Matrix rs cs ma) prevCell map seeds = if Map.notMember step map
74-
then [
75-
newMatrix | cell <- getAdjacents prevCell rs cs step seeds,
76-
let actCell = Set.elemAt (Set.findIndex cell ma) ma,
77-
value actCell == 0,
78-
let newMatrix = (Matrix rs cs (Set.insert cell ma), cell)
79-
]
80-
else let actCell = map Map.! step
81-
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)]
82127

83128
buildMap :: Matrix -> Map Int Cell
84129
buildMap ma@(Matrix r c m) = Set.foldl (\acc cell -> Map.insert (value cell) cell acc) Map.empty m
@@ -89,16 +134,8 @@ validateTemplate (Matrix rn cn cells)
89134
| sum [ 1 | degree <- degrees, degree == 1 ] > 2 = False
90135
| otherwise = True
91136
where degrees = [ length adjacents | cell <- Set.toList cells, value cell >= 0,
92-
let adjacents = [ adjR | adj <- getAdjacents cell rn cn 0 [1..], let Just adjR = Set.lookupGE adj cells, adjR /= cell,value adjR > (-1)]]
93-
94-
95-
-- solveRecursiveBFS :: [(Matrix, Int)] -> [Matrix]
96-
-- solveRecursiveBFS [] = []
97-
-- solveRecursiveBFS ((actualMatrix, step):queue)
98-
-- | isFinalMatrix actualMatrix = actualMatrix:solveRecursiveBFS queue
99-
-- | otherwise = let toAdd = [ (matrix, step + 1)
100-
-- | matrix <- stepMatrix step actualMatrix]
101-
-- in solveRecursiveBFS (queue ++ toAdd)
137+
let adjacents = [ adjR | adj <- getAdjacents cell rn cn 0 [1..],
138+
let Just adjR = Set.lookupGE adj cells, adjR /= cell, value adjR == 0]]
102139

103140
solveRecursiveDFS :: Matrix -> Int -> Cell -> Int -> Map Int Cell -> [Int] -> [Matrix]
104141
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)