一个Tcl程序的优化

一个工作中的问题，同事写了程序解决。

问题：两组矩形，找出在另一组中有重叠的矩形。

故事的最初是同事提到Pyton版本的程序比Tcl版本的程序快上百倍。自己觉得中间一定有问题，于是研究了一下。

A single spark can start a prairie fire.

数学模型

bbox             = {$llx $lly $urx $ury}
bbox_list        = [$bbox_1, $bbox_2, ... , $bbox_n]
sorted_bbox_list = sort bbox by $llx, $lly, $urx, $ury

数据概览

一些结论：

• 函数内联的效果还是很明显的。应该是省去了函数调用入栈、出栈的开销。
• 算法很重要
• 整数运算和浮点数运算（这里主要是比大小）的差别不大，整数运算只是略微快一些。
• I/O输出耗费时间不少
• 整数和浮点数的字符串输出占用的时间差别还是很大的

四叉树可以看作是动态大小的Grid Cell，并以Tree的方式进行检索。

Grid Cell方法则是固定的Grid Cell大小，借助hash table进行检索。

如果不能使用hash table的方法来检索，很可能需要一个sorted set来进行查询，或者用四叉树进行索引。

版本 0: 排序列表，双循环，比较函数

proc cmp_bbox {icv_bbox icc_bbox} {
  foreach {in1_x1 in1_y1 in1_x2 in1_y2} $icv_bbox break
  foreach {in2_x1 in2_y1 in2_x2 in2_y2} $icc_bbox break
  if {$in2_x1>=$in1_x2} {
    return -1
  } elseif {$in2_x2<=$in1_x1 || $in2_y2<=$in1_y1 || $in2_y1>=$in1_y2} {
    return 0
  } else {
    return 1
  }
}

proc diff_bbox_list_0 {icv_bboxs icc_bboxs} {
    timer mark

    set i 0
    foreach icv_bbox $icv_bboxs { 
      incr i
      set found 0
      set j 0
      foreach icc_bbox $icc_bboxs {
        incr j

        set flag [cmp_bbox $icv_bbox $icc_bbox]
        if {$flag<0} {
          break
        } elseif {$flag==0} {
          continue
        } else {
          set found 1
        }
      }
      puts "LUT COUNT: ($i $j) $found"
    }
    timer "end while"
}

版本 1: 排序列表，双循环，inline比较函数

... 
        foreach {in2_x1 in2_y1 in2_x2 in2_y2} $icc_bbox break
        if {$in2_x1>=$in1_x2} {
          break
          #return 2
        } elseif {$in2_x2<=$in1_x1 || $in2_y2<=$in1_y1 || $in2_y1>=$in1_y2} {
          continue
        } else {
          set found 1
        }
...

版本 2: 排序列表，双循环，跳头跳尾，foreach循环

proc diff_bbox_list_2 {icv_bboxs icc_bboxs} {
    timer mark

    set list2_head 0
    ... ...
      set max_urx -12345678
      foreach icc_bbox $icc_bboxs {
        incr j
        if {$j<=$list2_head} continue

        foreach {in2_x1 in2_y1 in2_x2 in2_y2} $icc_bbox break

        set max_urx [expr {max($in2_x2,$max_urx)}]
        if {$max_urx<=$in1_x1} {
          set list2_head [expr {$j+1}]    ;#   SKIP all bbox outside left side
        }
        ... ...
}

版本 2-1: 排序列表，双循环，跳头跳尾，for循环

   ...
   for {set j $list2_head ; set n [llength $icc_bboxs]} {$j<$n} {incr j} {
      ...
   }
   ...

版本 3: Grid Cell

proc diff_bbox_list_3 {icv_bboxs icc_bboxs {max 0x7fffffff}} {
    timer mark

    set  gcell_size 1000
    set  gcell_size $::env(GCELL_SIZE) ;# 1000
    set i 0
    foreach bbox $icv_bboxs {
      foreach {llx lly urx ury} $bbox break
      set gx1 [expr {int($llx/$gcell_size)}] ; set gy1 [expr {int($lly/$gcell_size)}]
      set gx2 [expr {int($urx/$gcell_size)}] ; set gy2 [expr {int($ury/$gcell_size)}]

      for {set gx $gx1} {$gx<=$gx2} {incr gx} {
        for {set gy $gy1} {$gy<=$gy2} {incr gy} {
          lappend gcells1($gx,$gy) $i
        }
      }
      incr i
    }
    timer "end grc 1"
    set i 0
    foreach bbox $icv_bboxs {
      set icv_bbox $bbox
      foreach {llx lly urx ury} $bbox break
      set gx1 [expr {int($llx/$gcell_size)}]; set gy1 [expr {int($lly/$gcell_size)}]
      set gx2 [expr {int($urx/$gcell_size)}]; set gy2 [expr {int($ury/$gcell_size)}]
      set bbox_idxs ""
      for {set gx $gx1} {$gx<=$gx2} {incr gx} {
        for {set gy $gy1} {$gy<=$gy2} {incr gy} {
          foreach {gxy bboxs} [array get gcells2 "$gx,$gy"] break
          set bbox_idxs [concat $bbox_idxs $bboxs]
        }
      }
      set idxs [lsort -uniq $bbox_idxs]
      set j    [llength $idxs]
      set found 0
      set found_bbox {}
      foreach idx $idxs {
        set icc_bbox [lindex $icc_bboxs $idx]
        foreach {llx2 lly2 urx2 ury2} $icc_bbox break
        if {!($llx2>=$urx || $urx2<=$llx || $ury2<=$lly|| $lly2>=$ury)} {
          # match
          set found 1
          set found_bbox $icc_bbox
        }
      }
      incr i
      puts "LUT COUNT: ($i $j) $found {$icv_bbox} {$found_bbox}"
    }

    timer "end while"
}

网络资源

• Quadtree @ WikiPedia
• QuadTree implementation in JavaScript