Haskell实现二值四叉树图像的边缘检测

四叉树(Quadtree)是一种数据结构，可用于表示图像。本文聚焦于一种简单的四叉树结构，使用Haskell及函数式编程(Functional Programming)的思想对其进行递归表示，并实现对由该四叉树表示的的二值图像的边缘检测。

问题背景

假设我们需要存储一张大小为\(2^n*2^n\)的正方形二值图像，一般使用一个比特\(0\)或\(1\)来存储一个像素值，需要\(2^n*2^n\)比特的存储空间。我们可以设计一种方法来表示图像中不同大小的同色区域，从而减少所需的空间。

一种简单的优化方法为，将一张正方形图像划分为四个大小相同的子图像，分别表示右上、左上、左下和右下区域。借用数学中坐标系的表示方法，我们简称它们为第一到第四象限的图像。对于每个象限，如果其中所有像素的颜色都相同，我们可以仅用1个比特表示该子图，并称其为一个图像单元格；否则继续递归划分该子图，直到获得纯色单元格。

考虑到递归表示的特点，我们在此忽略宏观图像的大小、像素维度和几何结构，仅仅关注递归的数据结构本身。这也将问题的表示尽可能简化，以最少的约束解决实际问题。

四叉树表示

下面使用Haskell进行四叉树这一抽象数据类型的表示。与此同时定义两个函数allBlack和allWhite，其接收一个整数输入\(n\)，返回一个大小为\(n*n\)的纯色四叉树（假设输入\(n\)可表示为\(2^k\)）。这里的特别之处在于，由于纯色单元格不可再分且为可表示的最小单位，因此实际上无论输入任何\(n\)，输出都为无关大小的一个纯色单元格。

-- define colors
data Color = Black | White deriving (Eq, Show)
-- implement Quadtree (the order of quadrant is same as mathematical coordinate system, with top-right grid being the first quadrant)
data Quadtree = Cell Color | Grid Quadtree Quadtree Quadtree Quadtree deriving (Eq, Show)

-- ignore size if a Quadtree is in same color
allBlack :: Int -> Quadtree
allBlack _ = Cell Black

allWhite :: Int -> Quadtree
allWhite _ = Cell White

问题目标

我们需要实现的目标为：定义一个名为ndiff的函数，输入一个四叉树，输出一个四叉树。其中输出四叉树保留与输入四叉树完全一致的内部结构，但按以下规则改变四叉树内部单元格的颜色：当且仅当某单元格自身颜色与任意一个沿边或角相邻的单元格颜色不一致时，该单元格为黑色，否则为白色。举例如下图所示：

可见输出的四叉树大多数单元格均变为了黑色，因为它们都至少与一个相邻单元格（包括角落）颜色不同。

问题解答

{-
    For this exercise, my general idea is that, first, find out all neighbours of each cell and store these information in a separate data structure (QuadtreeWN), then generate the new Quadtree which detects edges by those neighbours.
    To find out all neighbours, I use two nested recursions. One is to update neighbour list gradually from leaves to root. At each level, I tell each grid their surroundings, and use another recursion to update given surrounding cells into neighbour lists of cells of the current quadtree.
    This method does not care about the real size of cells, and so works on large, non-uniform quadtrees.
-}

-- define Quadtree with Neighbours which is represented as a list of cell colors
data QuadtreeWN = CellWN Color [Color] | GridWN QuadtreeWN QuadtreeWN QuadtreeWN QuadtreeWN deriving (Eq, Show)
-- define Surroundings that stores surrounding quadtrees of a quadtree
data Surrounding = Empty | SQuadtree Quadtree deriving (Eq, Show)
data Surroundings = Surroundings {
    top :: Surrounding,
    bottom :: Surrounding,
    left :: Surrounding,
    right :: Surrounding,
    topLeft :: Surrounding,
    topRight :: Surrounding,
    bottomLeft :: Surrounding,
    bottomRight :: Surrounding
} deriving (Eq, Show)

