PureBasic Forums - English

Code: Select all

Macro DefeatThis(a,b)
  If a>b
      a=b
  EndIf
EndMacro
Macro BeatThis(a,b)
  If b>a
      a=b
  EndIf
EndMacro




Structure PointD
  x.d
  y.d
EndStructure

Macro CopyPoint(cpp1,cpp2)
  cpp2\x=cpp1\x
  cpp2\y=cpp1\y
EndMacro

Macro SwapPoints(spp1,spp2)
  slave.PointD
  slave\x = spp1\x
  spp1\x = spp2\x
  spp2\x = slave\x
  
  slave\y = spp1\y
  spp1\y = spp2\y
  spp2\y = slave\y
EndMacro




Procedure.b ComputePolygonCentroid(points.i,Array vertex.PointD(1),*centroid.PointD)
  signedArea.d = 0
  x0 = 0; Current vertex X
  y0 = 0; Current vertex Y
  x1 = 0; Next vertex X
  y1 = 0; Next vertex Y
  a = 0 ;  Partial signed area
  
  ; for all points except last
  For i = 1 To points-1
    x0 = vertex(i)\x
    y0 = vertex(i)\y
    x1 = vertex(i+1)\x
    y1 = vertex(i+1)\y
    a = x0*y1 - x1*y0
    signedArea + a
    *centroid\x + (x0 + x1)*a
    *centroid\y + (y0 + y1)*a
  Next
  
  ; do last vertex
  x0 = vertex(points)\x
  y0 = vertex(points)\y
  x1 = vertex(1)\x
  y1 = vertex(1)\y
  a = x0*y1 - x1*y0
  signedArea + a
  *centroid\x + (x0 + x1)*a
  *centroid\y + (y0 + y1)*a
  
  signedArea * 0.5
  *centroid\x / (6*signedArea)
  *centroid\y / (6*signedArea)
EndProcedure




Structure CHPointD
  x.d
  y.d
  d.d
EndStructure

Procedure.d ccw(*p1.CHPointD, *p2.CHPointD, *p3.CHPointD)
  ProcedureReturn ((*p2\x - *p1\x)*(*p3\y - *p1\y)) - ((*p2\y - *p1\y)*(*p3\x - *p1\x))
EndProcedure

