现代优化算法的逻辑谜题

Question

我有以下“逻辑难题”（我认为这被认为是“调度问题”）：

在这个问题中，有 5 名篮球运动员 - 提供一些关于他们的昵称和身高的线索，您需要找到正确的球员-昵称-身高组合。

在之前的帖子 (Solving Logic Puzzles Using R) 中，我学习了如何使用 R 编程语言通过“蛮力”解决这个问题：

library(dplyr)

dt <- purrr::cross_df(list(
  name = list(c("Bill", "Ernie", "Oscar", "Sammy", "Tony")),
  nickname = combinat::permn(c("Slats", "Stretch", "Tiny", "Tower", "Tree")), 
  height = combinat::permn(c(6.6, 6.5, 6.3, 6.1, 6))
))

dt %>%  
  group_by(id = (seq_len(n()) - 1L) %/% 5L) %>% 
  filter(
    height[name == "Oscar"] > height[nickname == "Tree"], 
    height[nickname == "Tree"] > height[name == "Tony"], 
    height[name == "Bill"] > height[name == "Sammy"], 
    height[name == "Bill"] < height[nickname == "Slats"], 
    nickname[name == "Tony"] != "Tiny",
    height[nickname == "Stretch"] > height[name == "Oscar"], 
    height[nickname == "Stretch"] < 6.6
  )

#output
# A tibble: 5 x 4
# Groups:   id [1]
  name  nickname height    id
  <chr> <chr>     <dbl> <int>
1 Bill  Stretch     6.5 14398
2 Ernie Slats       6.6 14398
3 Oscar Tiny        6.3 14398
4 Sammy Tree        6.1 14398
5 Tony  Tower       6   14398

但是，当有成千上万的篮球运动员时，我认为上述方法的规模并不大。我很想知道是否可以使用一些更现代的优化算法（例如粒子群优化、模拟退火、nelder-meade、遗传算法等）来解决这个问题。

例如，在这个问题中，也许玩家-身高-昵称的每个组合所满足的“优化约束的分数”可以用作度量？

如果（实际上不正确，只是草拟一个简单的例子）

• 组合 1：Bill = Slats，Ernie = Stretch，Oscar = Tiny，Sammy = Tiny，Tony = Tree。比尔 6'6，厄尼 6'5，奥斯卡 6'3，萨米 6'1，托尼 6'。满足 3/4 的优化约束

• 组合 53：Bill = Stretch，Ernie = Slats，Oscar = Tiny，Sammy = Tiny，Tony = Tree。比尔 6 英尺 6 英寸，厄尼 6 英尺 5 英寸，奥斯卡 6 英尺 3 英寸，萨米 6 英尺，托尼 6 英尺 1 英寸。仅满足 2/4 的优化约束

也许我们可以说组合 1 比组合 53 具有更高的“性能指标”，因此，与组合 53 相比，考虑更接近组合 1 的组合可能更有利。

过去，我在 R 中使用了不同的优化算法来进行“多项式求根”——但是，我不确定如何为这个篮球示例编码优化函数、目标度量和约束。我做了一些研究，发现 R 中有一些不同的优化库可能能够解决这个问题：

• https://cran.r-project.org/web/packages/rminizinc/index.html
• https://www.r-orms.org/
• https://cran.r-project.org/web/packages/lpSolve/index.html

但我不确定如何使用这些参考资料来解决篮球问题。

有人可以告诉我怎么做吗？

谢谢！

Answer 1

这是一个允许多个矢量化搜索线程的随机贪心算法。我不能说它在数千名玩家中的表现如何，但在 5 名玩家的情况下，它的表现优于在帖子中的蛮力方法。禁忌搜索方法可能会在解决较大问题时提高性能。

players <- c("Bill", "Ernie", "Oscar", "Sammy", "Tony")
nicknames <- c("Slats", "Stretch", "Tiny", "Tower", "Tree")
heights <- c(6, 6.1, 6.3, 6.5, 6.6)

getScore <- function(m) {
  return(
    (m[3,] > m[10,]) +
      (m[10,] > m[5,]) +
      (m[1,] > m[4,]) +
      (m[1,] < m[6,]) +
      (m[5,] != m[8,]) +
      (m[7,] > m[3,]) +
      (m[7,] != 5L))
}