-- define helper functions to get the specific sub-quadtree of a quadtree
getGridA :: Surrounding -> Surrounding
getGridA Empty = Empty
getGridA (SQuadtree (Cell co)) = SQuadtree (Cell co)
getGridA (SQuadtree (Grid a b c d)) = SQuadtree a

getGridB :: Surrounding -> Surrounding
getGridB Empty = Empty
getGridB (SQuadtree (Cell co)) = SQuadtree (Cell co)
getGridB (SQuadtree (Grid a b c d)) = SQuadtree b

getGridC :: Surrounding -> Surrounding
getGridC Empty = Empty
getGridC (SQuadtree (Cell co)) = SQuadtree (Cell co)
getGridC (SQuadtree (Grid a b c d)) = SQuadtree c

getGridD :: Surrounding -> Surrounding
getGridD Empty = Empty
getGridD (SQuadtree (Cell co)) = SQuadtree (Cell co)
getGridD (SQuadtree (Grid a b c d)) = SQuadtree d

-- define helper functions to get cells of a quadtree in a given direction, e.g. `getTopCells` gives cells that compose the top edge of a quadtree
getTopCells :: Surrounding -> [Color]
getTopCells Empty = []
getTopCells (SQuadtree (Cell co)) = [co]
getTopCells (SQuadtree (Grid a b c d)) = getTopCells (SQuadtree b) ++ getTopCells (SQuadtree a)

getBottomCells :: Surrounding -> [Color]
getBottomCells Empty = []
getBottomCells (SQuadtree (Cell co)) = [co]
getBottomCells (SQuadtree (Grid a b c d)) = getBottomCells (SQuadtree c) ++ getBottomCells (SQuadtree d)

getLeftCells :: Surrounding -> [Color]
getLeftCells Empty = []
getLeftCells (SQuadtree (Cell co)) = [co]
getLeftCells (SQuadtree (Grid a b c d)) = getLeftCells (SQuadtree b) ++ getLeftCells (SQuadtree c)

getRightCells :: Surrounding -> [Color]
getRightCells Empty = []
getRightCells (SQuadtree (Cell co)) = [co]
getRightCells (SQuadtree (Grid a b c d)) = getRightCells (SQuadtree a) ++ getRightCells (SQuadtree d)

getTopLeftCell :: Surrounding -> [Color]
getTopLeftCell Empty = []
getTopLeftCell (SQuadtree (Cell co)) = [co]
getTopLeftCell (SQuadtree (Grid a b c d)) = getTopLeftCell (SQuadtree b)

getTopRightCell :: Surrounding -> [Color]
getTopRightCell Empty = []
getTopRightCell (SQuadtree (Cell co)) = [co]
getTopRightCell (SQuadtree (Grid a b c d)) = getTopRightCell (SQuadtree a)

getBottomLeftCell :: Surrounding -> [Color]
getBottomLeftCell Empty = []
getBottomLeftCell (SQuadtree (Cell co)) = [co]
getBottomLeftCell (SQuadtree (Grid a b c d)) = getBottomLeftCell (SQuadtree c)

getBottomRightCell :: Surrounding -> [Color]
getBottomRightCell Empty = []
getBottomRightCell (SQuadtree (Cell co)) = [co]
getBottomRightCell (SQuadtree (Grid a b c d)) = getBottomRightCell (SQuadtree d)


-- update border cells of given surroundings into neighbour list of each cell (recursion from root to leaves)
updateNeighbours :: QuadtreeWN -> Surroundings -> QuadtreeWN
updateNeighbours (CellWN co neigs) surrs = CellWN co (neigs ++
        getBottomCells (top surrs) ++
        getTopCells (bottom surrs) ++
        getRightCells (left surrs) ++
        getLeftCells (right surrs) ++
        getBottomRightCell (topLeft surrs) ++
        getBottomLeftCell (topRight surrs) ++
        getTopRightCell (bottomLeft surrs) ++
        getTopLeftCell (bottomRight surrs)
    )
