PureBasic Forums - English

Posted: **Fri Oct 22, 2010 10:45 pm**

I made crossplatform filled polygons. They are a bit slow, but they work, and the code is readable. Feel free to speed it up if you understand why it's slow.

Code: Select all


Structure Pt
  x.i
  y.i
EndStructure

Structure PtPair
  A.Pt
  B.Pt
EndStructure

Structure PtPairSlopeCache Extends PtPair
  yperx.d
EndStructure

Procedure MaxI(A, B)
  If A > B
    ProcedureReturn A
  EndIf
  ProcedureReturn B
EndProcedure

Procedure MinI(A, B)
  If A < B
    ProcedureReturn A
  EndIf
  ProcedureReturn B
EndProcedure

; Return the x of a line for a given y
Macro LineX(y, Line)
  (line\yperx * (y-Line\A\y) + Line\A\x)
EndMacro

; Whether a ray like this crosses a line segment
;  |-------------------->
; *a is the topmost point (smallest y), *b is the lowest point
Procedure XRayCrossesLine(x, y, *Line.PtPairSlopeCache)
  If y <= *line\A\y
    ProcedureReturn 0
  ElseIf y > *line\B\y
    ProcedureReturn 0
  ElseIf LineX(y, *Line) > x
    ProcedureReturn 1
  Else
    ProcedureReturn 0
  EndIf
EndProcedure

; Make sure *a\y < *b\y
Procedure CorrectPointOrder(*a.pt, *b.pt)
  If *a\y > *b\y
    Swap *a\x, *b\x
    Swap *a\y, *b\y
  EndIf
EndProcedure

; Precalc line slope
Procedure.d Slope(*a.pt, *b.pt)
  dx.i = (*b\x-*a\x)
  dy.i = (*b\y-*a\y)
  ProcedureReturn dx/dy
EndProcedure

; Make the lines conform to expectations
Procedure PrepLines(List Lines.PtPairSlopeCache())
  ForEach Lines()
    CorrectPointOrder(Lines()\A, Lines()\B)
    Lines()\yperx = Slope(Lines()\A, Lines()\B)
  Next
EndProcedure

; Convert a list of points into a list of lines
Procedure GetPolyLines(List Poly.pt(), List Lines.PtPairSlopeCache())
  FirstElement(Poly())
  Prev.pt = Poly()
  While NextElement(Poly())
    AddElement(Lines())
    Lines()\A = Prev
    Lines()\B = Poly()
    Prev = Poly()
  Wend
  ; Connect last point to first
  AddElement(lines())
  lines()\A = Prev
  FirstElement(Poly())
  lines()\B = Poly()
  ; Prep lines
  PrepLines(Lines())
EndProcedure

Procedure PtInPoly(x, y, List Lines.PtPairSlopeCache())
  Protected Intersections = 0
  FirstElement(Lines())
  ForEach Lines()
    Intersections + XRayCrossesLine(x, y, @Lines())
  Next
  ProcedureReturn Intersections & 1
EndProcedure

Procedure GetPolyExtents(List Poly.Pt(), *TopLeft.Pt, *BtmRight.Pt)
  ForEach Poly()
    *TopLeft\x = MinI(*TopLeft\x, Poly()\x)
    *TopLeft\y = MinI(*TopLeft\y, Poly()\y)
    *BtmRight\x = MaxI(*BtmRight\x, Poly()\x)
    *BtmRight\y = MaxI(*BtmRight\y, Poly()\y)
  Next
EndProcedure

Procedure FillPolygonWithCache(xoff, yoff, List Poly.Pt(), List Lines.PtPairSlopeCache(), color)
  GetPolyExtents(Poly(), TopLeft.Pt, BtmRight.Pt)
  w = BtmRight\x - TopLeft\x
  h = BtmRight\y - TopLeft\y
  For x = TopLeft\x To w
    For y = TopLeft\y To h
      If PtInPoly(x, y, Lines())
        Plot(x+xoff, y+yoff, color)
      EndIf
    Next
  Next
EndProcedure

