Я нашел этот вопрос интригующим, и, поскольку я учу себя на Хаскеле, я решил попробовать свои силы в реализации решения на этом языке.
Я думал о ветвлении и связывании, но не смог придумать хороший способ связать решения, поэтому я просто немного обрезал, отбрасывая доски, которые нарушают правила.
Мой алгоритм работает, начиная с «пустой» доски. Он помещает каждый возможный цвет башни в первый пустой слот и в каждом случае (каждый цвет) затем рекурсивно вызывает себя. Повторяющиеся вызовы пробуют каждый цвет во втором слоте, повторяя снова, пока доска не заполнится.
Поскольку каждая башня установлена, я проверяю только что установленную башню и всех ее соседей, чтобы убедиться, что они подчиняются правилам, рассматривая любых пустых соседей как групповые символы. Поэтому, если у белой башни четыре пустых соседа, я считаю это действительным. Если место размещения является недействительным, я не отказываюсь от этого места размещения, фактически удаляя все дерево возможностей под ним.
Как написан код, я генерирую список всех возможных решений, затем просматриваю список, чтобы найти лучшее. На самом деле, благодаря ленивой оценке Haskell, элементы списка генерируются так, как они нужны функции поиска, и, поскольку они больше не используются, они сразу становятся доступными для сборки мусора, так что даже для платы 5x5 использование памяти довольно мало (2 МБ).
Производительность довольно хорошая. На моем ноутбуке с частотой 2,1 ГГц скомпилированная версия программы решает задачу 4x4 за ~ 50 секунд, используя одно ядро. Сейчас я запускаю пример 5х5, чтобы посмотреть, сколько времени это займет. Поскольку функциональный код довольно легко распараллелить, я также собираюсь экспериментировать с параллельной обработкой. Существует параллельный компилятор Haskell, который будет распределять работу не только по нескольким ядрам, но и по нескольким компьютерам, и это очень распараллеливаемая проблема.
Вот мой код. Я понимаю, что вы указали Java или PHP, и Haskell совершенно другой. Если вы хотите поиграть с ним, вы можете изменить определение переменной «bnd» чуть выше дна, чтобы установить размер доски. Просто установите его в ((1,1), (x, y)), где x и y - количество столбцов и строк соответственно.
import Array
import Data.List
-- Enumeration of Tower types. "Empty" isn't really a tower color,
-- but it allows boards to have empty cells
data Tower = Empty | Blue | Red | Green | Yellow | White
deriving(Eq, Ord, Enum, Show)
type Location = (Int, Int)
type Board = Array Location Tower
-- towerScore omputes the score of a single tower
towerScore :: Tower -> Int
towerScore White = 100
towerScore t = (fromEnum t) * 10
-- towerUpper computes the upper bound for a single tower
towerUpper :: Tower -> Int
towerUpper Empty = 100
towerUpper t = towerScore t
-- boardScore computes the score of a board
boardScore :: Board -> Int
boardScore b = sum [ towerScore (b!loc) | loc <- range (bounds b) ]
-- boardUpper computes the upper bound of the score of a board
boardUpper :: Board -> Int
boardUpper b = sum [ bestScore loc | loc <- range (bounds b) ]
where
bestScore l | tower == Empty =
towerScore (head [ t | t <- colors, canPlace b l t ])
| otherwise = towerScore tower
where
tower = b!l
colors = reverse (enumFromTo Empty White)
-- Compute the neighbor locations of the specified location
neighborLoc :: ((Int,Int),(Int,Int)) -> (Int,Int) -> [(Int,Int)]
neighborLoc bounds (col, row) = filter valid neighborLoc'
where
valid loc = inRange bounds loc
neighborLoc' = [(col-1,row),(col+1,row),(col,row-1),(col,row+1)]
-- Array to store all of the neighbors of each location, so we don't
-- have to recalculate them repeatedly.
neighborArr = array bnd [(loc, neighborLoc bnd loc) | loc <- range bnd]
-- Get the contents of neighboring cells
neighborTowers :: Board -> Location -> [Tower]
neighborTowers board loc = [ board!l | l <- (neighborArr!loc) ]
-- The tower placement rule. Yields a list of tower colors that must
-- be adjacent to a tower of the specified color.
requiredTowers :: Tower -> [Tower]
requiredTowers Empty = []
requiredTowers Blue = []
requiredTowers Red = [Blue]
requiredTowers Green = [Red, Blue]
requiredTowers Yellow = [Green, Red, Blue]
requiredTowers White = [Yellow, Green, Red, Blue]
-- cellValid determines if a cell satisfies the rule.
cellValid :: Board -> Location -> Bool
cellValid board loc = null required ||
null needed ||
(length needed <= length empties)
where
neighbors = neighborTowers board loc
required = requiredTowers (board!loc)
needed = required \\ neighbors
empties = filter (==Empty) neighbors
-- canPlace determines if 'tower' can be placed in 'cell' without
-- violating the rule.
canPlace :: Board -> Location -> Tower -> Bool
canPlace board loc tower =
let b' = board // [(loc,tower)]
in cellValid b' loc && and [ cellValid b' l | l <- neighborArr!loc ]
-- Generate a board full of empty cells
cleanBoard :: Array Location Tower
cleanBoard = listArray bnd (replicate 80 Empty)
-- The heart of the algorithm, this function takes a partial board
-- (and a list of empty locations, just to avoid having to search for
-- them) and a score and returns the best board obtainable by filling
-- in the partial board
solutions :: Board -> [Location] -> Int -> Board
solutions b empties best | null empties = b
solutions b empties best =
fst (foldl' f (cleanBoard, best) [ b // [(l,t)] | t <- colors, canPlace b l t ])
where
f :: (Board, Int) -> Board -> (Board, Int)
f (b1, best) b2 | boardUpper b2 <= best = (b1, best)
| otherwise = if newScore > lstScore
then (new, max newScore best)
else (b1, best)
where
lstScore = boardScore b1
new = solutions b2 e' best
newScore = boardScore new
l = head empties
e' = tail empties
colors = reverse (enumFromTo Blue White)
-- showBoard converts a board to a printable string representation
showBoard :: Board -> String
showBoard board = unlines [ printRow row | row <- [minrow..maxrow] ]
where
((mincol, minrow), (maxcol, maxrow)) = bounds board
printRow row = unwords [ printCell col row | col <- [mincol..maxcol] ]
printCell col row = take 1 (show (board!(col,row)))
-- Set 'bnd' to the size of the desired board.
bnd = ((1,1),(4,4))
-- Main function generates the solutions, finds the best and prints
-- it out, along with its score
main = do putStrLn (showBoard best); putStrLn (show (boardScore best))
where
s = solutions cleanBoard (range (bounds cleanBoard)) 0
best = s
Также, пожалуйста, помните, что это моя первая нетривиальная программа на Haskell. Я уверен, что это можно сделать гораздо более элегантно и лаконично.
Обновление : Так как 5x5 с 5 цветами все еще занимал много времени (я ждал 12 часов, а он еще не закончился), я еще раз посмотрел, как использовать ограничение для удаления больше дерева поиска.
Мой первый подход состоял в том, чтобы оценить верхнюю границу частично заполненной доски, предполагая, что каждая пустая ячейка заполнена белой башней. Затем я изменил функцию «решение», чтобы отслеживать лучший результат и игнорировать все доски, верхняя граница которых меньше, чем этот лучший результат.
Это помогло некоторым, уменьшив доску 4x4x5 с 23 до 15 секунд. Чтобы еще больше улучшить его, я изменил функцию верхней границы, чтобы предположить, что каждый Пустой заполнен наилучшей возможной башней, соответствующей существующему непустому содержимому ячейки. Это очень помогло, сократив время 4x4x5 до 2 с.
Выполнение на 5x5x5 заняло 2600 с, давая следующую доску:
G B G R B
R B W Y G
Y G R B R
B W Y G Y
G R B R B
со счетом 730.
Я могу сделать еще одну модификацию, чтобы она нашла все доски с максимальным выигрышем, а не только одну.