-- pass specific sub-quadtree of given surrounding quadtree to form use sub-Surroundings
updateNeighbours (GridWN a b c d) surrs = GridWN
    (updateNeighbours a (Surroundings {
        top = getGridD (top surrs),
        bottom = Empty,
        left = Empty,
        right = getGridB (right surrs),
        topLeft = getGridC (top surrs),
        topRight = getGridC (topRight surrs),
        bottomLeft = Empty,
        bottomRight = getGridC (right surrs)
    }))
    (updateNeighbours b (Surroundings {
        top = getGridC (top surrs),
        bottom = Empty,
        left = getGridA (left surrs),
        right = Empty,
        topLeft = getGridD (topLeft surrs),
        topRight = getGridD (top surrs),
        bottomLeft = getGridD (left surrs),
        bottomRight = Empty
    }))
    (updateNeighbours c (Surroundings {
        top = Empty,
        bottom = getGridB (bottom surrs),
        left = getGridD (left surrs),
        right = Empty,
        topLeft = getGridA (left surrs),
        topRight = Empty,
        bottomLeft = getGridA (bottomLeft surrs),
        bottomRight = getGridA (bottom surrs)
    }))
    (updateNeighbours d (Surroundings {
        top = Empty,
        bottom = getGridA (bottom surrs),
        left = Empty,
        right = getGridC (right surrs),
        topLeft = Empty,
        topRight = getGridB (right surrs),
        bottomLeft = getGridB (bottom surrs),
        bottomRight = getGridB (bottomRight surrs)
    }))

-- compute neighbour list of each cell (from leaves to root)
computeNeighbours :: Quadtree -> QuadtreeWN
computeNeighbours (Cell co) = CellWN co []
-- pass surroundings at each level to updateNeighbours
computeNeighbours (Grid a b c d) = GridWN
    (updateNeighbours (computeNeighbours a) (Surroundings {
        top = Empty,
        bottom = SQuadtree d,
        left = SQuadtree b,
        right = Empty,
        topLeft = Empty,
        topRight = Empty,
        bottomLeft = SQuadtree c,
        bottomRight = Empty
    }))
    (updateNeighbours (computeNeighbours b) (Surroundings {
        top = Empty,
        bottom = SQuadtree c,
        left = Empty,
        right = SQuadtree a,
        topLeft = Empty,
        topRight = Empty,
        bottomLeft = Empty,
        bottomRight = SQuadtree d
    }))
    (updateNeighbours (computeNeighbours c) (Surroundings {
        top = SQuadtree b,
        bottom = Empty,
        left = Empty,
        right = SQuadtree d,
        topLeft = Empty,
        topRight = SQuadtree a,
        bottomLeft = Empty,
        bottomRight = Empty
    }))
    (updateNeighbours (computeNeighbours d) (Surroundings {
        top = SQuadtree a,
        bottom = Empty,
        left = SQuadtree c,
        right = Empty,
        topLeft = SQuadtree b,
        topRight = Empty,
        bottomLeft = Empty,
        bottomRight = Empty
    }))

-- decide if a given color is same as all of list elements
isSameColor :: Color -> [Color] -> Bool
isSameColor c [] = True
isSameColor c (x:xs) = c == x && isSameColor c xs

-- generate resulting matrix according to information in neighbour lists, which computes edges
detectEdges :: QuadtreeWN -> Quadtree
detectEdges (CellWN co neigs) = if isSameColor co neigs then allWhite 1 else allBlack 1
detectEdges (GridWN a b c d) = Grid (detectEdges a) (detectEdges b) (detectEdges c) (detectEdges d)

-- my crude edge detector
ndiff :: Quadtree -> Quadtree
ndiff (Cell _) = allWhite 1
ndiff grid = detectEdges (computeNeighbours grid)