我正在实施R7RS-small Scheme我遇到了以下问题，实现等于？：（应该很明显）相等？测试值相等，它还能够测试循环数据结构的相等性，而不会进入无限循环。但是，因为我在Haskell中实现Scheme，所以我无法访问可以在哈希表*或搜索树结构中使用的可以转换为整数的基础指针值来跟踪我已经遵循的节点（以便能够有效地修剪会导致无限循环的路径。）
相反，我似乎必须使用的是身份的相等性（通过（==）在IOArrays底层对，向量和记录上测量），因此看起来我所能做的就是构建列表，标记我有哪些节点跟随（按类型分隔），然后对于我跟随的每个其他节点，搜索我已经遵循的节点的相应列表，从我看来，它在时间上的O（n log n）和空间中的O（n）中缩放
我是对的，鉴于这些条件，这是我可用的唯一算法，还是我缺少其他更有效的实现？
我已经考虑使用可以在搜索树或哈希表*中使用的标记标记每个可以包含引用的值，但是这里的问题是这对列表来说特别节省空间，因为我需要使用每个节点的标记有两个字，一个是ThreadId，另一个是每个线程的唯一ID（ThreadId是必要的，因为我正在做一个多线程的Scheme实现，否则我会有保护MVar或TMVar背后的共享唯一ID计数器，这在许多用例中会引起可怕的争用。）
*当我在实现MonadIO的monad变换器中实现所有内容时，我可以使用传统的命令式哈希表。
答案 0 :(得分：3)
Tortoise and Hare不能解决这个问题吗？
在单个列表中，它是微不足道的。你让野兔的步伐比乌龟快两倍，并在第一个元素之前开始1。如果野兔与乌龟匹配，你就会有一个周期。
使用cons单元格它基本上是一个二叉树，你可以用两个树以一个特定的顺序遍历树，并且野兔跟随第一个以双倍速度进行。如果元素是eq ?,原子不是-eqv？你拍摄电路。如果乌龟和兔子匹配你回溯。
答案 1 :(得分：1)
这是我用它来实现的算法。它是布伦特“传送乌龟”算法的一种变体，经过修改后不再处理节点的线性列表，而是处理节点的N分支树。
（这不考虑实际的比较。下面将有两个状态副本，每个数据结构一个被测试相等，如果发现某些东西的值相等，则比较很短-circuited和false返回。）
我维护了两个堆栈，一堆节点，我已经跟踪了深度优先遍历以及下一个跟随相同深度和当前深度值的节点，以及乌龟将要访问的一堆节点被定位在哪个记录乌龟所处的深度以及比下一只乌龟所处的乌龟更深的距离。 （在我的实际实现中，堆栈是统一的，以便每个堆栈帧指向一对节点和一只乌龟（指向一对节点），这简化了海龟的管理。）
当我遍历数据结构深度优先时，我构建了第一个堆栈，并且在遍历中两个距离增加的间隔我将新的帧添加到乌龟堆栈中，其中乌龟指向当前节点第一个堆栈。
当我到达一个我不能更深入的节点时，因为它没有尚未到达的兄弟节点，我下降第一个堆栈直到我到达一个有未经检查的兄弟节点的节点，然后替换该节点与下一个兄弟节点关注;如果没有剩余的兄弟节点可以跟随堆栈中的任何地方，那么我们终止为true以实现值相等。
请注意，当下降第一个堆栈时，如果弹出的第一个堆栈的顶部等于与乌龟堆栈顶部相同的深度（或节点），则会弹出乌龟堆栈的顶部。
如果将帧推入第一个堆栈后，当前节点等于乌龟堆栈顶部的节点，我回溯。第一个堆叠的顶部和龟堆的顶部之间的深度差异等于循环的大小。我回溯一个完整的循环，记录我传递的每个节点及其相应的堆栈状态和兄弟姐妹。然后我在最顶层框架下面的第一个堆栈上测试框架中的节点。如果它们在记录的节点中不，那么我知道我所在的节点是循环的开始;然后我拉出那个节点的记录堆栈和兄弟节点并从那里继续，所以我可以从循环中取出备用路径（记住这是一个N分支树）或以其他方式退出循环。如果它们在记录的节点中，我更新记录的节点以包含最顶层帧和当前节点的兄弟之下的堆栈，然后弹出堆栈的顶部并继续。
这是我的算法测试实现的代码。代码应该可以正常工作。
{-# LANGUAGE RecordWildCards, BangPatterns #-}
module EqualTree (Tree(..),
equal)
where
import Data.Array.IO (IOArray)
import Data.Array.MArray (readArray,
getBounds)
data Tree a = Value a | Node (Node a)
type Node a = IOArray Int (Tree a)
data Frame a = Frame { frameNodes :: !(Node a, Node a),
frameSiblings :: !(Maybe (Siblings a)),
frameTurtle :: !(Turtle a) }
data Siblings a = Siblings { siblingNodes :: !(Node a, Node a),
siblingIndex :: !Int }
data Turtle a = Turtle { turtleDepth :: !Int,
turtleScale :: !Int,
turtleNodes :: !(Node a, Node a) }
data EqState a = EqState { stateFrames :: [Frame a],
stateCycles :: [(Node a, Node a)],
stateDepth :: !Int }
data Unrolled a = Unrolled { unrolledNodes :: !(Node a, Node a),
unrolledState :: !(EqState a),
unrolledSiblings :: !(Maybe (Siblings a)) }
data NodeComparison = EqualNodes | NotEqualNodes | HalfEqualNodes
equal :: Eq a => Tree a -> Tree a -> IO Bool
equal tree0 tree1 =
let state = EqState { stateFrames = [], stateCycles = [], stateDepth = 0 }
in ascend state tree0 tree1 Nothing
ascend :: Eq a => EqState a -> Tree a -> Tree a -> Maybe (Siblings a) -> IO Bool
ascend state (Value value0) (Value value1) siblings =
if value0 == value1
then descend state siblings
else return False
ascend state (Node node0) (Node node1) siblings =
case memberNodes (node0, node1) (stateCycles state) of
EqualNodes -> descend state siblings
HalfEqualNodes -> return False
NotEqualNodes -> do
(_, bound0) <- getBounds node0
(_, bound1) <- getBounds node1
if bound0 == bound1
then
let turtleNodes = currentTurtleNodes state
state' = state { stateFrames =
newFrame state node0 node1 siblings :
stateFrames state,
stateDepth = (stateDepth state) + 1 }
checkDepth = nextTurtleDepth state'
in case turtleNodes of
Just turtleNodes' ->
case equalNodes (node0, node1) turtleNodes' of
EqualNodes -> beginRecovery state node0 node1 siblings
HalfEqualNodes -> return False
NotEqualNodes -> ascendFirst state' node0 node1
Nothing -> ascendFirst state' node0 node1
else return False
ascend _ _ _ _ = return False
ascendFirst :: Eq a => EqState a -> Node a -> Node a -> IO Bool
ascendFirst state node0 node1 = do
(_, bound) <- getBounds node0
tree0 <- readArray node0 0
tree1 <- readArray node1 0
if bound > 0
then let siblings = Siblings { siblingNodes = (node0, node1),
siblingIndex = 1 }
in ascend state tree0 tree1 (Just siblings)
else ascend state tree0 tree1 Nothing
descend :: Eq a => EqState a -> Maybe (Siblings a) -> IO Bool
descend state Nothing =
case stateFrames state of
[] -> return True
frame : rest ->
let state' = state { stateFrames = rest,
stateDepth = stateDepth state - 1 }
in descend state' (frameSiblings frame)
descend state (Just Siblings{..}) = do
let (node0, node1) = siblingNodes
(_, bound) <- getBounds node0
tree0 <- readArray node0 siblingIndex
tree1 <- readArray node1 siblingIndex
if siblingIndex < bound
then let siblings' = Siblings { siblingNodes = (node0, node1),
siblingIndex = siblingIndex + 1 }
in ascend state tree0 tree1 (Just siblings')
else ascend state tree0 tree1 Nothing
beginRecovery :: Eq a => EqState a -> Node a -> Node a -> Maybe (Siblings a)
-> IO Bool
beginRecovery state node0 node1 siblings =
let turtle = case stateFrames state of
[] -> error "must have first frame in stack"
frame : _ -> frameTurtle frame
distance = (stateDepth state + 1) - turtleDepth turtle
unrolledFrame = Unrolled { unrolledNodes = (node0, node1),
unrolledState = state,
unrolledSiblings = siblings }
in unrolledFrame `seq` unrollCycle state [unrolledFrame] (distance - 1)
unrollCycle :: Eq a => EqState a -> [Unrolled a] -> Int -> IO Bool
unrollCycle state unrolled !count
| count <= 0 = findCycleStart state unrolled
| otherwise =
case stateFrames state of
[] -> error "frame must be found"
frame : rest ->
let state' = state { stateFrames = rest,
stateDepth = stateDepth state - 1 }
unrolledFrame =
Unrolled { unrolledNodes = frameNodes frame,
unrolledState = state',
unrolledSiblings = frameSiblings frame }
in unrolledFrame `seq`
unrollCycle state' (unrolledFrame : unrolled) (count - 1)
findCycleStart :: Eq a => EqState a -> [Unrolled a] -> IO Bool
findCycleStart state unrolled =
case stateFrames state of
[] ->
return True
frame : [] ->
case memberUnrolled (frameNodes frame) unrolled of
(NotEqualNodes, _) -> error "node not in nodes unrolled"
(HalfEqualNodes, _) -> return False
(EqualNodes, Just (state, siblings)) ->
let state' =
state { stateCycles = frameNodes frame : stateCycles state }
in state' `seq` descend state' siblings
frame : rest@(prevFrame : _) ->
case memberUnrolled (frameNodes prevFrame) unrolled of
(EqualNodes, _) ->
let state' = state { stateFrames = rest,
stateDepth = stateDepth state - 1 }
unrolledFrame =
Unrolled { unrolledNodes = frameNodes frame,
unrolledState = state',
unrolledSiblings = frameSiblings frame }
unrolled' = updateUnrolled unrolledFrame unrolled
in unrolledFrame `seq` findCycleStart state' unrolled'
(HalfEqualNodes, _) -> return False
(NotEqualNodes, _) ->
case memberUnrolled (frameNodes frame) unrolled of
(NotEqualNodes, _) -> error "node not in nodes unrolled"
(HalfEqualNodes, _) -> return False
(EqualNodes, Just (state, siblings)) ->
let state' =
state { stateCycles = frameNodes frame : stateCycles state }
in state' `seq` descend state' siblings
updateUnrolled :: Unrolled a -> [Unrolled a] -> [Unrolled a]
updateUnrolled _ [] = []
updateUnrolled unrolled0 (unrolled1 : rest) =
case equalNodes (unrolledNodes unrolled0) (unrolledNodes unrolled1) of
EqualNodes -> unrolled0 : rest
NotEqualNodes -> unrolled1 : updateUnrolled unrolled0 rest
HalfEqualNodes -> error "this should not be possible"
memberUnrolled :: (Node a, Node a) -> [Unrolled a] ->
(NodeComparison, Maybe (EqState a, Maybe (Siblings a)))
memberUnrolled _ [] = (NotEqualNodes, Nothing)
memberUnrolled nodes (Unrolled{..} : rest) =
case equalNodes nodes unrolledNodes of
EqualNodes -> (EqualNodes, Just (unrolledState, unrolledSiblings))
HalfEqualNodes -> (HalfEqualNodes, Nothing)
NotEqualNodes -> memberUnrolled nodes rest
newFrame :: EqState a -> Node a -> Node a -> Maybe (Siblings a) -> Frame a
newFrame state node0 node1 siblings =
let turtle =
if (stateDepth state + 1) == nextTurtleDepth state
then Turtle { turtleDepth = stateDepth state + 1,
turtleScale = currentTurtleScale state * 2,
turtleNodes = (node0, node1) }
else case stateFrames state of
[] -> Turtle { turtleDepth = 1, turtleScale = 2,
turtleNodes = (node0, node1) }
frame : _ -> frameTurtle frame
in Frame { frameNodes = (node0, node1),
frameSiblings = siblings,
frameTurtle = turtle }
memberNodes :: (Node a, Node a) -> [(Node a, Node a)] -> NodeComparison
memberNodes _ [] = NotEqualNodes
memberNodes nodes0 (nodes1 : rest) =
case equalNodes nodes0 nodes1 of
NotEqualNodes -> memberNodes nodes0 rest
HalfEqualNodes -> HalfEqualNodes
EqualNodes -> EqualNodes
equalNodes :: (Node a, Node a) -> (Node a, Node a) -> NodeComparison
equalNodes (node0, node1) (node2, node3) =
if node0 == node2
then if node1 == node3
then EqualNodes
else HalfEqualNodes
else if node1 == node3
then HalfEqualNodes
else NotEqualNodes
currentTurtleNodes :: EqState a -> Maybe (Node a, Node a)
currentTurtleNodes state =
case stateFrames state of
[] -> Nothing
frame : _ -> Just . turtleNodes . frameTurtle $ frame
currentTurtleScale :: EqState a -> Int
currentTurtleScale state =
case stateFrames state of
[] -> 1
frame : _ -> turtleScale $ frameTurtle frame
nextTurtleDepth :: EqState a -> Int
nextTurtleDepth state =
case stateFrames state of
[] -> 1
frame : _ -> let turtle = frameTurtle frame
in turtleDepth turtle + turtleScale turtle
以下是测试程序使用的算法的简单版本。
{-# LANGUAGE RecordWildCards #-}
module NaiveEqualTree (Tree(..),
naiveEqual)
where
import Data.Array.IO (IOArray)
import Data.Array.MArray (readArray,
getBounds)
import EqualTree (Tree(..),
Node)
data Frame a = Frame { frameNodes :: !(Node a, Node a),
frameSiblings :: !(Maybe (Siblings a)) }
data Siblings a = Siblings { siblingNodes :: !(Node a, Node a),
siblingIndex :: !Int }
data NodeComparison = EqualNodes | NotEqualNodes | HalfEqualNodes
naiveEqual :: Eq a => Tree a -> Tree a -> IO Bool
naiveEqual tree0 tree1 = ascend [] tree0 tree1 Nothing
ascend :: Eq a => [Frame a] -> Tree a -> Tree a -> Maybe (Siblings a) -> IO Bool
ascend state (Value value0) (Value value1) siblings =
if value0 == value1
then descend state siblings
else return False
ascend state (Node node0) (Node node1) siblings =
case testNodes (node0, node1) state of
EqualNodes -> descend state siblings
HalfEqualNodes -> return False
NotEqualNodes -> do
(_, bound0) <- getBounds node0
(_, bound1) <- getBounds node1
if bound0 == bound1
then do
let frame = Frame { frameNodes = (node0, node1),
frameSiblings = siblings }
state' = frame : state
tree0 <- readArray node0 0
tree1 <- readArray node1 0
if bound0 > 0
then let siblings = Siblings { siblingNodes = (node0, node1),
siblingIndex = 1 }
in frame `seq` ascend state' tree0 tree1 (Just siblings)
else frame `seq` ascend state' tree0 tree1 Nothing
else return False
ascend _ _ _ _ = return False
descend :: Eq a => [Frame a] -> Maybe (Siblings a) -> IO Bool
descend state Nothing =
case state of
[] -> return True
frame : rest -> descend rest (frameSiblings frame)
descend state (Just Siblings{..}) = do
let (node0, node1) = siblingNodes
(_, bound) <- getBounds node0
tree0 <- readArray node0 siblingIndex
tree1 <- readArray node1 siblingIndex
if siblingIndex < bound
then let siblings' = Siblings { siblingNodes = (node0, node1),
siblingIndex = siblingIndex + 1 }
in ascend state tree0 tree1 (Just siblings')
else ascend state tree0 tree1 Nothing
testNodes :: (Node a, Node a) -> [Frame a] -> NodeComparison
testNodes _ [] = NotEqualNodes
testNodes nodes (frame : rest) =
case equalNodes nodes (frameNodes frame) of
NotEqualNodes -> testNodes nodes rest
HalfEqualNodes -> HalfEqualNodes
EqualNodes -> EqualNodes
equalNodes :: (Node a, Node a) -> (Node a, Node a) -> NodeComparison
equalNodes (node0, node1) (node2, node3) =
if node0 == node2
then if node1 == node3
then EqualNodes
else HalfEqualNodes
else if node1 == node3
then HalfEqualNodes
else NotEqualNodes
这是测试程序的代码。请注意，这在偶数测试中偶尔会失败，因为它旨在生成具有相当程度通用性的节点集，由commonPortionRange控制。
{-# LANGUAGE TupleSections #-}
module Main where
import Data.Array (Array,
listArray,
bounds,
(!))
import Data.Array.IO (IOArray)
import Data.Array.MArray (writeArray,
newArray_)
import Control.Monad (forM_,
mapM,
mapM_,
liftM,
foldM)
import Control.Exception (SomeException,
catch)
import System.Random (StdGen,
newStdGen,
random,
randomR,
split)
import Prelude hiding (catch)
import EqualTree (Tree(..),
equal)
import NaiveEqualTree (naiveEqual)
leafChance :: Double
leafChance = 0.5
valueCount :: Int
valueCount = 1
maxNodeCount :: Int
maxNodeCount = 1024
commonPortionRange :: (Double, Double)
commonPortionRange = (0.8, 0.9)
commonRootChance :: Double
commonRootChance = 0.5
nodeSizeRange :: (Int, Int)
nodeSizeRange = (2, 5)
testCount :: Int
testCount = 1000
makeMapping :: Int -> (Int, Int) -> Int -> StdGen ->
([Either Int Int], StdGen)
makeMapping values range nodes gen =
let (count, gen') = randomR range gen
in makeMapping' 0 [] count gen'
where makeMapping' index mapping count gen
| index >= count = (mapping, gen)
| otherwise =
let (chance, gen0) = random gen
(slot, gen2) =
if chance <= leafChance
then let (value, gen1) = randomR (0, values - 1) gen0
in (Left value, gen1)
else let (nodeIndex, gen1) = randomR (0, nodes - 1) gen0
in (Right nodeIndex, gen1)
in makeMapping' (index + 1) (slot : mapping) count gen2
makeMappings :: Int -> Int -> (Int, Int) -> StdGen ->
([[Either Int Int]], StdGen)
makeMappings size values range gen =
let (size', gen') = randomR (1, size) gen
in makeMappings' 0 size' [] gen'
where makeMappings' index size mappings gen
| index >= size = (mappings, gen)
| otherwise =
let (mapping, gen') = makeMapping values range size gen
in makeMappings' (index + 1) size (mapping : mappings) gen'
makeMappingsPair :: Int -> (Double, Double) -> Int -> (Int, Int) -> StdGen ->
([[Either Int Int]], [[Either Int Int]], StdGen)
makeMappingsPair size commonPortionRange values range gen =
let (size', gen0) = randomR (2, size) gen
(commonPortion, gen1) = randomR commonPortionRange gen0
size0 = 1 + (floor $ fromIntegral size' * commonPortion)
size1 = size' - size0
(mappings, gen2) = makeMappingsPair' 0 size0 size' [] gen1
(mappings0, gen3) = makeMappingsPair' 0 size1 size' [] gen2
(mappings1, gen4) = makeMappingsPair' 0 size1 size' [] gen3
(commonRootValue, gen5) = random gen4
in if commonRootValue < commonRootChance
then (mappings ++ mappings0, mappings ++ mappings1, gen5)
else (mappings0 ++ mappings, mappings1 ++ mappings, gen5)
where makeMappingsPair' index size size' mappings gen
| index >= size = (mappings, gen)
| otherwise =
let (mapping, gen') = makeMapping values range size' gen
in makeMappingsPair' (index + 1) size size' (mapping : mappings)
gen'
populateNode :: IOArray Int (Tree a) -> Array Int (IOArray Int (Tree a)) ->
[Either a Int] -> IO ()
populateNode node nodes mapping =
mapM_ (uncurry populateSlot) (zip [0..] mapping)
where populateSlot index (Left value) =
writeArray node index $ Value value
populateSlot index (Right nodeIndex) =
writeArray node index . Node $ nodes ! nodeIndex
makeTree :: [[Either a Int]] -> IO (Tree a)
makeTree mappings = do
let size = length mappings
nodes <- liftM (listArray (0, size - 1)) $ mapM makeNode mappings
mapM_ (\(index, mapping) -> populateNode (nodes ! index) nodes mapping)
(zip [0..] mappings)
return . Node $ nodes ! 0
where makeNode mapping = newArray_ (0, length mapping - 1)
testEqual :: StdGen -> IO (Bool, StdGen)
testEqual gen = do
let (mappings, gen0) =
makeMappings maxNodeCount valueCount nodeSizeRange gen
tree0 <- makeTree mappings
tree1 <- makeTree mappings
catch (liftM (, gen0) $ equal tree0 tree1) $ \e -> do
putStrLn $ show (e :: SomeException)
return (False, gen0)
testNotEqual :: StdGen -> IO (Bool, Bool, StdGen)
testNotEqual gen = do
let (mappings0, mappings1, gen0) =
makeMappingsPair maxNodeCount commonPortionRange valueCount
nodeSizeRange gen
tree0 <- makeTree mappings0
tree1 <- makeTree mappings1
test <- naiveEqual tree0 tree1
if not test
then
catch (testNotEqual' tree0 tree1 mappings0 mappings1 gen0) $ \e -> do
putStrLn $ show (e :: SomeException)
return (False, False, gen0)
else return (True, True, gen0)
where testNotEqual' tree0 tree1 mappings0 mappings1 gen0 = do
test <- equal tree0 tree1
if test
then do
putStrLn "Match failure: "
putStrLn "Mappings 0: "
mapM (putStrLn . show) $ zip [0..] mappings0
putStrLn "Mappings 1: "
mapM (putStrLn . show) $ zip [0..] mappings1
return (False, False, gen0)
else return (True, False, gen0)
doTestEqual :: (StdGen, Int) -> Int -> IO (StdGen, Int)
doTestEqual (gen, successCount) _ = do
(success, gen') <- testEqual gen
return (gen', successCount + (if success then 1 else 0))
doTestNotEqual :: (StdGen, Int, Int) -> Int -> IO (StdGen, Int, Int)
doTestNotEqual (gen, successCount, excludeCount) _ = do
(success, exclude, gen') <- testNotEqual gen
return (gen', successCount + (if success then 1 else 0),
excludeCount + (if exclude then 1 else 0))
main :: IO ()
main = do
gen <- newStdGen
(gen0, equalSuccessCount) <- foldM doTestEqual (gen, 0) [1..testCount]
putStrLn $ show equalSuccessCount ++ " out of " ++ show testCount ++
" tests for equality passed"
(_, notEqualSuccessCount, excludeCount) <-
foldM doTestNotEqual (gen0, 0, 0) [1..testCount]
putStrLn $ show notEqualSuccessCount ++ " out of " ++ show testCount ++
" tests for inequality passed (with " ++ show excludeCount ++ " excluded)"