Procedure.i ComputeConvexHull(pnts.i,Array opnt.PointD(1),Array chpnt.PointD(1))
  Dim tempchpnt.CHPointD(pnts)
  For a = 1 To pnts
    CopyPoint(opnt(a),tempchpnt(a))
  Next
  
  SortStructuredArray(tempchpnt(), #PB_Sort_Descending, OffsetOf(CHPointD\y), TypeOf(CHPointD\y), 1, pnts)
  
  ; polar angle between all points with pnt(1) ... stored in \d
  For a = 2 To pnts
    tempchpnt(a)\d = ATan2(tempchpnt(1)\y - tempchpnt(a)\y, tempchpnt(1)\x - tempchpnt(a)\x)
  Next
  
  ;sort points by polar angle With pnt(1)
  SortStructuredArray(tempchpnt(), #PB_Sort_Descending, OffsetOf(CHPointD\d), TypeOf(CHPointD\d), 2, pnts)
  
  ; We want pnt[0] to be a sentinel point that will stop the loop
  tempchpnt(0)\x=tempchpnt(pnts)\x : tempchpnt(0)\y=tempchpnt(pnts)\y
  
  ; M will denote the number of points on the convex hull
  M = 1
  For i = 2 To pnts
    ; Find next valid point on convex hull
    While ccw(tempchpnt(M-1), tempchpnt(M), tempchpnt(i)) <= 0
      If M > 1
        M - 1
        Continue
        ; All points are collinear
      Else
        If i = pnts
          Break
        Else
          i + 1
        EndIf
      EndIf
    Wend
    
    ; Update M and Swap pnt[i] to the correct place
    M + 1
    SwapPoints( tempchpnt(M) , tempchpnt(i) )
  Next i
  
  
  Dim chpnt(M)
  For p = 1 To M
    CopyPoint(tempchpnt(p),chpnt(p))
  Next p
  
  ProcedureReturn M
EndProcedure




Procedure.d DegreeAngleBetweenTwoPoints(*o.PointD,*b.PointD)
  calcAngle.d = Degree(ATan2(*b\x-*o\x,*b\y-*o\y))
  If calcAngle<0
    calcAngle = 360-Abs(calcAngle)
  EndIf
  ProcedureReturn calcAngle
EndProcedure


Procedure.b DegreeRotatePointAroundPoint(*p.PointD,*rc.PointD,degrees.d,*np.PointD)
  radia.d = Radian(degrees)
  *np\x = *rc\x + ( Cos(radia) * (*p\x - *rc\x) - Sin(radia) * (*p\y - *rc\y) )
  *np\y = *rc\y + ( Sin(radia) * (*p\x - *rc\x) + Cos(radia) * (*p\y - *rc\y) )
EndProcedure




Procedure.d ComputeSmallestBoundingBox(pnts.i,Array pnt.PointD(1),Array perimrect.PointD(1))
  
  Dim hullpnt.PointD(pnts)
  chpnts.i = ComputeConvexHull(pnts,pnt(),hullpnt())
  
  ComputePolygonCentroid(chpnts,hullpnt(),@cd.PointD)
  
  smallest_area.d = 99999999
  smallest_deg.d = 0
  ReDim perimrect(4)
  
  For s = 1 To chpnts
    s2=s+1 : If s=chpnts : s2=1 : EndIf
    deg.d = DegreeAngleBetweenTwoPoints(@hullpnt(s),@hullpnt(s2))
    
    xmin.d = 99999999
    ymin.d = 99999999
    xmax.d = -99999999
    ymax.d = -99999999
    
    ; rotate all points...
    Dim rotpnt.PointD(chpnts)
    For rs = 1 To chpnts
      DegreeRotatePointAroundPoint(@hullpnt(rs),@cd,-deg,@rotpnt(rs))
      DefeatThis(xmin,rotpnt(rs)\x)
      DefeatThis(ymin,rotpnt(rs)\y)
      BeatThis(xmax,rotpnt(rs)\x)
      BeatThis(ymax,rotpnt(rs)\y)
    Next rs
    
    this_area.d = (xmax-xmin) * (ymax-ymin)
    If this_area<smallest_area
      smallest_area = this_area
      smallest_deg = deg
      
      perimrect(1)\x=xmin : perimrect(1)\y=ymin
      perimrect(2)\x=xmax : perimrect(2)\y=ymin
      perimrect(3)\x=xmax : perimrect(3)\y=ymax
      perimrect(4)\x=xmin : perimrect(4)\y=ymax
    EndIf
  Next s
  
  For r = 1 To 4
    DegreeRotatePointAroundPoint(@perimrect(r),@cd,smallest_deg,@np.PointD)
    CopyPoint(np,perimrect(r))
  Next r
  ProcedureReturn smallest_deg
  
EndProcedure




iw = 1600
ih = 800
win = OpenWindow(#PB_Any,0,0,iw,ih,"Minimum Perimeter Rectangle",#PB_Window_ScreenCentered)
cnv = CanvasGadget(#PB_Any,0,0,iw,ih)
space=5
AddKeyboardShortcut(win,#PB_Shortcut_Space,space)
esc=6
AddKeyboardShortcut(win,#PB_Shortcut_Escape,esc)


Repeat
  pnts = Random(20,5)
  Dim pnt.PointD(pnts)
  For p = 1 To pnts
    pnt(p)\x = Random(iw*0.7,iw*0.3)
    pnt(p)\y = Random(ih*0.8,ih*0.2)
  Next p
  
  Dim rotpnt.PointD(4)
  deg.d = ComputeSmallestBoundingBox(pnts,pnt(),rotpnt())
  rpnts=4
  
  
  StartDrawing(CanvasOutput(cnv))
  Box(0,0,OutputWidth(),OutputHeight(),#Black)
  
  For p = 1 To pnts
    Circle(pnt(p)\x,pnt(p)\y,5,#Red)
  Next p
  
  For p = 1 To rpnts
    p2=p+1 : If p=rpnts : p2=1 : EndIf
    LineXY(rotpnt(p)\x,rotpnt(p)\y,rotpnt(p2)\x,rotpnt(p2)\y,#Green)
  Next p
  
  StopDrawing()
  
  Repeat : Until WaitWindowEvent(5)=#PB_Event_Menu
  If EventMenu()=esc : Break : EndIf
ForEver