在Mathematica中实现四叉树

Question

我在Mathematica中实现了quadtree。我不熟悉像Mathematica这样的函数式编程语言，我想知道我是否可以通过更好地使用模式来改进它或使其更紧凑。

（我知道我可以通过修剪未使用的节点来优化树，并且可能有更好的数据结构，比如用于空间分解的k-d树。）

另外，每次添加新点时，我仍然不满意复制整个树/表达式的想法。但我的理解是，对整个表达式进行操作而不修改部分是函数式编程方式。我对这方面的任何澄清表示感谢。

MV

守则

ClearAll[qtMakeNode, qtInsert, insideBox, qtDraw, splitBox, isLeaf, qtbb, qtpt];

(* create a quadtree node *)
qtMakeNode[{{xmin_,ymin_}, {xmax_, ymax_}}] := 
{{}, {}, {}, {}, qtbb[{xmin, ymin}, {xmax, ymax}], {}}

(* is pt inside box? *)
insideBox[pt_, bb_] := If[(pt[[1]] <= bb[[2, 1]]) && (pt[[1]] >= bb[[1, 1]]) &&
  (pt[[2]] <= bb[[2, 2]]) && (pt[[2]] >= bb[[1, 2]]),
  True, False]

(* split bounding box into 4 children *)
splitBox[{{xmin_,ymin_}, {xmax_, ymax_}}] := {
 {{xmin, (ymin+ymax)/2}, {(xmin+xmax)/2, ymax}},
 {{xmin, ymin},{(xmin+xmax)/2,(ymin+ymax)/2}},
 {{(xmin+xmax)/2, ymin},{xmax, (ymin+ymax)/2}},
 {{(xmin+xmax)/2, (ymin+ymax)/2},{xmax, ymax}}
}

