PureBasic

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