Procedure FillPolygon(xoff, yoff, List Poly.Pt(), color=255)
  Protected NewList Lines.PtPairSlopeCache()
  GetPolyLines(Poly(), Lines())
  FillPolygonWithCache(xoff, yoff, Poly(), Lines(), color)
EndProcedure

Procedure OutlinePolygonWithCache(xoff, yoff, List Poly.Pt(), List Lines.PtPairSlopeCache(), color)
  ForEach Lines()
    LineXY(Lines()\A\x + xoff, Lines()\A\y + yoff, Lines()\B\x + xoff, Lines()\B\y + yoff, color)
  Next
EndProcedure

Procedure OutlinePolygon(xoff, yoff, List Poly.Pt(), color=0)
  Protected NewList Lines.PtPairSlopeCache()
  GetPolyLines(Poly(), Lines())
  OutlinePolygonWithCache(xoff, yoff, Poly(), Lines(), color)
EndProcedure

Procedure RenderPolygon(xoff, yoff, List Poly.Pt(), FillColor=255, OutlineColor=0)
  Protected NewList Lines.PtPairSlopeCache()
  GetPolyLines(Poly(), Lines())
  FillPolygonWithCache(xoff, yoff, Poly(), Lines(), FillColor)
  OutlinePolygonWithCache(xoff, yoff, Poly(), Lines(), OutlineColor)
EndProcedure

;- Test code:

Procedure MyPatternPainter(x, y, src, target)
  r = 255-(((x/4)&1) | ((y/4)&1))*255
  ProcedureReturn RGB(r, x*y, r)
EndProcedure