(* is node a leaf? *)
isLeaf[qt_] := If[ And @@((# == {})& /@ Join[qt[[1;;4]], {List @@ qt[[6]]}]),True, False]

(*--- insert methods ---*)

(* qtInsert #1 - return input if pt is out of bounds *)
qtInsert[qtree_, pt_] /; !insideBox[pt, List @@ qtree[[5]]]:= qtree

(* qtInsert #2 - if leaf, just add pt to node *)
qtInsert[qtree_, pt_] /; isLeaf[qtree] :=
{qtree[[1]],qtree[[2]],qtree[[3]],qtree[[4]],qtree[[5]], qtpt @@ pt} 

(* qtInsert #3 - recursively insert pt *)
qtInsert[qtree_, pt_] := 
  Module[{cNodes, currPt},
  cNodes = qtree[[1;;4]];
  (* child nodes not created? *)
  If[And @@ ((# == {})& /@ cNodes), 
    (* compute child node bounds *)
    (* create child nodes with above bounds*)
    cNodes = qtMakeNode[#]& /@ splitBox[List @@ qtree[[5]]];
  ];
  (* move curr node pt (if not empty) into child *)
  currPt = List @@ qtree[[6]];
  If[currPt != {},
    cNodes = qtInsert[#, currPt]& /@ cNodes; 
  ];
 (* insert new pt into child *)
 cNodes = qtInsert[#, pt]& /@ cNodes;
 (* return new quadtree *)
 {cNodes[[1]],cNodes[[2]], cNodes[[3]], cNodes[[4]], qtree[[5]], {}}
 ]

(* draw quadtree *)
qtDraw[qt_] := Module[{pts, bboxes},
  pts = Cases[qt, _qtpt, Infinity] /. qtpt :> List;
  bboxes = Cases[qt, _qtbb, Infinity] /. qtbb :> List;
  Graphics[{
   EdgeForm[Black],Hue[0.2], Map[Disk[#, 0.01]&, pts],
   Hue[0.7],EdgeForm[Red], FaceForm[],(Rectangle @@ #) & /@ bboxes
  },
  Frame->True
 ]
]

用法

Clear[qt];
len = 50;
pts = RandomReal[{0, 2}, {len, 2}];
qt = qtMakeNode[{{0.0, 0.0}, {2.0, 2.0}}];
Do[qt = qtInsert[qt, pts[[i]]], {i, 1, len}]
qtDraw[qt]

输出

Answer 1

我认为你的代码并不像你期望的那样对内存感到饥饿。它确实打破并改革了名单，但它往往使大多数子列表保持不变。

正如其他人所说，仍然可以使用Hold包装器和/或HoldXXX属性做得更好，以便模拟按引用调用。

对于某些相关数据结构实现的硬核方法，请参阅

http://library.wolfram.com/infocenter/MathSource/7619/

相关代码在笔记本中是Hemmecke-final.nb（之所以如此命名是因为它实现了由于R. Hemmecke和共同作者而实现的复曲面Groebner基算法。）

我尝试使用Hold ...属性重新实现，但是我并不是非常擅长并且当代码刺向我时（放弃，但杀死了我的Mathematica会话）放弃了它。所以相反，我有一个使用未记录的“原始”Mathematica数据类型的实现，这种数据类型是惰性的，因此适合于通过引用调用行为。

所讨论的结构称为“expr bag”，因为通用的Mathematica数据结构是“expr”。它就像一个List但是（1）它可以在一端生长（虽然不缩小）和（2）像其他原始表达式类型（例如版本8中的图形）一样，它具有可以通过提供的函数访问和/或更改的组件（一个API，可以这么说）。它的潜在“元素”是惰性的，因为它们可以引用任何expr（包括包本身），并且可以用我在下面指出的方式进行操作。

上面的第一项提供了实施Sow / Reap的基础技术。这是第二个对下面的代码感兴趣的内容。最后，我将在解释数据结构时加入一些评论，因为没有正式的文档。

我将代码或多或少保持与原始代码相同的样式，特别是它仍然是一个在线版本（也就是说，元素不一定都是在开始时进入，但可以单独添加）。换了几个名字。制作了类似于

的基本结构

节点（边界框，值，零或四个子节点）

如果有子节点，则值字段为空。 box和value字段由通常的Mathematica List表达式表示，尽管使用专用头并使其更类似于C struct样式可能是有意义的。在命名各种字段访问/设置功能时，我确实做了类似的事情。

有一点需要注意，这种原始数据类型消耗的内存开销比例如一个列表。所以下面我的变体将使用比最初发布的代码更多的内存。不是渐渐地更多，只是一个恒定的因素。在访问或设置元素值方面，它需要一个恒定的开销因子，比如一个类似的C结构。所以它不是一个神奇的子弹，只是一种行为不应该给出渐近意外的数据类型。

---

AppendTo[$ContextPath, "Internal`"];

makeQuadTreeNode[bounds_] := Bag[{bounds, {}, {}}]

(*is pt inside box?*)

insideBox[pt_, box_] := 
 And @@ Thread[box[[1]] <= (List @@ pt) <= box[[2]]]

(*split bounding box into 4 children*)

splitBox[{{xmin_, ymin_}, {xmax_, ymax_}}] := 
 Map[makeQuadTreeNode, {{{xmin, (ymin + ymax)/2}, {(xmin + xmax)/2, 
     ymax}}, {{xmin, 
     ymin}, {(xmin + xmax)/2, (ymin + ymax)/2}}, {{(xmin + xmax)/2, 
     ymin}, {xmax, (ymin + ymax)/2}}, {{(xmin + xmax)/
      2, (ymin + ymax)/2}, {xmax, ymax}}}]

bounds[qt_] := BagPart[qt, 1]
value[qt_] := BagPart[qt, 2]
children[qt_] := BagPart[qt, 3]

isLeaf[qt_] := value[qt] =!= {}
isSplit[qt_] := children[qt] =!= {}
emptyNode[qt_] := ! isLeaf[qt] && ! isSplit[qt]

(*qtInsert #1-return input if pt is out of bounds*)

qtInsert[qtree_, pt_] /; ! insideBox[pt, bounds[qtree]] := qtree

(*qtInsert #2-empty node (no value,no children)*)

qtInsert[qtree_, pt_] /; emptyNode[qtree] := value[qtree] = pt

(*qtInsert #2-currently a leaf (has a value and no children)*)

qtInsert[qtree_, pt_] /; isLeaf[qtree] := Module[
  {kids = splitBox[bounds[qtree]], currval = value[qtree]},
  value[qtree] = {};
  children[qtree] = kids;
  Map[(qtInsert[#, currval]; qtInsert[#, pt]) &, kids];
  ]

(*qtInsert #4-not a leaf and has children*)

qtInsert[qtree_, pt_] := Map[qtInsert[#, pt] &, children[qtree]];

getBoxes[ee_Bag] := 
 Join[{bounds[ee]}, Flatten[Map[getBoxes, children[ee]], 1]]
getPoints[ee_Bag] := 
 Join[{value[ee]}, Flatten[Map[getPoints, children[ee]], 1]]

qtDraw[qt_] := Module[
  {pts, bboxes},
  pts = getPoints[qt] /. {} :> Sequence[];
  bboxes = getBoxes[qt];
  Graphics[{EdgeForm[Black], Hue[0.2], Map[Disk[#, 0.01] &, pts], 
    Hue[0.7], EdgeForm[Red], 
    FaceForm[], (Rectangle @@ #) & /@ bboxes}, Frame -> True]]

这是一个例子。我会注意到缩放是合理的。也许O（n log（n））左右。绝对优于O（n ^ 2）。

len = 4000;
pts = RandomReal[{0, 2}, {len, 2}];
qt = makeQuadTreeNode[{{0.0, 0.0}, {2.0, 2.0}}];
Timing[Do[qtInsert[qt, pts[[i]]], {i, 1, len}]]

{1.6, Null}

---

一般expr包便条。这些都是旧的所以我并没有声称这一切仍然按照指示工作。

这些功能存在于内部`上下文中。

袋     创建一个expr包，可选择使用预设元素。

BagPart     获得expr包的部分，类似于普通的部分 exprs。也可用于lhs，例如重置一个值。

StuffBag     将元素附加到包的末尾。

我们还有一个BagLength。用于迭代一个包。

由于两个原因，这些功能非常有用。

首先，这是一个制作可扩展表的好方法 的Mathematica。

其次，对袋子的内容进行评估，然后放入 原始的expr，因此被屏蔽。因此可以使用这些作为 “指针”（在C意义上）而不是作为对象，而这一点 不需要等等。以下是一些例子：

a = {1,2,a} (* gives infinite recursion *)

如果我们改用袋子，我们会得到一种自我参照结构。

In[1]:= AppendTo[$ContextPath, "Internal`"];

In[2]:= a = Bag[{1,2,a}]
Out[2]= Bag[<3>]

In[3]:= expr1 = BagPart[a, All]
Out[3]= {1, 2, Bag[<3>]}

In[4]:= expr2 = BagPart[BagPart[a, 3], All]
Out[4]= {1, 2, Bag[<3>]}

In[5]:= expr1 === expr2
Out[5]= True

这很难在Mathematica中以任何其他方式效仿。 在某些情况下，需要使用稀疏表（散列） 不太透明的方式。

这是一个相关的示例，未完全调试。我们基本上 实现链接列表，从而可以破坏性地修改 尾巴，替换子列表等。

tail[ll_] := BagPart[ll,2]
settail[ll_, ll2_] := BagPart[ll,2] = ll2
contents[ll_] := BagPart[ll,1]
setcontents[ll_, elem_] := BagPart[ll,1] = elem

createlinkedlist[elems__] := Module[
    {result, elist={elems}, prev, el},
    result = Bag[{elist[[1]],Bag[]}];
    prev = result;
    Do [el = Bag[{elist[[j]],Bag[]}];
        settail[prev, el];
        prev = el,
        {j,2,Length[elist]}];
    result
    ]

In[18]:= tt = createlinkedlist[vv,ww,xx]
Out[18]= Bag[<2>]

In[20]:= BagPart[tt,All]
Out[20]= {vv, Bag[<2>]}

所以tt是一个链表，第一个元素是vv，下一个是 本身是一个链表，等等。我没有使用Lisp 术语（汽车/司机等），因为我无法做到 回想一下Lisp的列表操作是否具有破坏性。但 你得到了一般的想法。

沿着类似的路线，我使用了expr包来实现二进制文件 树木。这很有用，因为我们可以进行破坏性的改变 恒定时间（假设我们已经有了一个“句柄” 插入/删除），以及expr的“原始”性质 bag意味着我们完全避免了Mathematica的无限评估 语义。

也许是另一个应用程序。

Pointer = Internal`Bag
Contents[aa_Pointer, j_Integer] /;0<j<=Internal`BagLength[aa] :=
    Internal`BagPart[aa,j]
SetContents[aa_Pointer, j_Integer, e_] /; 0<j<=Internal`BagLength[aa] :=
    Internal`BagPart[aa,j] = e
SetContents[aa_Pointer, j_Integer, e_] /; j>BagLength[aa] :=
    (Do[Internal`StuffBag[aa,Null], {k,Internal`BagLength[aa]+1,j-1}];
    Internal`StuffBag[aa,e])

尝试

a = Bag[{1,2,a,6,t,y,99,Bag[{a,q,3,r,a,5,t}]}]
expr1 = BagPart[a, All]
expr2 = BagPart[BagPart[a, 3], All]

Contents[a, 4]
SetContents[a, 7, Contents[a,7]+5]
SetContents[a,11,33]

---

Daniel Lichtblau Wolfram Research

Answer 2

这是一个更紧凑的版本。它使用与原始版本相同的数据结构。函数splitBox和insideBox基本上是相同的（只是以稍微不同的方式编写）。

初始框不包含逐个添加的点，而是包含开头的所有点，因此不需要qtInsert例程。在每个递归步骤中，包含多个点的框被拆分，并且这些点分布在子框上。这意味着具有多个点的所有节点都是叶子，因此不需要检查它。

qtMakeNode[bb_, pts_] := {{}, {}, {}, {}, qtbb @@ bb, pts}

splitBox[bx_] := splitBox[{min_, max_}] := {min + #, max + #}/2 & /@  
  Tuples[Transpose[{min, max}]]


insideBox[pt_, bb_] := bb[[1, 1]] <= pt[[1]] <= bb[[2, 1]] && 
  bb[[1, 2]] <= pt[[2]] <= bb[[2, 2]]

distribute[qtree_] := Which[
  Length[qtree[[6]]] == 1, 
    (* no points in node -> return node unchanged *)
  qtree,

  Length[qtree[[6]]] == 1, 
    (* one point in node -> replace head of point with qtpt and return node *)
  ReplacePart[qtree, 6 -> qtpt @@ qtree[[6, 1]]],

  Length[qtree[[6]]] > 1, 
    (* multiple points in node -> create sub-nodes and distribute points *)
    (* apply distribute to sub-nodes *) 
  Module[{spl = splitBox[qtree[[5]]], div, newtreelist},
   div = Cases[qtree[[6]], a_ /; insideBox[a, #], 1] & /@ spl;
   ReplacePart[qtree, 
    Join[Table[i -> distribute[qtMakeNode[spl[[i]], div[[i]]]], {i, 4}], 
      {6 -> {}}]]]]

示例（使用qtDraw的原始版本）：

len = 50;
pts = RandomReal[{0, 2}, {len, 2}];
qt = makeTree[qtMakeNode[{{0.0, 0.0}, {2.0, 2.0}}, pts]];
qtDraw[qt]

结果：

Answer 3

这可能不是你想要做的，但是Nearest []可以创建一个内置四叉树结构的NearestFunction []。