PureBasic Forums - English

http://www.purebasic.com
https://www.purebasic.fr/english/

Get Outline

https://www.purebasic.fr/english/viewtopic.php?t=45738

Page 1 of 1

Get Outline

Posted: Sat Mar 12, 2011 10:40 pm
by einander

Code: Select all

#SquaredShape=0
#RhombShape=1
EnableExplicit
Define i,wi,he, ev,Fon,Img,ImGad

DisableDebugger ; with debugger on, slow drawing 
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 <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
;StartDrawing is inside loop to see the growing outline effect 
Procedure TestDraw(img,imgad)
   Protected RGB,j
   
   Dim arr.point(0)
   StartDrawing(ImageOutput(Img))
   Outline(arr(),Img,0,#RhombShape) ; try #SquaredShape <<<<<<<<<<
   RGB=Random(#White)
   For j=0 To ArraySize(arr())
      Plot(arr(j)\x,arr(j)\y,RGB)   
   Next
   StopDrawing()
   SetGadgetState(Imgad,ImageID(Img))
EndProcedure

OpenWindow(0, 100, 100,900,320 ,"Get Outline",    #PB_Window_SystemMenu  |1) 
Wi=WindowWidth(0):He=WindowHeight(0)
Fon=LoadFont(-1,"arial",80)
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(130,90,"Pure Basic",Random(#White),0)
StopDrawing()
SetGadgetState(Imgad,ImageID(Img))

Repeat 
   ev= WaitWindowEvent(1)
   If i<90
      testdraw(img,imgad)
      i+1
   EndIf
   
Until ev=#PB_Event_CloseWindow

Re: Get Outline

Posted: Sat Mar 12, 2011 10:54 pm
by Kwai chang caine
Nice :D
Thanks for sharing 8)

Re: Get Outline

Posted: Sun Mar 13, 2011 12:47 am
by IdeasVacuum
Very snazzy, I really like the #SquareShape option.

Re: Get Outline

Posted: Sun Mar 13, 2011 2:17 am
by einander
You're welcome :D
Here is the same with fake 3D:

Code: Select all

 #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

Re: Get Outline

Posted: Sun Mar 13, 2011 7:49 pm
by Kwai chang caine
EINANDER..splendid, merveillous, giant, awesome :shock:
Sometime numerous code of this forum have no equal word
My kingdom for 10% of your knowledge
Thanks a lot for sharing 8)

Re: Get Outline

Posted: Sun Mar 13, 2011 8:34 pm
by kenmo
Cool! You could do a lot of things with this.

I modified the coloring procedure to make a glowing border effect:

Code: Select all

#Glow       = 0.35        ; Vary from 0.0 to 1.0
#GlowColor  = $2040FF     ; Color in $BBGGRR format
#Thickness  = 90          ; Outline iterations
#Message    = "PureBasic" ; String to display


#SquaredShape=0
#RhombShape=1
EnableExplicit
Define i,wi,he, ev,Fon,Img,ImGad

DisableDebugger ; with debugger on, slow drawing
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 <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
;StartDrawing is inside loop to see the growing outline effect
Procedure TestDraw(img,imgad,i)
   Protected RGB,j
   
   Dim arr.point(0)
   StartDrawing(ImageOutput(Img))
   Outline(arr(),Img,0,#RhombShape) ; try #SquaredShape <<<<<<<<<<
   Define f.f = 1.0 - Pow((i / #Thickness), #Glow)
   RGB=RGB(Red(#GlowColor) * f, Green(#GlowColor) * f, Blue(#GlowColor) * f)
   For j=0 To ArraySize(arr())
      Plot(arr(j)\x,arr(j)\y,RGB)
   Next
   StopDrawing()
   SetGadgetState(Imgad,ImageID(Img))
EndProcedure

OpenWindow(0, 100, 100,900,320 ,"Get Outline",    #PB_Window_SystemMenu  |1)
Wi=WindowWidth(0):He=WindowHeight(0)
Fon=LoadFont(-1,"georgia",80,#PB_Font_Bold)
If (Not Fon)
  Fon=LoadFont(-1,"times",80,#PB_Font_Bold)
EndIf
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(150,90,#Message,$010101,0)
StopDrawing()
SetGadgetState(Imgad,ImageID(Img))

Repeat
   ev= WaitWindowEvent(1)
   If i<#Thickness
      testdraw(img,imgad,i)
      i+1
   EndIf
   
Until ev=#PB_Event_CloseWindow
[/size]

Re: Get Outline

Posted: Sun Mar 13, 2011 8:36 pm
by Nituvious
That is very cool! However, is this an intended feature that when you click the screen, or the screen loses focus that it begins redrawing the effect?

Re: Get Outline

Posted: Sun Mar 13, 2011 9:37 pm
by einander
@kcc: :D

@kenmo:
I think the code is useful for a lot of drawing tricks.
Also works well with images with transparent backgrounds, and for hand drawing.
Your glow effect looks nice :wink:

@Nituvious:
This is intended, to allow to quit the loop if you are tired of wait in case of slow drawing.
The code is only a test to show the Outline procedure.

@ All : Please upload here if any corrections or modifications.

Re: Get Outline

Posted: Mon Mar 14, 2011 12:41 am
by WilliamL
Works on the Mac with just a few changes. :)

Code: Select all

#SquaredShape=0
#RhombShape=1
#White=$FFFFFF
EnableExplicit
Define i,wi,he, ev,Fon,Img,ImGad

;DisableDebugger ; with debugger on, slow drawing 

Structure Point
    x.i
    y.i
EndStructure

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 <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
;StartDrawing is inside loop to see the growing outline effect 
Procedure TestDraw(img,imgad)
   Protected RGB,j
   
   Dim arr.point(0)
   StartDrawing(ImageOutput(Img))
   Outline(arr(),Img,0,#RhombShape) ; try #SquaredShape <<<<<<<<<<
   RGB=Random(#White)
   For j=0 To ArraySize(arr())
      Plot(arr(j)\x,arr(j)\y,RGB)   
   Next
   StopDrawing()
   SetGadgetState(Imgad,ImageID(Img))
EndProcedure

OpenWindow(0, 100, 100,900,320 ,"Get Outline",    #PB_Window_SystemMenu) 
Wi=WindowWidth(0):He=WindowHeight(0)
Fon=LoadFont(-1,"Arial",80)
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(130,90,"Pure Basic",Random(#White),0)
StopDrawing()
SetGadgetState(Imgad,ImageID(Img))

Repeat 
   ev= WaitWindowEvent(1)
   If i<90
      testdraw(img,imgad)
      i+1
   EndIf
   
Until ev=#PB_Event_CloseWindow

Re: Get Outline

Posted: Wed Mar 16, 2011 12:58 pm
by bembulak
:shock:
Wow, this really looks awesome!
All times are UTC+01:00
Page 1 of 1

Powered by phpBB® Forum Software © phpBB Limited