Question

我正在Haskell中编写泛型分支和绑定实现。该算法以这种方式探索分支树（实际上没有边界，为了简单起见）：

- Start from an initial node and an initial solution.
- While there are nodes on the stack:
    - Take the node on the top.
    - If it's a leaf, then it contains a solution:
        - If it's better than the best one so far, replace it
    - Otherwise, generate the children node and add them on the top of the stack.
- When the stack is empty, return the best solution found.

解决方案和节点是什么，取决于实际问题。如何生成子节点，节点是否为叶子，如何从叶节点中提取解，又取决于实际问题。

我考虑定义需要这些操作的两个类Solution和BBNode，以及存储当前解决方案的BBState类型。我还为两种类型ConcreteSolution和ConcreteBBNode做了一个虚拟实现（它们没有任何有趣的东西，我只是想让程序键入check）。

import Data.Function (on)

class Solution solution where
  computeValue :: solution -> Double

class BBNode bbnode where
  generateChildren :: bbnode -> [bbnode]
  getSolution :: Solution solution => bbnode -> solution
  isLeaf :: bbnode -> Bool

data BBState solution = BBState {
      bestValue :: Double
    , bestSolution :: solution
    }

instance Eq (BBState solution) where
  (==) = (==) `on` bestValue

instance Ord (BBState solution) where
  compare = compare `on` bestValue


branchAndBound :: (BBNode bbnode, Solution solution) => solution -> bbnode -> Maybe solution
branchAndBound initialSolution initialNode = do
  let initialState = BBState { bestValue = computeValue initialSolution
                             , bestSolution = initialSolution
                             }
  explore [initialNode] initialState

  where

  explore :: (BBNode bbnode, Solution solution) => [bbnode] -> BBState solution -> Maybe solution
  explore [] state =
    -- Completely explored the tree, return the best solution found.
    Just (bestSolution state)

  explore (node:nodes) state
    | isLeaf node =
      -- New solution generated. If it's better than the current one, replace it.
      let newSolution = getSolution node
          newState = BBState { bestValue = computeValue newSolution
                             , bestSolution = newSolution
                             }
      in explore nodes (min state newState)

    | otherwise =
      -- Generate the children nodes and explore them.
      let childrenNodes = generateChildren node
          newNodes = childrenNodes ++ nodes
      in explore newNodes state





data ConcreteSolution = ConcreteSolution [Int]
                      deriving Show

instance Solution ConcreteSolution where
  computeValue (ConcreteSolution xs) = fromIntegral . maximum $ xs

data ConcreteBBNode = ConcreteBBNode {
      remaining :: [Int]
    , chosen :: [Int]
    }

instance BBNode ConcreteBBNode where
  generateChildren node =
    let makeNext next = ConcreteBBNode {
                chosen = next : chosen node
              , remaining = filter (/= next) (remaining node)
              }
    in map makeNext (remaining node)

  getSolution node = ConcreteSolution (chosen node)
  isLeaf node = null (remaining node)



solve :: Int -> Maybe ConcreteSolution
solve n =
  let initialSolution = ConcreteSolution [0..n]
      initialNode = ConcreteBBNode {
                chosen = []
              , remaining = [0..n]
              }
  in branchAndBound initialSolution initialNode

main :: IO ()
main = do
  let n = 10
      sol = solve n
  print sol

但是，此程序不进行类型检查。在实例getSolution中实现函数BBNode时出现错误：

Could not deduce (solution ~ ConcreteSolution)
  from the context (Solution solution)
    bound by the type signature for
           getSolution :: Solution solution => ConcreteBBNode -> solution

事实上，我甚至不确定这是正确的方法，因为在BBNode类getSolution函数应该适用于任何 Solution类型虽然我只需要单个具体的那个。

  getSolution :: Solution solution => bbnode -> solution

我也尝试使用多参数类型类：

{-# LANGUAGE MultiParamTypeClasses #-}

...

class (Solution solution) => BBNode bbnode solution where
  generateChildren :: bbnode -> [bbnode]
  getSolution :: bbnode -> solution
  isLeaf :: bbnode -> Bool

...

branchAndBound :: (BBNode bbnode solution) => solution -> bbnode -> Maybe solution
branchAndBound initialSolution initialNode = do
  let initialState = BBState { bestValue = computeValue initialSolution
                             , bestSolution = initialSolution
                             }
  explore [initialNode] initialState

  where

  explore :: (BBNode bbnode solution) => [bbnode] -> BBState solution -> Maybe solution
  explore [] state =
    -- Completely explored the tree, return the best solution found.
    Just (bestSolution state)

  explore (node:nodes) state
    | isLeaf node =
      -- New solution generated. If it's better than the current one, replace it.
...

但它仍然没有在行上打字：

  | isLeaf node =

我收到错误：

  Ambiguous type variable `solution0' in the constraint:
    (BBNode bbnode1 solution0) arising from a use of `isLeaf'

Answer 1

看起来这是functional dependencies或associated types解决的典型问题。

你的第二种方法几乎是正确的。 bbnode和solution类型已连接，即solution类型由bbnode类型唯一确定。您可以使用函数依赖项或关联类型在Haskell中对此关系进行编码。这是FD示例：

{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-}
module Main where

import Data.Function

class Solution solution where
  computeValue :: solution -> Double

class (Solution solution) => BBNode bbnode solution | bbnode -> solution where
  generateChildren :: bbnode -> [bbnode]
  getSolution :: bbnode -> solution
  isLeaf :: bbnode -> Bool

data BBState solution = BBState {
      bestValue :: Double
    , bestSolution :: solution
    }

instance Eq (BBState solution) where
  (==) = (==) `on` bestValue

instance Ord (BBState solution) where
  compare = compare `on` bestValue

branchAndBound :: (BBNode bbnode solution) => solution -> bbnode -> Maybe solution
branchAndBound initialSolution initialNode = do
  let initialState = BBState { bestValue = computeValue initialSolution
                             , bestSolution = initialSolution
                             }
  explore [initialNode] initialState

  where

  explore :: (BBNode bbnode solution) => [bbnode] -> BBState solution -> Maybe solution
  explore [] state =
    -- Completely explored the tree, return the best solution found.
    Just (bestSolution state)

  explore (node:nodes) state
    | isLeaf node = undefined

请注意BBNode类型类的定义。这个程序是如何进行的。

另一种方法是关联类型，但我不记得究竟如何将类型类边界放在关联类型上。也许其他人会写一个例子。

键入依赖于另一个类型类的类

1 个答案: