virloop.pas

these are some texts and original program,they are very useful for transportation reserch.

    if (prjwidth> 0) and ((m_projectleft[i-1]+m_projectright[i-1])=0) then
    begin
      m_regionstart[m_regionnum]:=i;
    end;

    if (prjwidth=0) and ((m_projectleft[i-1]+m_projectright[i-1])> 0) then
    begin
      m_regionend[m_regionnum]:=i-1;
      inc(m_regionnum);
    end;
  end;

  prjwidth:=m_projectleft[m_btm]+m_projectright[m_btm];
  if prjwidth> 0 then
  begin
    m_regionend[m_regionnum]:=m_btm;
    inc(m_regionnum);
  end;
end;

procedure TVLoop.ReRegion();//在第一次确定的区域内再次投影，去除行人干扰
var
  i,j,k,ll,rr,top,btm:integer;
begin
  for k:=0 to m_objectnum-1 do
  begin
    ll:=m_objectarray[k].ll;
    rr:=m_objectarray[k].rr;

    for i:=m_objectarray[k].ii_t to m_objectarray[k].ii_b do
    begin
      m_projectleft[i]:=0;
      m_projectright[i]:=0;
      for j:=ll to (rr+ll)div 2 do
      begin
        if m_diff[i,j]=255 then inc(m_projectleft[i]);
      end;
      for j:=(rr+ll)div 2 to rr do
      begin
        if m_diff[i,j]=255 then inc(m_projectright[i]);
      end;
    end;

    top:=m_objectarray[k].ii_t;
    btm:=m_objectarray[k].ii_b;
    for i:=m_objectarray[k].ii_t to m_objectarray[k].ii_b do
    begin
      if (m_projectleft[i]+m_projectright[i])>0 then
      begin
        top:=i;
        break;
      end;
    end;

    for i:=m_objectarray[k].ii_b downto m_objectarray[k].ii_t do
    begin
      if (m_projectleft[i]+m_projectright[i])>round((m_objectarray[k].rr-m_objectarray[k].ll)*m_REREGIONWIDTH) then
      begin
        btm:=i;
        break;
      end;
    end;

    m_objectarray[k].ii_t:=top;
    m_objectarray[k].ii_b:=btm;
  end;
end;

procedure TVLoop.RegionMerge();//对距离很近的区域进行合并
var
  k:integer;
begin
  m_regionnum1:=0;
  if m_regionnum=0 then exit;
  
  m_regionstart1[0]:=m_regionstart[0];
  m_regionend1[0]:=m_regionend[0];

  for k:=1 to m_regionnum-1 do
  begin
    if (m_regionstart[k]-m_regionend1[m_regionnum1])<round((m_btm-m_top)*m_REGIONDISTANCE) then
    begin
      m_regionend1[m_regionnum1]:=m_regionend[k];
    end
    else
    begin
      inc(m_regionnum1);
      m_regionstart1[m_regionnum1]:=m_regionstart[k];
      m_regionend1[m_regionnum1]:=m_regionend[k];
    end;
  end;
  inc(m_regionnum1);
end;

procedure TVLoop.RegionFilter();//根据区域内的最大宽度对区域进行滤波，如果区域内的最大宽度过小，认为该区域不是车而是干扰，删除该区域
var
  i,k:integer;
  max,pos:integer;
begin
  m_regionnum:=0;

  for k:=0 to m_regionnum1-1 do
  begin
    max:=0;
    pos:=0;
    for i:=m_regionstart1[k] to m_regionend1[k] do
    begin
      if (m_projectleft[i]+m_projectright[i])>max then
      begin
        max:=m_projectleft[i]+m_projectright[i];
        pos:=i;
      end;
    end;

    if max>round((m_ra[pos]-m_la[pos])*m_PROJECTMAX) then
    begin
      m_regionstart[m_regionnum]:=m_regionstart1[k];
      m_regionend[m_regionnum]:=m_regionend1[k];
      inc(m_regionnum);
    end;
  end;
end;

procedure TVLoop.RegionPlace();//在区域内进行水平投影，从而确定物体的位置
var
  i,j,k,ll,rr:integer;
  projectnum:array [0..IMGWIDTH-1] of integer;
  start1,start2,end1,end2,length:integer;
begin
  for k:=0 to m_regionnum-1 do
  begin
    ll:=min(m_la[m_regionstart[k]],m_la[m_regionend[k]]);
    rr:=max(m_ra[m_regionstart[k]],m_ra[m_regionend[k]]);

    fillchar(projectnum,sizeof(projectnum),0);

    for j:=ll to rr do
    begin
      for i:=m_regionstart[k] to m_regionend[k] do
      begin
        if m_diff[i,j]=255 then inc(projectnum[j]);
      end;
    end;

    start1:=0;
    start2:=0;
    end1:=0;
    //end2:=0;
    length:=0;

    if projectnum[ll]>0 then start2:=ll;

    for j:=ll+1 to rr do
    begin
      if (projectnum[j]>0) and (projectnum[j-1]=0) then
      begin
        start2:=j;
      end;
      if (projectnum[j]=0) and (projectnum[j-1]>0) then
      begin
        end2:=j-1;
        if (end2-start2)>=length then
        begin
          start1:=start2;
          end1:=end2;
          length:=end2-start2;
        end;
      end;
    end;

    if projectnum[rr]>0 then
    begin
      end2:=rr;
      if (end2-start2)>=length then
      begin
        start1:=start2;
        end1:=end2;
        //length:=end2-start2;
      end;
    end;

    m_objectarray[k].ll:=start1;
    m_objectarray[k].rr:=end1;
    m_objectarray[k].ii_t:=m_regionstart[k];
    m_objectarray[k].ii_b:=m_regionend[k];
  end;
  m_objectnum:=m_regionnum;
end;

procedure TVLoop.Trace();//对象跟踪
var
  MatchMatrix:array of array of boolean;//匹配矩阵
  Listflg,objectflg:array of boolean;
  ACarObject:PCarObject;
  i,j,k,x:integer;
  matchnum:integer;
  listindexarray,objectindexarray:array of integer;
  AddCarArray:array [0..IMGHEIGHT div 2-1] of PCarObject;
  AddCarNum:integer;
  DivideList:TList;
begin
  AddCarNum:=0;
  DivideList:=nil;

  if (m_CarList.Count<>0) and (m_objectnum<>0) then
  begin
    setlength(MatchMatrix,m_CarList.Count,m_objectnum);
    //判断目标链中的对象和当前帧中的对象的匹配关系
    for i:=0 to m_CarList.Count-1 do
    begin
      for j:=0 to m_objectnum-1 do
      begin
        MatchMatrix[i,j]:=Ismatch(i,j);
      end;
    end;

    ////////////////////////////////////////////////////////////////////////////
    //对匹配矩阵进行扫描
    setlength(Listflg,m_CarList.Count);
    setlength(objectflg,m_objectnum);
    for i:=0 to m_CarList.Count-1 do Listflg[i]:=false;
    for j:=0 to m_objectnum-1 do objectflg[j]:=false;

    //首先按列进行扫描
    for j:=0 to m_objectnum-1 do
    begin
      if objectflg[j]=false then
      begin
        matchnum:=0;
        for i:=0 to m_CarList.Count-1 do
        begin
          if (MatchMatrix[i,j]) and (listflg[i]=false) then inc(matchnum);
        end;

        if matchnum=0 then
        begin
          //新增
          ACarObject:=add(j);
          if ACarObject<>nil then
          begin
            AddCarArray[AddCarNum]:=ACarObject;
            inc(AddCarNum);
          end;
          objectflg[j]:=true;
        end
        else if matchnum>1 then
        begin
          //合并
          setlength(listindexarray,matchnum);
          k:=0;
          for i:=0 to m_CarList.Count-1 do
          begin
            if (MatchMatrix[i,j]) and (Listflg[i]=false) then
            begin
              Listflg[i]:=true;
              listindexarray[k]:=i;
              inc(k);
            end;
          end;
          merge(listindexarray,j);
          objectflg[j]:=true;
          setlength(listindexarray,0);
        end;
      end;
    end;

    //按行进行扫描
    for i:=0 to m_CarList.Count-1 do
    begin
      if Listflg[i]=false then
      begin
        matchnum:=0;
        for j:=0 to m_objectnum-1 do
        begin
          if (MatchMatrix[i,j]) and (objectflg[j]=false) then inc(matchnum);
        end;

        if matchnum=0 then
        begin
          //删除或保留
          remove(i);
          Listflg[i]:=true;
        end
        else if matchnum=1 then
        begin
          //匹配
          for j:=0 to m_objectnum-1 do
          begin
            if (objectflg[j]=false) and (MatchMatrix[i,j]) then
            begin
              bijection(i,j);
              listflg[i]:=true;
              objectflg[j]:=true;
            end;
          end;
        end
        else
        begin
          //分裂
          setlength(objectindexarray,matchnum);
          k:=0;
          for j:=0 to m_objectnum-1 do
          begin
            if (objectflg[j]=false) and (MatchMatrix[i,j])then
            begin
              objectindexarray[k]:=j;
              inc(k);
              objectflg[j]:=true;
            end;
          end;
          listflg[i]:=true;
          DivideList:=divide(i,objectindexarray);
          if DivideList<>nil then
          begin
            for x:=0 to DivideList.Count-1 do
            begin
              AddCarArray[AddCarNum]:=DivideList.Items[x];
              inc(AddCarNum);
            end;
          end;
          setlength(objectindexarray,0);
        end;
      end;
    end;
    setlength(MatchMatrix,0,0);
    setlength(Listflg,0);
    setlength(objectflg,0);
    ////////////////////////////////////////////////////////////////////////////
  end
  else if (m_CarList.Count=0) and (m_objectnum<>0) then //新增
  begin
    for i:=0 to m_objectnum-1 do
    begin
      ACarObject:=add(i);
      if ACarObject<>nil then
      begin
        AddCarArray[AddCarNum]:=ACarObject;
        inc(AddCarNum);
      end;
    end;
  end
  else if (m_CarList.Count<>0) and (m_objectnum=0) then //删除或保留
  begin
    for i:=0 to m_CarList.Count-1 do remove(i);
  end
  else ;//都等于零时，不做操作

  for i:=0 to AddCarNum-1 do
  begin
    m_CarList.Add(AddCarArray[i]);
  end;

  m_CarList.Pack;
  if DivideList<>nil then DivideList.Free;
end;

function TVLoop.Ismatch(listindex:integer;objectindex:integer):boolean;//根据两个矩形的交集面积分别占两个矩形面积的百分比，确定是否匹配
var
  area1,area2,area3:integer;
  left,right,top,bottom:integer;
  rect1,rect2:TRect;
  ACarObject:PCarObject;
begin
  result:=false;
  ACarObject:=m_CarList.Items[listindex];
  rect1.Left:=ACarObject^.ObjectRecord[ACarObject^.FrameNum-1].ll+ACarObject^.vj;
  rect1.Right:=ACarObject^.ObjectRecord[ACarObject^.FrameNum-1].rr+ACarObject^.vj;
  rect1.Top:=ACarObject^.ObjectRecord[ACarObject^.FrameNum-1].ii_t+ACarObject^.vi;
  rect1.Bottom:=ACarObject^.ObjectRecord[ACarObject^.FrameNum-1].ii_b+ACarObject^.vi;

  //判断是否超出边界