Für getrennte Polygone habe ich mal was gemacht, allerdings unkommentiert und nicht optimiert :
Code: Alles auswählen
;
; Autor : alter Mann
; Datum : 11.11.08
;
; Demo zum Erzeugen von Grafikumrissen
;
#Image1 = 1
#Window = 2
#ImageGad = 3
#Button1 = 4
#Text = 7
#Button2 = 8
#MaxX = 800
#MaxY = 600
#MaxAnz = 1000
#Timer = 111
#Time = 20
#BIT0 = 1
#BIT1 = 2
#BIT2 = 4
#BIT3 = 8
Prototype.i fPixelTest(wPosX.w,wPosY.w,wAnzX.w,wAnzY.w,*lBild.l)
Structure STRECKE
wX1.w
wY1.w
wX2.w
wY2.w
wK.w
EndStructure
Structure PIXEL
bRed.b
bGreen.b
bBlue.b
EndStructure
Structure PIXELIDX
wX.w
wY.w
EndStructure
Structure PIXELKONTUR
wAnz.w
List sPixel.PIXELIDX()
EndStructure
Structure PIXELBEREICH
wAnz.w
List sKontur.PIXELKONTUR()
EndStructure
Global sBereich.PIXELBEREICH
Procedure.i iAbs (iWert.i)
If iWert < 0
ProcedureReturn -iWert
EndIf
ProcedureReturn iWert
EndProcedure
Procedure DrawLine(lX1.l,lY1.l,lX2.l,lY2.l,lR.l,lF.l)
Protected lX.l, lY.l, lH.l, lT.l, lA.l, lD.l
Circle(lX1,lY1,lR,lF)
If lX1=lX2 And lY1=lY2
ProcedureReturn
EndIf
If iAbs(lX1-lX2) > iAbs(lY1-lY2)
lD = lX2-lX1
If lX1>lX2
For lX=lX1-1 To lX2 Step -1
lH = (lX-lX1)*(lY2-lY1)
lT = (lH % lD) << 1
If lT<lD
lY = lY1 + lH / lD - 1
Else
lY = lY1 + lH / lD
EndIf
Circle(lX,lY,lR,lF)
Next lX
Else
For lX=lX1+1 To lX2 Step 1
lH = (lX-lX1)*(lY2-lY1)
lT = (lH % lD) << 1
If lT>lD
lY = lY1 + lH / lD + 1
Else
lY = lY1 + lH / lD
EndIf
Circle(lX,lY,lR,lF)
Next lX
EndIf
Else
lD = lY2-lY1
If lY1>lY2
For lY=lY1-1 To lY2 Step -1
lH = (lY-lY1)*(lX2-lX1)
lT = (lH % lD) << 1
If lT<lD
lX = lX1 + lH / lD - 1
Else
lX = lX1 + lH / lD
EndIf
Circle(lX,lY,lR,lF)
Next lY
Else
For lY=lY1+1 To lY2 Step 1
lH = (lY-lY1)*(lX2-lX1)
lT = (lH % lD) << 1
If lT>lD
lX = lX1 + lH / lD + 1
Else
lX = lX1 + lH / lD
EndIf
Circle(lX,lY,lR,lF)
Next lY
EndIf
EndIf
EndProcedure
Procedure Umriss(wAnzX.w, wAnzY.w, *lBild.l, *pFunction.fPixelTest)
Protected i.w,j.w
Protected iAnzP.i = 0
Protected Dim bRand.b(wAnzX,wAnzY)
For i=0 To wAnzY-1 Step 1
For j=0 To wAnzX-1 Step 1
If *pFunction(j,i,wAnzX,wAnzY,*lBild) = #True
bRand(j,i) = (#BIT0|#BIT1|#BIT2|#BIT3)
iAnzP + 1
If j>0 And (bRand(j-1,i) & #BIT1) = #BIT1
bRand(j ,i) & ~#BIT3
bRand(j-1,i) & ~#BIT1
EndIf
If i>0 And (bRand(j,i-1) & #BIT2) = #BIT2
bRand(j,i ) & ~#BIT0
bRand(j,i-1) & ~#BIT2
EndIf
EndIf
Next j
Next i
Protected Dim sStr.STRECKE(2*wAnzX*wAnzY+wAnzX+wAnzY)
Protected iAnzS.i = 0
For i=0 To wAnzY-1 Step 1
For j=0 To wAnzX-1 Step 1
If (bRand(j,i) & #BIT0) = #BIT0
sStr(iAnzS)\wX1 = j
sStr(iAnzS)\wY1 = i
sStr(iAnzS)\wX2 = j+1
sStr(iAnzS)\wY2 = i
sStr(iAnzS)\wK = 0
iAnzS + 1
EndIf
If (bRand(j,i) & #BIT1) = #BIT1
sStr(iAnzS)\wX1 = j+1
sStr(iAnzS)\wY1 = i
sStr(iAnzS)\wX2 = j+1
sStr(iAnzS)\wY2 = i+1
sStr(iAnzS)\wK = 0
iAnzS + 1
EndIf
If (bRand(j,i) & #BIT2) = #BIT2
sStr(iAnzS)\wX1 = j+1
sStr(iAnzS)\wY1 = i+1
sStr(iAnzS)\wX2 = j
sStr(iAnzS)\wY2 = i+1
sStr(iAnzS)\wK = 0
iAnzS + 1
EndIf
If (bRand(j,i) & #BIT3) = #BIT3
sStr(iAnzS)\wX1 = j
sStr(iAnzS)\wY1 = i+1
sStr(iAnzS)\wX2 = j
sStr(iAnzS)\wY2 = i
sStr(iAnzS)\wK = 0
iAnzS + 1
EndIf
Next j
Next i
SortStructuredArray(sStr(),#PB_Sort_Ascending,OffsetOf(STRECKE\wX1),#PB_Sort_Word,0,iAnzS-1)
Protected Dim sStr1.STRECKE(iAnzS)
Protected k.i,iS.i=-1,iE.i, iAnz.i=1, iFind.i=0, iIdx.i=0
Protected wX0.w = sStr(0)\wX2
Protected wDx1.w=sStr(0)\wX2-sStr(0)\wX1,wDy1.w=sStr(0)\wY2-sStr(0)\wY1
Protected wDx2.w,wDy2.w,wDx3.w,wDy3.w,wW2.w,wW3.w
For k=0 To iAnzS Step 1
If sStr(k)\wX1 = wX0 And iS = -1
iS = k
ElseIf sStr(k)\wX1 > wX0
iE = k
Break
EndIf
Next k
sStr(0)\wK = 1
sStr1(0) = sStr(0)
While iFind < iAnzS
If sStr1(iAnz-1)\wX2 > wX0
iS = iE
While iE<iAnzS And sStr(iE)\wX1 = sStr1(iAnz-1)\wX2
iE + 1
Wend
wX0 = sStr1(iAnz-1)\wX2
ElseIf sStr1(iAnz-1)\wX2 < wX0
iE = iS
iS - 1
While iS>=0 And sStr(iS)\wX1 = sStr1(iAnz-1)\wX2
iS - 1
Wend
iS + 1
wX0 = sStr1(iAnz-1)\wX2
EndIf
iIdx = -1
wW2 = 4
For k=iS To iE-1
If sStr(k)\wK = 1
Continue
EndIf
If sStr(k)\wX1 = sStr1(iAnz-1)\wX2 And sStr(k)\wY1 = sStr1(iAnz-1)\wY2
wDx3 = sStr(k)\wX2 - sStr(k)\wX1
wDy3 = sStr(k)\wY2 - sStr(k)\wY1
wW3 = wDx1 * wDy3 - wDy1 * wDx3
If wW3 < wW2
iIdx = k
wW2 = wW3
wDx2 = wDx3
wDy2 = wDy3
EndIf
EndIf
Next k
If iIdx = -1 And sStr1(0)\wX1 = sStr1(iAnz-1)\wX2 And sStr1(0)\wY1 = sStr1(iAnz-1)\wY2
; Kontur geschlossen
sBereich\wAnz + 1
AddElement(sBereich\sKontur())
For k=0 To iAnz-1 Step 1
wDx1 = sStr1(k)\wX2 - sStr1(k)\wX1
wDy1 = sStr1(k)\wY2 - sStr1(k)\wY1
If wDx1 = 1 And wDy1 = 0
wDx2 = sStr1(k)\wX1
wDy2 = sStr1(k)\wY1
ElseIf wDx1 = 0 And wDy1 = 1
wDx2 = sStr1(k)\wX1-1
wDy2 = sStr1(k)\wY1
ElseIf wDx1 = -1 And wDy1 = 0
wDx2 = sStr1(k)\wX2
wDy2 = sStr1(k)\wY1-1
ElseIf wDx1 = 0 And wDy1 = -1
wDx2 = sStr1(k)\wX2
wDy2 = sStr1(k)\wY2
Else
EndIf
If sBereich\sKontur()\wAnz > 0 And sBereich\sKontur()\sPixel()\wX = wDx2 And sBereich\sKontur()\sPixel()\wY = wDy2
Continue
EndIf
sBereich\sKontur()\wAnz + 1
AddElement(sBereich\sKontur()\sPixel())
sBereich\sKontur()\sPixel()\wX = wDx2
sBereich\sKontur()\sPixel()\wY = wDy2
Next k
iAnz = 0
For k=0 To iAnzS-1 Step 1
If sStr(k)\wK = 0
sStr1(iAnz) = sStr(k)
sStr(k)\wK = 1
wX0 = sStr1(0)\wX2
iAnz + 1
iFind + 1
iS = -1
For j=0 To iAnzS-1 Step 1
If sStr(j)\wX1 = wX0 And iS = -1
iS = j
iE = iAnzS
ElseIf sStr(j)\wX1 > wX0
iE = j
Break
EndIf
Next j
Break
EndIf
Next k
If iAnz = 0
Break
EndIf
wDx1 = sStr1(0)\wX2 - sStr1(0)\wX1
wDy1 = sStr1(0)\wY2 - sStr1(0)\wY1
ElseIf iIdx >-1
sStr1(iAnz) = sStr(iIdx)
sStr(iIdx)\wK = 1
iAnz + 1
iFind + 1
wDx1 = wDx2
wDy1 = wDy2
Else
Break ; Fehler
EndIf
Wend
k = 0
EndProcedure
Procedure.i GetPixelFromImage (iImage.i, *lPixel.PIXEL)
If StartDrawing(ImageOutput(iImage))
Protected *bBuffer.b = DrawingBuffer()
Protected iPitch.i = DrawingBufferPitch()/SizeOf(PIXEL)
Protected iPixelFormat.i = DrawingBufferPixelFormat()
Protected iWidth.i = ImageWidth(iImage)
Protected iHeight.i = ImageHeight(iImage)
Protected *bBuffer2.b,*bBuffer3.b
Protected i.i
If iPixelFormat & #PB_PixelFormat_24Bits_RGB
StopDrawing()
ProcedureReturn 1
EndIf
If iPitch = iWidth
CopyMemory (*bBuffer,*lPixel,iWidth*iHeight*SizeOf(PIXEL))
ElseIf iPitch > iWidth
For i=0 To iHeight
CopyMemory (*bBuffer,*lPixel,iWidth*SizeOf(Long))
*bBuffer + iPitch*SizeOf(Long)
*lPixel + iWidth*SizeOf(Long)
Next i
Else
ProcedureReturn (2)
EndIf
StopDrawing()
SetGadgetState(#ImageGad,ImageID(1))
Else
ProcedureReturn (3)
EndIf
ProcedureReturn 0
EndProcedure
Procedure.i TestePixel (wX.w, wY.w, wAX.w, wAY.w, *lPix.PIXEL)
Protected lX.l = wX, lY.l = wY, lAX.l = wAX
*lPix + (lX + lY*lAX) * SizeOf(PIXEL)
If (*lPix\bGreen & $FF) = 255 And *lPix\bRed = 0 And *lPix\bBlue = 0
ProcedureReturn 1
EndIf
ProcedureReturn 0
EndProcedure
InitializeStructure(@sBereich,PIXELBEREICH)
Define iEvent.i
Define iAktion.i = 0
Define iDraw.i = #False
Define iTimer.i = -1
Define lX.l,lY.l,lX1.l,lY1.l
Define lR.l = 5
Define lF.l = RGB(0,255,0)
Define *lPixel.l
Define i.w,j.w
If CreateImage(#Image1,#MaxX,#MaxY,24) = 0
MessageRequester("Achtung!","Kann Image nicht erstellen")
End
EndIf
sBereich\wAnz = 0
If OpenWindow(#Window,0,0,#MaxX+10,#MaxY+55,"Cursor in Kontur",#PB_Window_ScreenCentered|#PB_Window_SystemMenu)
ImageGadget (#ImageGad, 5,10, #MaxX,#MaxY,ImageID(#Image1))
ButtonGadget(#Button1,5,#MaxY+20,50,25, "Neu")
TextGadget(#Text,65,#MaxY+25,100,30,"Zeichnen : aus")
ButtonGadget(#Button2,180,#MaxY+20,70,25, "Rand")
StartDrawing(ImageOutput(#Image1))
DrawingMode(#PB_2DDrawing_AllChannels)
Box(0,0,#MaxX,#MaxY,RGB(50,50,50))
StopDrawing()
SetGadgetState(#ImageGad,ImageID(#Image1))
Repeat
iEvent = WaitWindowEvent()
Select iEvent
Case #PB_Event_Gadget
Select EventGadget()
Case #ImageGad
If EventType() = #PB_EventType_LeftClick
iAktion = 1-iAktion
If iAktion = 1
AddWindowTimer(#Window,#Timer,#Time)
iTimer = #Timer
SetGadgetText(#Text,"Zeichnen : an")
Else
If iDraw = #False
lX = WindowMouseX(#Window)
lY = WindowMouseY(#Window)
EndIf
lX1 = WindowMouseX(#Window)
lY1 = WindowMouseY(#Window)
If lX1 > -1 And lY1 > -1
StartDrawing(ImageOutput(#Image1))
DrawLine(lX,lY,lX1,lY1,lR,lF)
StopDrawing()
SetGadgetState(#ImageGad,ImageID(#Image1))
EndIf
RemoveWindowTimer(#Window,#Timer)
iTimer = -1
SetGadgetText(#Text,"Zeichnen : aus")
iDraw = #False
EndIf
EndIf
Case #Button1
If iTimer = #Timer
RemoveWindowTimer(#Window,#Timer)
iTimer = -1
SetGadgetText(#Text,"Zeichnen : aus")
EndIf
StartDrawing(ImageOutput(#Image1))
Box(0,0,#MaxX,#MaxY,RGB(50,50,50))
StopDrawing()
SetGadgetState(#ImageGad,ImageID(#Image1))
iDraw = #False
Case #Button2
Define *fSuchePixel.fPixelTest = @TestePixel()
lX1 = ImageWidth(#Image1)
lY1 = ImageHeight(#Image1)
*lPixel = AllocateMemory(lX1*lY1*SizeOf(Long))
GetPixelFromImage (#Image1, *lPixel)
Umriss(lX1, lY1, *lPixel, *fSuchePixel)
If sBereich\wAnz>0
Debug sBereich\wAnz
StartDrawing(ImageOutput(#Image1))
ResetList(sBereich\sKontur())
While NextElement(sBereich\sKontur())
If sBereich\sKontur()\wAnz
ResetList(sBereich\sKontur()\sPixel())
NextElement(sBereich\sKontur()\sPixel())
lX1 = sBereich\sKontur()\sPixel()\wX
lY1 = ImageHeight(#Image1)-sBereich\sKontur()\sPixel()\wY-1
Debug lX1
Debug lY1
While NextElement(sBereich\sKontur()\sPixel())
LineXY(lX1,lY1,sBereich\sKontur()\sPixel()\wX,ImageHeight(#Image1)-sBereich\sKontur()\sPixel()\wY-1,RGB(255,0,0))
lX1 = sBereich\sKontur()\sPixel()\wX
lY1 = ImageHeight(#Image1)-sBereich\sKontur()\sPixel()\wY-1
Wend
Debug lX1
Debug lY1
ClearList(sBereich\sKontur()\sPixel())
EndIf
Wend
StopDrawing()
ClearList(sBereich\sKontur())
sBereich\wAnz = 0
SetGadgetState(#ImageGad,ImageID(#Image1))
EndIf
FreeMemory(*lPixel)
EndSelect
Case #PB_Event_Timer
If EventTimer() = #Timer
If iDraw = #False
lX = WindowMouseX(#Window)
lY = WindowMouseY(#Window)
EndIf
iDraw = #True
lX1 = WindowMouseX(#Window)
lY1 = WindowMouseY(#Window)
If lX1 > -1 And lY1 > -1
StartDrawing(ImageOutput(#Image1))
DrawLine(lX,lY,lX1,lY1,lR,lF)
StopDrawing()
lX = lX1
lY = lY1
SetGadgetState(#ImageGad,ImageID(#Image1))
EndIf
EndIf
EndSelect
Until iEvent = #PB_Event_CloseWindow
EndIf
CloseWindow(#Window)