fGreedy <- function(players, nicknames, heights, fScore, maxScore = 0L, threads = 1L, maxIter = Inf) {
  nPlayers <- length(players)
  # the first 5 rows of the config matrix are the height orders by player name
  # the second 5 are the rows are the height orders by nickname
  # each column is a different search thread
  config <- replicate(threads, c(sample(nPlayers), sample(nPlayers)))
  currScore <- fScore(config)
  mIdx1 <- matrix(1:threads, nrow = threads, ncol = 2)
  mIdx2 <- matrix(1:threads, nrow = threads, ncol = 2)
  iter <- setNames(1L, "iterations")
  
  while (max(currScore) < maxScore && iter < maxIter) {
    proposal <- config
    blnNicknameSwap <- sample(c(TRUE, FALSE), threads, replace = TRUE)
    mIdx1[,1] <- sample(5, threads, replace = TRUE)
    mIdx2[,1] <- ((mIdx1[,1] + sample(0:3, threads, replace = TRUE)) %% 5L) + 1L
    mIdx1[blnNicknameSwap, 1] <- mIdx1[blnNicknameSwap, 1] + 5L
    mIdx2[blnNicknameSwap, 1] <- mIdx2[blnNicknameSwap, 1] + 5L
    temp <- proposal[mIdx1]
    proposal[mIdx1] <- proposal[mIdx2]
    proposal[mIdx2] <- temp
    newScore <- fScore(proposal)
    blnReplace <- newScore >= currScore
    config[,blnReplace] <- proposal[,blnReplace]
    currScore[blnReplace] <- newScore[blnReplace]
    iter <- iter + 1L
  }
  
  # print(iter)
  ans <- config[,which.max(currScore)]
  return(data.frame(name = players[order(ans[1:5])], nickname = nicknames[order(ans[6:10])], height = heights))
}


library(dplyr)

dt <- purrr::cross_df(list(
  name = list(c("Bill", "Ernie", "Oscar", "Sammy", "Tony")),
  nickname = combinat::permn(c("Slats", "Stretch", "Tiny", "Tower", "Tree")), 
  height = combinat::permn(c(6.6, 6.5, 6.3, 6.1, 6))
))

fEnum <- function(dt) {
  dt %>%  
    group_by(id = (seq_len(n()) - 1L) %/% 5L) %>% 
    filter(
      height[name == "Oscar"] > height[nickname == "Tree"], 
      height[nickname == "Tree"] > height[name == "Tony"], 
      height[name == "Bill"] > height[name == "Sammy"], 
      height[name == "Bill"] < height[nickname == "Slats"], 
      nickname[name == "Tony"] != "Tiny",
      height[nickname == "Stretch"] > height[name == "Oscar"], 
      height[nickname == "Stretch"] < 6.6
    )
}

fGreedy(players, nicknames, heights, getScore, 7L, 100L)
#>    name nickname height
#> 1  Tony    Tower    6.0
#> 2 Sammy     Tree    6.1
#> 3 Oscar     Tiny    6.3
#> 4  Bill  Stretch    6.5
#> 5 Ernie    Slats    6.6
fEnum(dt)
#> # A tibble: 5 x 4
#> # Groups:   id [1]
#>   name  nickname height    id
#>   <chr> <chr>     <dbl> <int>
#> 1 Bill  Stretch     6.5 14398
#> 2 Ernie Slats       6.6 14398
#> 3 Oscar Tiny        6.3 14398
#> 4 Sammy Tree        6.1 14398
#> 5 Tony  Tower       6   14398

microbenchmark::microbenchmark("enum" = fEnum(dt),
                               "1" = fGreedy(players, nicknames, heights, getScore, 7L, 1L),
                               "10" = fGreedy(players, nicknames, heights, getScore, 7L, 10L),
                               "100" = fGreedy(players, nicknames, heights, getScore, 7L, 100L))
#> Unit: microseconds
#>  expr        min         lq       mean     median         uq        max neval
#>  enum 349753.801 361069.301 377810.821 368307.051 386885.301 490222.700   100
#>     1    772.602   4274.502  14209.154   9021.252  19660.551  79180.201   100
#>    10    508.701   1645.201   2892.640   2398.501   3841.801   9889.700   100
#>   100   1358.001   2225.301   2986.916   2773.552   3237.601   9725.301   100