OpenWindow(0, 0, 0, 512, 384, "", #PB_Window_SystemMenu | #PB_Window_ScreenCentered | #PB_Window_SizeGadget)

Macro AddPt(l, _x, _y)
  AddElement(l)
  l\x = _x
  l\y = _y
EndMacro

NewList rect.pt()

AddPt(rect(), 10, 10)
AddPt(rect(), 125, 15)
AddPt(rect(), 120, 100)
AddPt(rect(), 15, 90)

NewList Star.Pt()
AddPt(Star(), 0, 13)
AddPt(Star(), 15, 13)
AddPt(Star(), 20, 0)
AddPt(Star(), 25, 13)
AddPt(Star(), 40, 13)
AddPt(Star(), 27, 22)
AddPt(Star(), 32, 35)
AddPt(Star(), 20, 27)
AddPt(Star(), 7, 35)
AddPt(Star(), 12, 22)

ForEach Star()
  Star()\x = Star()\x * 4 + 130
  Star()\y = Star()\y * 4 + 30
Next


w = 512
h = 384
CreateImage(0, w, h, 24)
t = ElapsedMilliseconds()
StartDrawing(ImageOutput(0))
  Box(0, 0, w, h, RGB(255, 255, 255))
  
  ; Show our box
  RenderPolygon(0, 0, rect(), RGB(255, 128, 32), RGB(128, 64, 16))
  
  ; Advanced: gradient fill (of star)
  DrawingMode(#PB_2DDrawing_Gradient)
  CircularGradient(200, 100, 100)
  RandomSeed(63)
  For I = 0 To 20
    GradientColor(I/20, RGB(Random(255), Random(255), Random(255)))
  Next
  FillPolygon(0, 0, star())
  DrawingMode(#PB_2DDrawing_Default)
  OutlinePolygon(0, 0, Star())
  
  ; Advanced: pattern fill (with custom callback)
  DrawingMode(#PB_2DDrawing_CustomFilter)
  CustomFilterCallback(@MyPatternPainter())
  FillPolygon(0, 200, rect())
  DrawingMode(#PB_2DDrawing_Default)
  OutlinePolygon(0, 200, rect(), RGB(0, 255, 0))

  
StopDrawing()
t = ElapsedMilliseconds()-t
; MessageRequester("", Str(t))

ImageGadget(0, 0, 0, 0, 0, ImageID(0))

Repeat
  Event = WaitWindowEvent()
Until Event = #PB_Event_CloseWindow

Posted: **Fri Oct 22, 2010 11:21 pm**

The sample is not slow on my WinXP PC - all three items are rendered in an instant.

Posted: **Sat Oct 23, 2010 12:05 am**

Instantaneous on my Mac! Well, actually t=471...

Posted: **Sat Oct 23, 2010 1:01 am**

Takes its time on (my Laptop) Linux - wavering between e.g. t=839 ... 1163

thanks for sharing

cheers ~ Vera

Posted: **Sat Oct 23, 2010 1:11 am**

t < 16
looks good

Posted: **Sat Oct 23, 2010 10:19 am**

Instantaneous on my Mac! Well, actually t=471...

Takes its time on (my Laptop) Linux - wavering between e.g. t=839 ... 1163

Try without the debugger. It should be around 32 for William and 100 for Vera. The debugger is slowing it down tremendously.

Posted: **Sat Oct 23, 2010 10:30 am**

Very nice.

Using a high resolution timer I end up ~14.2-14.8 msec om a 2.4 GHz C2D laptop with on-board graphics.
That is not slow for me, especially considering that you use gradient filling.

Posted: **Sat Oct 23, 2010 12:20 pm**

Trond wrote:Try without the debugger.

That reduces it down to average 'round t=140 [117 - 167] (on 1.5 GHz monocore)

btw: now I got why you used a messagebox, and next time I'll understand it as a hint

Posted: **Sat Oct 23, 2010 12:22 pm**

Using hires timing and no debugger I'm getting avg. 2.6 milliseconds execution time. This with crappy onboard video on a cheap computer. Nice work!

Posted: **Sat Oct 23, 2010 5:06 pm**

Damn, I forgot to turn off the Debugger...

So I turn off the debugger and it crashes.

(yeah, it's a Mac)

Rem out these lines and I get a 5 but no polygons. The Purifier doesn't put any messages in the PBEditorOutput box... and it runs fine (because the debugger is on). See note two lines down...

Code: Select all

Procedure FillPolygon(xoff, yoff, List Poly.Pt(), color=255)
;   Protected NewList Lines.PtPairSlopeCache() ; <<< un-rem this line and crash!
;   GetPolyLines(Poly(), Lines())
;   FillPolygonWithCache(xoff, yoff, Poly(), Lines(), color)
EndProcedure

Procedure OutlinePolygonWithCache(xoff, yoff, List Poly.Pt(), List Lines.PtPairSlopeCache(), color)
  ForEach Lines()
    LineXY(Lines()\A\x + xoff, Lines()\A\y + yoff, Lines()\B\x + xoff, Lines()\B\y + yoff, color)
  Next
EndProcedure

Procedure OutlinePolygon(xoff, yoff, List Poly.Pt(), color=0)
;   Protected NewList Lines.PtPairSlopeCache()
;   GetPolyLines(Poly(), Lines())
;   OutlinePolygonWithCache(xoff, yoff, Poly(), Lines(), color)
EndProcedure

Procedure RenderPolygon(xoff, yoff, List Poly.Pt(), FillColor=255, OutlineColor=0)
;   Protected NewList Lines.PtPairSlopeCache()
;   GetPolyLines(Poly(), Lines())
;   FillPolygonWithCache(xoff, yoff, Poly(), Lines(), FillColor)
;   OutlinePolygonWithCache(xoff, yoff, Poly(), Lines(), OutlineColor)
EndProcedure

Posted: **Sat Oct 23, 2010 5:18 pm**

Can't make it crash here, but I'm on Windows. You're on Mac, right? See if the purifier is happy.

Posted: **Sun Oct 24, 2010 7:18 am**

Works good here Trond on my crappy old laptop with xp home 256ram and 32meg stealing graphics.
Displays in less than a second.

Posted: **Fri Oct 29, 2010 7:59 pm**

I needed something like this, great work and thank you.

PureBasic Forums - English

Filled polygons

Filled polygons

Re: Filled polygons

Re: Filled polygons

Re: Filled polygons

Re: Filled polygons

Re: Filled polygons

Re: Filled polygons

Re: Filled polygons

Re: Filled polygons

Re: Filled polygons

Re: Filled polygons

Re: Filled polygons

Re: Filled polygons