(En fait..j'y connais rien en 3D)
Je pense que ce code de EINANDER "mérite" le forum français à plusieurs titres
http://www.purebasic.fr/english/viewtop ... 32#p348832
Code : Tout sélectionner
#SquaredShape=0
#RhombShape=1
EnableExplicit
Define i,wi,he, ev,Fon,Img,ImGad
Global _FastMode=#False ; less fun if set to #True
Global _drawing
DisableDebugger ; with debugger on, slow drawing
Macro MMK
Abs(GetAsyncKeyState_(#VK_LBUTTON) +GetAsyncKeyState_(#VK_RBUTTON)*2+GetAsyncKeyState_(#VK_MBUTTON)*3)/$8000
EndMacro
Procedure CAux(Array Arr.Point(1),X,Y,A,B,Rgb,N)
If Point(X,Y)=RGB And Point(A,B)<>Rgb
Arr(N)\X=x : Arr(N)\Y=y
N+1
EndIf
ProcedureReturn N
EndProcedure
Procedure Outline(Array Arr.Point(1),Img,Rgb=0,Rhomb=0)
;ret Arr con outline de rgb
Protected I,X,Y,N
Protected Iwi=ImageWidth(Img)-2
Protected Ihe=ImageHeight(Img)-2
Dim arr(iwi*ihe)
For X=1 To Iwi
For y=1 To Ihe
If Rhomb=1 Or (Rhomb=2 And 1&Y) ; if Odd(y)
N=CAux(Arr(),X,Y,X-1,Y ,Rgb,N) ; left
N=CAux(Arr(),X,Y,X ,Y-1,Rgb,N) ; top
N=CAux(Arr(),X,Y,X+1,Y ,Rgb,N) ; right
N=CAux(Arr(),X,Y,X ,Y+1,Rgb,N) ; bottom
EndIf
If Rhomb=0 Or (Rhomb=2 And Not(1&Y)) ; if Even(Y)
N=CAux(Arr(),X,Y,X-1,Y-1,Rgb,N) ; left top
N=CAux(Arr(),X,Y,X-1,Y+1,Rgb,N) ; left bottom
N=CAux(Arr(),X,Y,X+1,Y-1,Rgb,N) ; top right
N=CAux(Arr(),X,Y,X+1,Y+1,Rgb,N) ; bottom right
EndIf
Next
Next
ReDim arr(n-1)
EndProcedure
;Test it <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
Procedure BallDraw(img,imgad,X,Y,Array Arr.Point(1),Rgb1,Rgb2,Radius)
Protected I,X1,Y1,R2=Radius/2,ev
If _Fastmode
DrawingMode(#PB_2DDrawing_Gradient)
FrontColor(Rgb2) : BackColor(Rgb1)
For I=0 To ArraySize(Arr())-1
X1=Arr(I)\X : Y1=Arr(I)\Y
LinearGradient(X1-R2,Y1-R2,X1+R2,Y1+R2)
Circle(X1,Y1,Radius)
Next
Else
While Mmk:WindowEvent():Wend
For I=0 To ArraySize(Arr())-1
If GetAsyncKeyState_(27)&$8000 : End : EndIf
WindowEvent()
If Mmk :Break:EndIf ; stop drawing and return if left mouse click
If _Drawing:StopDrawing():EndIf
_Drawing=StartDrawing(ImageOutput(Img))
DrawingMode(#PB_2DDrawing_Gradient)
FrontColor(Rgb2) : BackColor(Rgb1)
X1=Arr(I)\X : Y1=Arr(I)\Y
LinearGradient(X1-R2,Y1-R2,X1+R2,Y1+R2)
Circle(X1,Y1,Radius)
StopDrawing():_Drawing=0
SetGadgetState(Imgad,ImageID(Img))
Next
EndIf
EndProcedure
Procedure TestDraw(img,imgad,rgb1,rgb2,radius)
Protected RGB,j
Dim arr.point(0)
_drawing=StartDrawing(ImageOutput(Img))
Outline(arr(),Img,0,#RhombShape) ; try #SquaredShape <<<<<<<<<<
RGB=Random(#White)
balldraw(img,imgad,arr(j)\x,arr(j)\y,arr(),rgb1,rgb2,radius)
StopDrawing():_drawing=0
SetGadgetState(Imgad,ImageID(Img))
EndProcedure
OpenWindow(0, 100, 100,1000,320 ,"Get Outline _ Double click on Close Window to Quit", #PB_Window_SystemMenu |1)
Wi=WindowWidth(0):He=WindowHeight(0)
Fon=LoadFont(-1,"times new roman",70) ; try different fonts and sizes
Img=CreateImage(-1,Wi,He)
Imgad=ImageGadget(-1,0,0,0,0,ImageID(Img))
StartDrawing(ImageOutput(Img))
DrawingFont(FontID(Fon))
DrawingMode(#PB_2DDrawing_Outlined)
DrawText(100,90,"P u r e B a s i c",Random(#White),0)
StopDrawing()
SetGadgetState(Imgad,ImageID(Img))
testdraw(img,imgad,#Yellow,$55,6) ; last parameter= radius: small values or very slow drawing
Repeat
ev= WaitWindowEvent(1)
If i<10
testdraw(img,imgad,Random(#White),Random(#White),i)
i+1
SetWindowTitle(0,Str(i))
EndIf
Until ev=#PB_Event_CloseWindow
