IdentifiantMot de passe
Loading...
Mot de passe oublié ?Je m'inscris ! (gratuit)

Sources PureBasic

Sources PureBasicConsultez toutes les sources

Nombre d'auteurs : 41, nombre de sources : 88, dernière mise à jour : 13 août 2011 

 
OuvrirSommaireImages

Pour les besoins d'un éditeur srod avait besoin d'inscrire un texte en lieu et place d'une image qui ne serait pas définie, etc.
Le texte est calculé de façon à occuper la diagonale de l'image manquante.

 
Sélectionnez
;Based on code by Bluid-fyte.

text$ = "NO IMAGE DEFINED!"

If OpenWindow(0, 0, 0, 600, 600, "",#PB_Window_SystemMenu|#PB_Window_ScreenCentered)

  ;Create an EMF to house the text.
    hdc = CreateEnhMetaFile_(0, 0, 0, 0)
    If hdc
      oldBrush = SelectObject_(hdc, GetStockObject_(#NULL_BRUSH))
      oldPen = SelectObject_(hdc, GetStockObject_(#WHITE_PEN))
      SetBkMode_(hdc, #TRANSPARENT)
      hFont = CreateFont_(100,55,450,0.0,0,0,0,0,0,0,0,0,0,"ARIAL")
      oldFont = SelectObject_(hdc, hFont)
      SetTextAlign_(hdc, #TA_LEFT|#TA_BOTTOM)
      BeginPath_(hdc)   
        TextOut_(hdc, 70, 510,text$, Len(text$))
      EndPath_(hdc)
      SelectObject_(hdc, oldFont)
      DeleteObject_(hFont)
      StrokeAndFillPath_(hdc)
      SelectObject_(hdc, oldPen)
      SelectObject_(hdc, oldBrush)
      hEMF = CloseEnhMetaFile_(hdc)
    EndIf

  width = WindowWidth(0)
  height = WindowHeight(0)

  ;Now an image gadget etc.
  If CreateImage(1, width, height, 24)
    hdc = StartDrawing(ImageOutput(1))
    If hdc
      SetRect_(rc.RECT, 0, 0, width,height)
      PlayEnhMetaFile_(hdc, hEMF, rc)
      StopDrawing() 
      ImageGadget(1, 0,0,0,0,ImageID(1))
    EndIf
  EndIf

  Repeat
    EventID = WaitWindowEvent()
  Until EventID = #PB_Event_CloseWindow

  DeleteEnhMetaFile_(hEMF)

EndIf
Créé le 15 mars 2009  par srod

Ce code permet de déformer une image.

 
Sélectionnez
;"Image Rotate, Pull, Reverse & Stretch"

Structure PointF :  X.f : Y.f : EndStructure
Structure FLEX
  pt.POINT
  Plg.POINT[4]
  Vertx.POINT[4]
  s1.f[4]
  S2.PointF[4]
EndStructure

 
Global __Clip ,__Hatch,__Rim
Global _Brush,_BrushRGB,_BrushStyle
Global _DRAWING,_Grid,_Mode
Global _MyFont10=FontID(LoadFont(-1,"Arial",10))
Global _OldBrush,_Pen,_PenRGB,_PenStyle,_ShowCornerNumbers=1,_Showflag=1
Global _X,_Xmax,_Xmin,_Y,_Ymax,_Ymin

Global Dim Color(0, 0)
Global Dim Grid.POINT(0, 0) 
Global _Flex.FLEX

Title$ = "Image Rotate, Pull, Reverse & Stretch"
   
UseJPEGImageDecoder()
UseJPEGImageEncoder()
UsePNGImageDecoder()
UsePNGImageEncoder()
UseTGAImageDecoder()
UseTIFFImageDecoder()
#DBLUE=$660000
#LBLUE=$FFFCC2
Enumeration
  #ImGad
  #IMG
  #IMG2
  #Open
  #SaveAs
  #CornerNumbers
  #Quit     
  #HorVer
  #Diag
  #Grid
  #GridIMG
EndEnumeration
 
Macro MMx :  WindowMouseX(EventWindow()) : EndMacro
Macro MMy :  WindowMouseY(EventWindow()) : EndMacro
Macro MMK
  Abs(GetAsyncKeyState_(#VK_LBUTTON) +GetAsyncKeyState_(#VK_RBUTTON)*2+GetAsyncKeyState_(#VK_MBUTTON)*3)/$8000   
EndMacro
 
Macro MouseOverGad ;- MouseOverGad : ret GadgetID under mouse
  WindowFromPoint_(MMx|MMy<<32)
EndMacro
 
Macro LoBound(A,B) :  If A<B :A=B:EndIf : EndMacro
Macro HiBound(A,B) :  If A>B :A=B:EndIf : EndMacro
 
Procedure InMousEX(X,Y,X1,Y1)
  SetRect_(rc.RECT,X,Y,X1,Y1)
  ProcedureReturn PtInRect_(@rc,MMx|MMy<<32)
EndProcedure

Procedure  EndClip() ;- EndClip
  SelectClipRgn_(_DRAWING, 0)
  DeleteObject_(__Clip)
EndProcedure
 
Procedure  Clip(X,Y,X1,Y1) ;- Clip(X,Y,X1,Y1)
  If __Clip:EndClip():EndIf
  __Clip = CreateRectRgn_(X,Y,X1,Y1)
  If __Clip : SelectClipRgn_(_DRAWING, __Clip)
  Else      : __Clip=0
  EndIf
EndProcedure
 
Macro STOPDRAW  ;- StopDraw
  If _DRAWING
StopDrawing() : _DRAWING=0: EndIf
EndMacro
 
Macro DrawIMG(IMG) ;- DrawIMG(IMG) ; #ImageOutput=2
  STOPDRAW
_DRAWING=StartDrawing(ImageOutput(IMG)) ;<
EndMacro
 
Procedure Min(A,B)
  If A<B:ProcedureReturn A:EndIf
  ProcedureReturn B
EndProcedure
 
Procedure  ClsImg(IMG,RGB=0) ;-ClsImg(IMG,RGB=0)
  DrawIMG(IMG)
  Box(0,0,ImageWidth(IMG),ImageHeight(IMG),RGB)
EndProcedure
 
 
Macro DelBrush()   ;-DelBrush()
  If _Brush :DeleteObject_(_Brush) :EndIf
  _Brush=0
  If _OldBrush : SelectObject_(_DRAWING, _OldBrush) : EndIf
  _BrushRGB=0
EndMacro
 
Procedure  Brush(BrushRGB,style=#BS_SOLID,Hatch=0)  ;- Brush(BrushRGB,Style=#BS_SOLID,Hatch=0) #BS_HOLLOW, #BS_PATTERN
  Protected L.LOGBRUSH
  DelBrush()
  L\lbStyle=style
  L\lbColor=BrushRGB
  L\lbHatch=Hatch
  _Brush = CreateBrushIndirect_(@L)
  _OldBrush=SelectObject_(_DRAWING,_Brush)
  _BrushRGB=BrushRGB
  _BrushStyle=style
  __Hatch=Hatch
EndProcedure 
   
Macro DelPen() ;- DelPen
  If _Pen: DeleteObject_(_Pen) :EndIf
  _Pen=0: _PenRGB=0:__Rim=0
EndMacro
 
Macro Pen(Rim=1, PenRGB=0,style=#PS_SOLID) ;-  Pen(Rim=1, PenRGB=0,style=#ps_solid)
  DelPen()
  If style=#NULL_PEN
    _Pen= SelectObject_(_DRAWING,GetStockObject_ ( #NULL_PEN ))
  Else
    _Pen=CreatePen_(style,Rim,PenRGB)   
    SelectObject_(_DRAWING,_Pen)
  EndIf
  __Rim=Rim
  _PenRGB=PenRGB
  _PenStyle=style
EndMacro
     
Procedure CenterTXT(X,Y,Wi,He,T.S) 
 
  Protected TextWidth=TextWidth(T),TextHeight=TextHeight(T)
  Protected X1=X+Wi,Y1=Y+He
  Clip(X,Y,X1,Y1)
  If TextWidth>Wi :  DrawText(X,(Y+Y1)/2-TextHeight/2 , T)
  Else :  DrawText((X+X1)/2-TextWidth/2, (Y1+Y)/2-TextHeight/2 , T)
  EndIf
  EndClip()
EndProcedure
 
Procedure  Corners() ;-  draw corners
  Protected i
  With _Flex
    DrawingFont(_MyFont10)
    FrontColor(#LBLUE):BackColor(#DBLUE)
    For i = 0 To 3
      Circle (\Vertx[i]\X , \Vertx[i]\Y, 9,#DBLUE)
      CenterTXT(\Vertx[i]\X-5,\Vertx[i]\Y-5,10,10,Str(i))
    Next
  EndWith
EndProcedure
   
Procedure Bounding() ;- Bounding()
  Protected i
  With _Flex
    _Xmax=0 : _Xmin=$FFFFFF:_Ymax=0:_Ymin=$FFFFFF
    For i = 0 To 3   
      HiBound(_Xmin,\Vertx[i]\X)
      LoBound(_Xmax,\Vertx[i]\X)
      HiBound(_Ymin,\Vertx[i]\Y)
      LoBound(_Ymax,\Vertx[i]\Y)
    Next
  EndWith
EndProcedure
 
Procedure  STP(A,B,C,D,E)  ;- STP(A,B,C,D,E)  - aux de Sizes
  With _Flex
    \s1[0]   = (\S2[A]\X - \S2[B]\X) / E
    \s1[1]   = (_Flex\Vertx[C]\X - _Flex\Vertx[D]\X) / E
    \s1[2]   = (\S2[A]\Y    - \S2[B]\Y)   / E
    \s1[3]   = (_Flex\Vertx[C]\Y - _Flex\Vertx[D]\Y) / E
  EndWith
EndProcedure
   
Procedure  Sizes()
  Protected i,j,A.f,B.f,C.f,D.f
  With _Flex
    ;  _Xmax = 0 : _Xmin = _X : _Ymax = 0 : _Ymin = _Y
    Bounding()
    \S2[0]\X = (\Vertx[1]\X - \Vertx[0]\X)  / \pt\X ; step X HOR TOP
    \S2[0]\Y = (\Vertx[1]\Y - \Vertx[0]\Y)  / \pt\X ; step Y HOR TOP
    \S2[1]\X = (\Vertx[2]\X - \Vertx[3]\X)  / \pt\X ; step X HOR BOTTOM
    \S2[1]\Y = (\Vertx[2]\Y - \Vertx[3]\Y)  / \pt\X ; step Y HOR BOTTOM
    \S2[2]\X = (\Vertx[3]\X - \Vertx[0]\X)  / \pt\Y ; step X VER LEFT
    \S2[2]\Y = (\Vertx[3]\Y - \Vertx[0]\Y)  / \pt\Y ; step Y VER LEFT
    \S2[3]\X = (\Vertx[2]\X - \Vertx[1]\X)  / \pt\Y ; step X VER RIGHT
    \S2[3]\Y = (\Vertx[2]\Y - \Vertx[1]\Y)  / \pt\Y ; step Y VER RIGHT
   
    STP(1,0,3,0,\pt\Y)
   
    For j = 0 To \pt\Y
      A=\S2[0]\X     +\s1[0]*j
      B=\Vertx[0]\X  +\s1[1]*j
      C=\S2[0]\Y     +\s1[2]*j
      D=\Vertx[0]\Y  +\s1[3]*j
      For i = 0 To \pt\X
        Grid(i,j)\X=A*i+B
        Grid(i,j)\Y=C*i+D
      Next
    Next
   
    STP(3,2,1,0,\pt\X)
   
    For j = 0 To \pt\X
      A=\S2[2]\X    +\s1[0]*j
      B=\Vertx[0]\X +\s1[1]*j
      C=\S2[2]\Y    +\s1[2]*j
      D=\Vertx[0]\Y +\s1[3]*j
      For i = 1 To \pt\Y
        Grid(j,i)\X=A*i+B
        Grid(j,i)\Y=C*i+D
      Next
    Next
  EndWith
EndProcedure 
   
Procedure FastGrid(Wi,He,StpX=24,StpY=-1,RGB=-1)
  If StpY=-1:StpY=StpX:EndIf
  If RGB=-1:RGB=$555555:EndIf
  For Y=0 To He
    LineXY(0,Y,Wi,Y,RGB)
    Y+StpY
  Next
  For X=0 To Wi
    LineXY(X,0,X,He,RGB)
    X+StpX   
  Next
EndProcedure
 
Macro InitGrid() ;- InitGrid()
  CreateImage(#GridIMG,_X,_Y)
  DrawIMG(#GridIMG)
  FastGrid(_X,_Y,30,30)
  STOPDRAW
EndMacro     
   
Procedure  FastImage() ;- Faster than ShowImage - ONLY POINTS to circumvent the Polygon drawing
  Static i,j,STP
  With _Flex
    If _Grid
      FreeImage(#IMG)
      GrabImage(#GridIMG,#IMG,0,0,_X,_Y)
      DrawIMG(#IMG)
    Else       
      DrawIMG(#IMG)
      ClsImg(#IMG)
    EndIf 
    If _ShowCornerNumbers : Corners() : EndIf
    STP=\pt\X/120  ; LONGER STP = QUICKER DRAWING 
    LoBound(STP,1)
    i=0
    Repeat   ; Increase Stp for slow processor
      j=0
      Repeat
        Box(Grid(i, j)\X, Grid(i, j)\Y,1,1, Color(i, j))
        j+STP
      Until j>=\pt\Y
      i+STP
    Until i>=\pt\X
    STOPDRAW
    SetGadgetState(#ImGad, ImageID(#IMG))
  EndWith
EndProcedure
     
Procedure  Polyg( Sides,*P,RGB=-1) ;P= array of POINT struc with polyg vertices ; sides >1
  If RGB>-1
    Pen(1,RGB):Brush(RGB)
  EndIf
  Polygon_(_DRAWING,*P,Sides) 
EndProcedure
     
Procedure ShowImage()
  Protected i,j,i2,j2
  With _Flex
    If _Grid
      FreeImage(#IMG)
      GrabImage(#GridIMG,#IMG,0,0,_X,_Y)
      DrawIMG(#IMG)
    Else       
      DrawIMG(#IMG)
      ClsImg(#IMG,0)
    EndIf 
    If _ShowCornerNumbers : Corners() : EndIf
   
    For i = 0 To \pt\X
      DrawIMG(#IMG)
     
      If MMK = 1 : _Showflag=0: ProcedureReturn : EndIf ;  show interruptus
      i2=i+1
      WindowEvent()
     
      For j = 0 To \pt\Y
        If j < \pt\Y And i < \pt\X
          j2=j+1
          \Plg[0]\X = Grid(i ,j )\X ;  Polygon positions
          \Plg[0]\Y = Grid(i ,j )\Y
          \Plg[1]\X = Grid(i2,j )\X
          \Plg[1]\Y = Grid(i2,j )\Y
          \Plg[2]\X = Grid(i2,j2)\X
          \Plg[2]\Y = Grid(i2,j2)\Y
          \Plg[3]\X = Grid(i ,j2)\X
          \Plg[3]\Y = Grid(i ,j2)\Y
          Pen(1,Color(i,j)):Brush(Color(i,j))
          Polyg(4,\Plg[0])
        Else
          Plot(Grid(i,j)\X, Grid(i,j)\Y, Color(i,j)) ; only 1 pixel for the last line
        EndIf
      Next
      If _ShowCornerNumbers : Corners() : EndIf
      STOPDRAW
      SetGadgetState(#ImGad,ImageID(#IMG))
    Next
  EndWith
EndProcedure
   
Procedure SaveImg(DefaultFile$="",Title.S="Save Image") ; Save Image
  Protected Flag, Pattern$ = "(*.bmp)|*.bmp|"   
  Pattern$ + "(*.jpg)|*.jpg|"   
  Pattern$ + "(*.png)|*.png|"   
  File$=SaveFileRequester("Please Choose The File Name To Save", DefaultFile$, Pattern$, 0)
  If File$
    If _ShowCornerNumbers
      Flag=1
      _ShowCornerNumbers = 0
    EndIf   
    If _Grid
      Flag+2
      _Grid=0
    EndIf
    If Flag : ShowImage()  : EndIf
   
    Select SelectedFilePattern()
      Case 0 : SaveImage(#IMG,File$,#PB_ImagePlugin_BMP)
      Case 1 : SaveImage(#IMG,File$,#PB_ImagePlugin_JPEG,10)
      Case 2 : SaveImage(#IMG,File$,#PB_ImagePlugin_PNG)
    EndSelect
    MessageRequester("","Saved to "+File$, #PB_MessageRequester_Ok)
  Else
    MessageRequester("","File Not Saved", #PB_MessageRequester_Ok)
  EndIf   
 
  If Flag=1 Or Flag=3:_ShowCornerNumbers=1:EndIf
  If Flag=2 Or Flag=3:_Grid=1:EndIf
  If Flag:ShowImage():EndIf
EndProcedure
   
Procedure$ GetLastDir(LastDirFile.S)
  Protected Temp= ReadFile(-1,GetTemporaryDirectory()+LastDirFile)
  If Temp
    LastDir.S=ReadString(Temp)
    CloseFile(Temp)
  EndIf   
  ProcedureReturn LastDir.S
EndProcedure
 
Procedure SetLastDir(LastDirFile.S,LastDir.S)  ;-SetLastDir - pone en TempDir
  Protected Temp
  DeleteFile(GetTemporaryDirectory()+LastDirFile)
  Temp=OpenFile(-1,GetTemporaryDirectory()+LastDirFile)
  If Temp
    WriteString(Temp,LastDir)
    CloseFile(Temp)
  EndIf
EndProcedure
 
Procedure LeeImg(*P.POINT)
  Protected StandardFile$
  Static IMG,hIMG
  If IsImage(IMG):FreeImage(IMG):EndIf
  If hIMG:DeleteDC_(hIMG):EndIf
  LastDirFile.S="EstiraLast"
  Pattern$ = "Images (*.bmp, *.jpg, *.png, *.tiff, *.tga)|*.bmp;*.jpg; *.png; *.tiff ; *.tga |All files (*.*)|*.*"
  StandardFile$=GetLastDir(LastDirFile)
  If StandardFile$=""
    StandardFile$ = "c:\" ; put here your image directory
  EndIf
  File$ = OpenFileRequester("Load Image", StandardFile$, Pattern$, Pattern)
  If File$
    StandardFile$=GetPathPart(File$)
    SetLastDir(LastDirFile,StandardFile$)
    hIMG = CreateCompatibleDC_(GetDC_(WindowID(0)))
    IMG = LoadImage(#PB_Any, File$,  #PB_Image_DisplayFormat)
    If ImageWidth(IMG)>_X
      ResizeImage(IMG,_X,ImageHeight(IMG))
    EndIf
    If ImageHeight(IMG)>_Y
      ResizeImage(IMG,ImageWidth(IMG),_Y)
    EndIf
    *P\X=ImageWidth(IMG):*P\Y=ImageHeight(IMG)
    SelectObject_(hIMG, ImageID(IMG))
    ProcedureReturn hIMG
  EndIf
EndProcedure
   
Procedure  Menu(Win=0) ;- Menu(win)
  Protected Menu= CreateMenu(-1, WindowID(Win))   
  MenuTitle("   File")
  MenuItem(#Open,"Open ")
  MenuBar()
  MenuItem(#SaveAs,"Save As")
  MenuBar()
  MenuItem(#Quit,"Quit")
  MenuTitle("   Options")
  MenuItem( #CornerNumbers, "Switch Corner Numbers")
  MenuBar()
  MenuItem(#Grid,"Switch Grid")
  ProcedureReturn Menu
EndProcedure
     
Procedure NewImage()
 Protected hIMG = LeeImg(@P.POINT) ,X,Y,CenterX,CenterYsz
  With _Flex
    If hIMG 
      \pt\X = P\X - 1 : \pt\Y = P\Y - 1
      Global Dim Color(\pt\X, \pt\Y)
      Global Dim Grid.POINT (\pt\X, \pt\Y )
      For X = 0 To \pt\X
        For Y = 0 To \pt\Y
          Color(X, Y) = GetPixel_(hIMG, X, Y)
        Next
      Next
      CenterX=_X/2:CenterY=_Y/2
      SZ=Min(_X,_Y)/10
      \Vertx[0]\X = CenterX-SZ
      \Vertx[0]\Y = CenterY-SZ
      \Vertx[1]\X = CenterX+SZ
      \Vertx[1]\Y = CenterY-SZ
      \Vertx[2]\X = CenterX+SZ
      \Vertx[2]\Y = CenterY+SZ
      \Vertx[3]\X = CenterX-SZ
      \Vertx[3]\Y = CenterY+SZ       
      Sizes() : ShowImage()
    EndIf
  EndWith
EndProcedure

Procedure GetDistance(A1,A2) ;- GetDistance(a1,a2)
  ProcedureReturn Sqr(A1*A1 + A2*A2)         
EndProcedure

Procedure Near(X,Y); X, Y, ArrSize, ARRAY P.POINT(1)) ; Return elem de Array de Points Nearest to  x,y
  Protected A,i,min
  With _Flex
    min = $FFFFFFF
    For i = 0 To 3
      A = GetDistance(X - \Vertx[i]\X, Y - \Vertx[i]\Y)
      If A < min : min = A : Near = i : EndIf
    Next i
    ProcedureReturn Near
  EndWith
EndProcedure

    ;<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
   
If  OpenWindow(0, 100, 100,600,400,Title$, #WS_OVERLAPPEDWINDOW | #WS_MAXIMIZE)
  SetWindowColor(0,0)
  StickyWindow(0,1)
 
  _X=WindowWidth(0):_Y=WindowHeight(0)
  Menu()   
  CreateImage(#IMG, _X,_Y,32)
  ImageGadget(#ImGad,0,0,0,0,ImageID(#IMG))
  SetWindowLongPtr_(GadgetID(#ImGad), -20, GetWindowLongPtr_(GadgetID(#ImGad), -20) | $2000000)
 
  InitGrid() : NewImage()
  With _Flex
   
    Repeat
      If GetAsyncKeyState_(#VK_ESCAPE) :  End:EndIf
     
      Ev = WaitWindowEvent(1)
      Select Ev
        Case #PB_Event_Menu
          Select EventMenu() ; To see which menu has been selected
            Case #Quit  : End
            Case #Open  :NewImage()
            Case #SaveAs:SaveImg()
            Case #CornerNumbers ;  switch corner numbers
              _ShowCornerNumbers = 1 -_ShowCornerNumbers 
              ShowImage() 
            Case #Grid
              _Grid=1-_Grid
              ShowImage()     
          EndSelect
        Case #PB_Event_SizeWindow
          _X=WindowWidth(0):_Y=WindowHeight(0)
          ShowImage()
        Default
          If Ev=#WM_MOUSEMOVE
            If MMK = 1
              If  InMousEX(1,1,_X-4,_Y-4)
                If Sel = 0
                  Near = Near(MMx,MMy)
                  Sel = 1
                EndIf
                _Showflag = 0
                \Vertx[Near]\X = MMx
                \Vertx[Near]\Y = MMy
                Sizes() :  FastImage()
              EndIf
            EndIf   
           
          EndIf 
          If MMK=0
            If _Showflag = 0 : _Showflag = 1 : ShowImage() : EndIf
            Sel = 0
          EndIf     
      EndSelect
    Until Ev = #PB_Event_CloseWindow
  EndWith
EndIf
End
Créé le 29 mars 2009  par einander

Le code qui suit comporte 2 exemples avec la fonction CustomFilterCallback(), l'appel se fait aux lignes 65, 66 :
- ;NoiseFilter() ; Supprimez le commentaire pour tester cette fonction
- PixelFilter() ; mettez cette ligne en commentaire pour tester la fonction ci dessus.

Le premier code est complet et permet de tester les 2 premiers effets, plus bas vous trouverez d'autres effets sous forme d'une procédure uniquement, vous pourrez prendre modèle sur le premier code pour les utiliser.

 
Sélectionnez
UsePNGImageDecoder()
Procedure NoiseFilterCallback(x, y, SourceColor, TargetColor)
   If (x+y)%5=0
      ProcedureReturn TargetColor
   EndIf
   xn=x-1+Random(2)
   yn=y-1+Random(2)
   If xn<0 Or xn>=OutputWidth() Or yn<0 Or yn>=OutputHeight()
      ProcedureReturn TargetColor
   EndIf
   ProcedureReturn Point(xn, yn)
EndProcedure
Procedure NoiseFilter()
   CustomFilterCallback(@NoiseFilterCallback())
EndProcedure

Procedure PixelFilterCallback(x, y, SourceColor, TargetColor)
   #pixelSize=5
   xn=#pixelSize*(x/#pixelSize)
   yn=#pixelSize*(y/#pixelSize)
   ProcedureReturn Point(xn, yn)
EndProcedure

Procedure PixelFilter()
   CustomFilterCallback(@PixelFilterCallback())
EndProcedure

If OpenWindow(0, 0, 0, 800, 600, "", #PB_Window_SystemMenu | #PB_Window_ScreenCentered)
   ; load purebasic logo
   CatchImage(100, ?TestImage)
   
   ; background layer
   If CreateImage(0, 800, 600, 32) And StartDrawing(ImageOutput(0))
         #box_size=7
         Box(0, 0, 800, 600, $FFFFFF)
         For y=0 To 600 Step #box_size*2
            For x=0 To 800 Step #box_size*2
               Box(x, y, #box_size, #box_size, $C0C0C0)
               Box(x+#box_size, y+#box_size, #box_size, #box_size, $C0C0C0)
            Next
         Next
         
         ; draw logo image
         For i=1 To 60
            DrawAlphaImage(ImageID(100), Random(800), Random(600))
         Next
         
      StopDrawing()
   EndIf
   
   ; drawing layer
   CreateImage(1, 800, 600, 32)
   
   SmartWindowRefresh(0, 1)
   ImageGadget(1, 0, 0, 0, 0, ImageID(1))
   Repeat
      e=WaitWindowEvent(0)
      If e=#PB_Event_ActivateWindow Or e=#WM_MOUSEMOVE
         StartDrawing(ImageOutput(1))
            ; draw background
            DrawImage(ImageID(0), 0, 0)
           
            ; draw gradient filter
            DrawingMode(#PB_2DDrawing_CustomFilter)
            ;NoiseFilter()
            PixelFilter()
            Circle(WindowMouseX(0), WindowMouseY(0), 100)
         StopDrawing()
         SetGadgetState(1, ImageID(1))
      EndIf
   Until e=#PB_Event_CloseWindow
EndIf

DataSection
   TestImage :
   Data.b $89, $50, $4E, $47, $0D, $0A, $1A, $0A, $00, $00, $00, $0D, $49, $48, $44, $52
   Data.b $00, $00, $00, $30, $00, $00, $00, $30, $08, $06, $00, $00, $00, $57, $02, $F9
   Data.b $87, $00, $00, $00, $09, $70, $48, $59, $73, $00, $00, $1C, $20, $00, $00, $1C
   Data.b $20, $01, $CD, $0F, $9B, $9E, $00, $00, $00, $07, $74, $49, $4D, $45, $07, $D6
   Data.b $0C, $1C, $15, $17, $0D, $B6, $53, $C9, $04, $00, $00, $0C, $9C, $49, $44, $41
   Data.b $54, $68, $DE, $D5, $99, $79, $8C, $5D, $D7, $5D, $C7, $3F, $E7, $9C, $7B, $EF
   Data.b $5B, $E6, $BD, $D9, $17, $CF, $E2, $78, $A9, $27, $09, $B6, $A2, $26, $71, $90
   Data.b $93, $8A, $2C, $60, $D2, $02, $6D, $54, $94, $96, $48, $24, $6D, $11, $55, $55
   Data.b $05, $A5, $40, $25, $4A, $04, $52, $A1, $82, $06, $A9, $8A, $10, $02, $A1, $A6
   Data.b $34, $40, $45, $CB, $2A, $0A, $51, $A0, $B4, $84, $2C, $4E, $52, $E3, $6C, $B6
   Data.b $C7, $F6, $64, $C6, $19, $7B, $16, $8F, $67, $5F, $DF, $BE, $DF, $77, $CF, $E1
   Data.b $8F, $7B, $66, $3C, $36, $89, $ED, $B1, $C7, $48, $1C, $E9, $E8, $5E, $DD, $27
   Data.b $BD, $FB, $FB, $9E, $DF, $F6, $FD, $FE, $AE, $62, $8B, $56, $4B, $3C, $2A, $9E
   Data.b $79, $F4, $A1, $96, $87, $F6, $DF, $D6, $11, $53, $2A, $32, $B6, $94, $52, $81
   Data.b $D6, $0E, $A0, $00, $B9, $61, $0B, $BB, $B9, $E4, $FE, $9A, $96, $D8, $22, $FB
   Data.b $C5, $F4, $23, $0F, $7E, $B9, $51, $D7, $FF, $D8, $F1, $5C, $29, $1C, $15, $18
   Data.b $29, $2B, $06, $72, $46, $90, $D1, $82, $4C, $A0, $C9, $D4, $B5, $49, $D7, $11
   Data.b $E9, $BA, $54, $99, $9A, $A3, $D2, $15, $A9, $D2, $45, $44, $2A, $A7, $4D, $7A
   Data.b $36, $5F, $4A, $1D, $3E, $37, $93, $7E, $73, $72, $B6, $70, $66, $25, $E5, $07
   Data.b $DA, $68, $60, $6D, $07, $F6, $7A, $63, $00, $9C, $79, $E2, $D1, $9B, $55, $A6
   Data.b $30, $50, $74, $DD, $06, $E3, $07, $18, $BF, $8E, $30, $06, $61, $C0, $51, $02
   Data.b $E5, $39, $38, $9E, $83, $F2, $5C, $1C, $C7, $C5, $95, $02, $19, $F8, $50, $2E
   Data.b $41, $AD, $82, $10, $E0, $7A, $11, $94, $E7, $82, $52, $B5, $74, $AE, $58, $D0
   Data.b $F9, $6A, $26, $55, $F5, $8F, $DC, $F9, $C3, $D7, $9E, $06, $E6, $81, $8C, $05
   Data.b $72, $D1, $72, $AE, $D7, $F8, $87, $6F, $DE, $A1, $A2, $E9, $FC, $B7, $A7, $CF
   Data.b $4F, $37, $68, $40, $1B, $83, $36, $60, $08, $37, $F6, $AA, $0D, $04, $1A, $02
   Data.b $6D, $D0, $08, $94, $1B, $C5, $69, $6A, $C2, $69, $6C, $42, $7A, $1E, $A2, $0A
   Data.b $C2, $57, $4C, $8D, $0C, $7A, $1D, $41, $AD, $75, $5F, $57, $57, $FC, $E1, $D7
   Data.b $DE, $01, $B8, $17, $78, $1D, $28, $DC, $10, $00, $7F, $76, $FF, $81, $2F, $2E
   Data.b $9C, $9D, $78, $C0, $6C, $74, $AB, $00, $63, $42, $F7, $5E, $78, $6E, $C2, $80
   Data.b $17, $20, $8D, $41, $FB, $15, $AA, $2B, $15, $CA, $2B, $4B, $61, $6C, $08, $45
   Data.b $C1, $D4, $89, $F9, $25, $F6, $DF, $B4, $DD, $FC, $C2, $91, $E3, $E9, $C9, $62
   Data.b $69, $9B, $B5, $B1, $F6, $7E, $C6, $63, $93, $EA, $9A, $D7, $D0, $AF, $3D, $BA
   Data.b $33, $37, $B3, $F0, $8D, $AA, $EF, $83, $31, $18, $13, $9A, $6B, $36, $A2, $31
   Data.b $1B, $1E, $08, $90, $02, $A4, $B4, $5B, $80, $14, $06, $25, $C0, $77, $14, $54
   Data.b $0A, $3C, $B0, $BD, $8F, $2F, $9D, $1A, $C9, $1F, $4B, $65, $97, $80, $53, $C0
   Data.b $00, $B0, $B8, $E5, $00, $6E, $EF, $68, $91, $D1, $E5, $D4, $B7, $B2, $D9, $6C
   Data.b $23, $18, $CC, $DA, $59, $6F, $30, $DE, $98, $0D, $BF, $58, $8F, $20, $D6, $C2
   Data.b $CB, $80, $08, $EF, $44, $43, $92, $62, $6E, $85, $7B, $BB, $B7, $F1, $17, $E7
   Data.b $E7, $4A, $FF, $3C, $35, $37, $0F, $BC, $03, $BC, $0C, $BC, $07, $14, $2F, $FE
   Data.b $E7, $2D, $00, $F0, $DC, $CF, $3F, $F0, $B9, $D4, $C2, $E2, $CF, $69, $63, $42
   Data.b $43, $0D, $18, $63, $CD, $5D, $F7, $C6, $C5, $EF, $34, $EF, $03, $D0, $4D, $B6
   Data.b $B0, $9C, $5A, $E4, $F6, $D6, $56, $4E, $94, $AB, $B5, $AF, $0D, $9D, $59, $02
   Data.b $4E, $00, $2F, $59, $0F, $64, $3F, $A8, $02, $61, $6B, $F4, $A6, $D7, $C0, $AF
   Data.b $7E, $AA, $A7, $3E, $33, $FF, $7C, $B1, $52, $89, $E9, $75, $E3, $2F, $24, $EE
   Data.b $7A, $F2, $1A, $61, $3D, $20, $2C, $B0, $8B, $81, $44, $92, $CD, $2C, $66, $D3
   Data.b $EC, $F0, $1C, $62, $8D, $8D, $C1, $27, $0F, $1F, $5D, $AE, $69, $3D, $08, $FC
   Data.b $27, $F0, $DF, $36, $74, $EA, $97, $B3, $65, $D3, $49, $BC, $2D, $1E, $95, $0D
   Data.b $CB, $A9, $3F, $9F, $CF, $64, $5B, $EB, $DA, $86, $87, $14, $08, $21, $C2, $E4
   Data.b $15, $62, $3D, $65, $8D, $08, $BD, $83, $30, $17, $9D, $BC, $30, $E0, $C5, $13
   Data.b $A4, $2A, $55, $9A, $B4, $4F, $7F, $4F, $AF, $B9, $FF, $D5, $37, $53, $85, $7A
   Data.b $7D, $14, $38, $04, $1C, $B1, $A5, $D3, $BF, $92, $3D, $9B, $06, $F0, $BD, $BB
   Data.b $6F, $DB, $51, $2A, $64, $9B, $DC, $98, $BB, $D4, $28, $44, $9B, $13, $68, $55
   Data.b $01, $7C, $24, $01, $10, $04, $9A, $7A, $50, $47, $23, $C2, $92, $23, $42, $4F
   Data.b $5C, $F4, $52, $2F, $42, $59, $45, $08, $52, $33, $7C, $64, $D7, $4E, $1E, $79
   Data.b $EB, $64, $F6, $5C, $A1, $34, $09, $FC, $D8, $EE, $F3, $B6, $F2, $DC, $90, $4E
   Data.b $DC, $00, $7C, $18, $F8, $B8, $14, $E2, $CE, $CE, $88, $D7, $D6, $1F, $75, $93
   Data.b $3B, $A3, $5E, $BC, $37, $EA, $C5, $BA, $63, $D1, $C8, $81, $F6, $D6, $86, $42
   Data.b $D5, $57, $75, $AD, $C1, $7A, $06, $04, $CA, $F5, $30, $DA, $40, $73, $27, $33
   Data.b $D3, $A3, $1C, $DC, $BE, $9D, $A7, $46, $27, $0B, $CF, $8E, $4D, $4E, $02, $AF
   Data.b $00, $CF, $DB, $F8, $CF, $7D, $50, $D2, $6E, $05, $00, $0F, $E8, $06, $3E, $64
   Data.b $AF, $4D, $76, $37, $02, $4D, $F7, $75, $B4, $DC, $FC, $F5, $5D, $7D, $3F, $5D
   Data.b $F1, $7D, $A9, $A5, $40, $08, $89, $10, $82, $68, $A2, $89, $B2, $72, $E9, $2E
   Data.b $67, $19, $CE, $64, $D8, $D7, $DE, $C1, $6B, $C5, $4A, $F9, $37, $8F, $0D, $CE
   Data.b $D8, $90, $79, $0E, $78, $13, $48, $5D, $2E, $69, $B7, $A2, $91, $F9, $C0, $1C
   Data.b $B0, $02, $44, $2C, $A0, $28, $10, $FB, $E8, $AE, $BE, $9D, $7F, $78, $53, $CF
   Data.b $F7, $D2, $B9, $9C, $34, $80, $D1, $06, $21, $34, $5E, $34, $46, $25, $92, $20
   Data.b $7D, $EE, $34, $BB, $3E, $B4, $C7, $FC, $D5, $E8, $54, $7E, $78, $7C, $2E, $B7
   Data.b $58, $A9, $AE, $00, $EF, $02, $2F, $DA, $7A, $9F, $DE, $8C, $F1, $D7, $0A, $C0
   Data.b $58, $10, $BE, $AD, $CF, $02, $E0, $B7, $EE, $DC, $1B, $FB, $62, $6F, $F7, $B3
   Data.b $53, $B3, $B3, $ED, $D2, $5A, $61, $0C, $08, $29, $50, $AD, $3D, $4C, $9F, $3D
   Data.b $C9, $DD, $BB, $76, $F3, $C4, $C0, $70, $EE, $D0, $D2, $EA, $14, $30, $04, $0C
   Data.b $5B, $00, $A7, $80, $A5, $0F, $6A, $56, $5B, $0A, $E0, $C4, $E7, $7F, $B1, $AF
   Data.b $AB, $BD, $E5, $EE, $B9, $7C, $31, $FF, $97, $C7, $4E, $9F, $FD, $F6, $D1, $A1
   Data.b $55, $A0, $FE, $1B, $7B, $76, $FE, $C9, $FC, $EC, $DC, $4F, $79, $9E, $8B, $D6
   Data.b $10, $18, $83, $36, $86, $78, $F7, $2E, $46, $CE, $BE, $CB, $BE, $BE, $3E, $7E
   Data.b $F7, $BD, $F1, $FC, $CB, $0B, $4B, $D3, $B6, $44, $FE, $97, $6D, $52, $CB, $96
   Data.b $E7, $F8, $D7, $52, $D2, $37, $95, $03, $23, $8F, $7C, $7C, $77, $9B, $E7, $9F
   Data.b $90, $E5, $5A, $A3, $17, $8B, $E2, $C6, $63, $A6, $8C, $9C, $AF, $69, $31, $5D
   Data.b $5C, $4E, $1D, $F0, $A5, $C0, $AF, $07, $54, $FD, $80, $7A, $60, $50, $89, $36
   Data.b $06, $C7, $DE, $A3, $29, $1E, $E5, $B9, $D5, $5C, $F1, $EF, $C7, $26, $D7, $8C
   Data.b $FF, $37, $DB, $69, $53, $F6, $D4, $CD, $B5, $36, $D4, $AB, $F6, $C0, $67, $77
   Data.b $F7, $39, $CD, $75, $FF, $AF, $4B, $42, $37, $CA, $B6, $26, $F2, $42, $11, $18
   Data.b $21, $02, $4D, $4F, $63, $26, $D7, $D3, $D8, $D5, $46, $60, $04, $D5, $9A, $4F
   Data.b $B9, $E2, $83, $8C, $71, $6C, $6C, $94, $93, $B3, $73, $2C, $B5, $75, $54, $FE
   Data.b $69, $6C, $72, $19, $38, $69, $3B, $EC, $80, $35, $BE, $7E, $BD, $64, $F2, $6A
   Data.b $01, $88, $A7, $EF, $D8, $F7, $EB, $C2, $D1, $0F, $44, $3D, $17, $53, $AD, $13
   Data.b $51, $06, $A9, $1C, $8C, $00, $A7, $B3, $05, $E5, $44, $08, $0C, $18, $E9, $10
   Data.b $C8, $18, $D3, $B9, $22, $AB, $E9, $15, $5A, $1C, $C5, $1D, $1E, $D1, $5F, $BE
   Data.b $7F, $7F, $B7, $1B, $8D, $DC, $E1, $41, $09, $6D, $92, $43, $99, $DC, $C9, $3F
   Data.b $38, $75, $76, $32, $5D, $F3, $2B, $36, $7C, $D6, $44, $8B, $D9, $F2, $10, $1A
   Data.b $FD, $D4, $47, $F7, $36, $4B, $73, $54, $C4, $9C, $B8, $11, $21, $9D, $14, $CA
   Data.b $41, $48, $85, $54, $0A, $A9, $1C, $84, $0A, $63, $BF, $EA, $07, $94, $CB, $3E
   Data.b $E5, $9A, $8F, $89, $46, $A9, $6B, $4D, $10, $F8, $54, $4A, $45, $74, $21, $4F
   Data.b $BC, $52, $A0, $39, $E2, $12, $73, $5C, $DC, $48, $24, $8F, $1B, $19, $79, $FC
   Data.b $E8, $D0, $D7, $BE, $3F, $39, $3B, $68, $2B, $5B, $75, $4B, $3D, $F0, $D4, $87
   Data.b $6F, $F6, $9A, $D1, $DF, $51, $31, $27, $AE, $37, $E2, $5E, $A3, $CE, $6B, $47
   Data.b $A6, $0D, $C6, $08, $04, $02, $29, $15, $AE, $32, $D4, $7D, $8D, $A7, $5C, $DC
   Data.b $68, $03, $AD, $8D, $9D, $18, $2F, $8A, $69, $68, $24, $9D, $5A, $62, $F0, $D8
   Data.b $6B, $EC, $4D, $36, $25, $FF, $71, $75, $31, $FA, $FD, $C9, $D9, $7B, $AC, $E1
   Data.b $45, $DB, $81, $AF, $DA, $0B, $57, $62, $A3, $E2, $0B, $3B, $7B, $9F, $54, $51
   Data.b $79, $E0, $82, $02, $17, $17, $5F, $4D, $C8, $8F, $D7, $08, $1D, $58, $5E, $24
   Data.b $25, $42, $48, $A4, $08, $29, $85, $90, $0A, $57, $3A, $88, $62, $85, $F1, $63
   Data.b $6F, $B0, $23, $12, $E7, $07, $D9, $42, $E9, $F7, $4F, $BD, $07, $D0, $62, $8D
   Data.b $DE, $DA, $32, $3A, $F1, $B1, $03, $B7, $47, $A4, $F9, $AA, $72, $54, $28, $0B
   Data.b $85, $C4, $08, $19, $1A, $27, $25, $88, $D0, $48, $83, $E4, $02, $7B, $5E, $23
   Data.b $76, $12, $69, $F9, $90, $10, $E1, $30, $A2, $5E, $0F, $38, $79, $FC, $75, $7A
   Data.b $84, $66, $C4, $50, $FB, $CA, $C0, $F0, $32, $70, $06, $78, $1B, $18, $03, $CA
   Data.b $9B, $CD, $81, $CB, $D2, $E9, $A9, $72, $35, $98, $C9, $E5, $53, $A3, $4B, $E9
   Data.b $F6, $7A, $D5, $4F, $B6, $2B, $E5, $4A, $C7, $11, $D2, $71, $2D, $08, $15, $4A
   Data.b $AB, $90, $86, $A2, $8D, $08, $35, $B1, $D6, $68, $0D, $46, $48, $A4, $08, $F3
   Data.b $04, $E9, $70, $7A, $78, $80, $58, $3E, $4D, $D0, $D8, $58, $7F, $E4, $C8, $F1
   Data.b $45, $5F, $9B, $41, $E0, $47, $96, $C0, $CD, $5F, $4B, $2F, $B8, $2C, $80, $91
   Data.b $7C, $49, $1D, $5A, $CD, $55, $7F, $B8, $94, $CE, $7F, $F7, $FC, $C2, $6A, $A6
   Data.b $5C, $F3, $1E, $EC, $ED, $EC, $10, $9E, $7B, $E1, $F4, $CD, $05, $FA, $AC, $4D
   Data.b $28, $EA, $03, $1D, $0A, $FB, $50, $43, $4A, $A4, $72, $18, $9B, $38, $4B, $7D
   Data.b $69, $86, $8E, $CE, $8E, $E0, $13, $87, $8F, $AD, $14, $EA, $C1, $69, $CB, $FB
   Data.b $5F, $05, $A6, $AE, $96, $7D, $6E, $56, $D0, $68, $9B, $58, $B3, $BF, $D4, $DB
   Data.b $59, $FD, $C6, $5D, $7B, $3F, $EB, $25, $E3, $6E, $28, $50, $04, $06, $C9, $F8
   Data.b $CC, $2A, $A5, $89, $31, $DC, $6A, $99, $A0, $1E, $A0, $09, $E3, $5D, $5B, $50
   Data.b $42, $2A, $66, $16, $E6, $C9, $4C, $8D, $D2, $DF, $DB, $AD, $1F, $3A, $32, $90
   Data.b $5A, $A8, $54, $CF, $5A, $FE, $F3, $12, $30, $B1, $D9, $CA, $B3, $99, $2A, $54
   Data.b $07, $52, $5F, $BD, $75, $47, $ED, $4B, $BB, $B7, $FF, $43, $A4, $B1, $21, $A6
   Data.b $B5, $59, $D7, $B3, $73, $A9, $02, $93, $13, $A3, $F4, $75, $B5, $E9, $4F, $1E
   Data.b $3E, $91, $E9, $95, $54, $EE, $6B, $49, $AA, $FD, $AD, $4D, $89, $BD, $6D, $6D
   Data.b $71, $95, $68, $12, $2B, $5A, $B1, $30, $31, $CC, $1D, $7D, $3D, $E6, $D3, $EF
   Data.b $0C, $66, $CE, $17, $CB, $13, $F6, $D4, $5F, $B1, $C6, $57, $AE, $A7, $13, $5F
   Data.b $B1, $0F, $C4, $1D, $47, $4C, $FC, $CC, $FE, $67, $22, $ED, $6D, $8F, $6B, $A5
   Data.b $C2, $E1, $88, $10, $64, $2A, $9A, $A3, $43, $C3, $F4, $B4, $35, $99, $C7, $4F
   Data.b $9D, $4D, $BD, $97, $2B, $4E, $02, $A7, $ED, $00, $AA, $B9, $41, $A9, $AE, $FB
   Data.b $1A, $63, $DD, $B7, $34, $44, $DB, $13, $5E, $34, $FA, $1F, $A9, $5C, $F9, $64
   Data.b $26, $37, $03, $BC, $06, $FC, $00, $18, $04, $F2, $D7, $63, $FC, $55, $01, $98
   Data.b $3E, $B8, $FF, $B1, $44, $6B, $EB, $DF, $E2, $45, $84, $16, $60, $90, $54, $EA
   Data.b $F0, $C6, $F0, $08, $6E, $D4, $31, $5F, $1F, $9F, $CD, $0C, $A4, $B2, $E7, $AC
   Data.b $14, $3C, $64, $75, $6C, $12, $E8, $B2, $7A, $A1, $07, $E8, $B4, $EF, $1A, $03
   Data.b $0E, $5B, $E3, $B3, $9B, $A5, $CE, $9B, $0E, $A1, $33, $0F, $DC, $FE, $13, $89
   Data.b $64, $F2, $5B, $78, $AE, $08, $45, $79, $58, $65, $06, $C6, $26, $79, $7D, $7A
   Data.b $86, $F9, $D6, $B6, $CA, $C9, $74, $6E, $09, $38, $6A, $E3, $F9, $B8, $55, $53
   Data.b $CA, $6A, $84, $04, $D0, $6C, $05, $8F, $B4, $9D, $76, $CE, $9E, $FC, $75, $1B
   Data.b $7F, $D9, $24, $FE, $D7, $7B, $F6, $C5, $F7, $35, $35, $FE, $48, $26, $13, $3B
   Data.b $40, $AC, $CF, $73, $16, $6B, $01, $E7, $4B, $45, $2A, $F9, $02, $F7, $B4, $35
   Data.b $B9, $BF, $F7, $B3, $F7, $24, $1F, $DE, $DD, $A7, $3E, $D6, $D7, $99, $2E, $F9
   Data.b $C1, $F4, $78, $AE, $50, $B5, $B9, $53, $B1, $86, $AE, $02, $0B, $C0, $AC, $05
   Data.b $50, $B9, $DE, $B0, $B9, $62, $08, $25, $5C, $47, $4C, $1E, $BC, $EB, $59, $AF
   Data.b $B9, $E9, $0B, $5A, $CA, $0B, $E3, $12, $11, $56, $1F, $5F, $2A, $2A, $91, $08
   Data.b $99, $5C, $91, $F4, $EA, $2A, $D1, $5A, $95, $AE, $64, $03, $1D, $AD, $CD, $7E
   Data.b $C5, $98, $E3, $73, $85, $D2, $AB, $87, $E6, $96, $5F, $FC, $CA, $B1, $D3, $43
   Data.b $DA, $98, $D2, $86, $D1, $E0, $96, $19, $7E, $59, $00, $0B, $0F, $FE, $E4, $AF
   Data.b $24, $9B, $9B, $FE, $C6, $B8, $EE, $FA, $7C, $DB, $AC, $F9, $5C, $4A, $90, $2A
   Data.b $6C, $62, $42, $51, $AD, $6B, $2A, $8E, $4B, $BE, $54, $A2, $98, $CF, $E2, $94
   Data.b $8B, $B4, $7A, $2E, $2D, $89, $38, $28, $35, $BD, $5A, $2E, $BF, $7E, $26, $5B
   Data.b $78, $F9, $A9, $E1, $89, $1F, $BF, $B5, $9A, $5B, $B5, $1E, $A8, $6F, $55, $08
   Data.b $FD, $2F, $00, $E3, $07, $F7, $DF, $B6, $AD, $31, $F9, $86, $88, $46, $13, $21
   Data.b $CD, $11, $04, $98, $90, $2A, $0B, $81, $11, $21, $85, $40, $28, $8C, $0C, $AF
   Data.b $DA, $F6, $84, $5A, $3D, $C0, $F7, $5C, $8A, $7E, $8D, $4A, $B9, $08, $99, $14
   Data.b $4D, $D4, $69, $F2, $3C, $12, $B1, $48, $39, $5B, $AD, $BD, $3D, $57, $AA, $1C
   Data.b $7A, $7E, $6E, $E5, $C5, $3F, $1A, $99, $1A, $03, $D6, $BC, $A3, $AF, $D5, $3B
   Data.b $17, $01, $F8, $E6, $81, $7D, $D1, $CF, $B5, $37, $1D, $93, $89, $86, $7D, $C8
   Data.b $90, $BF, $84, $5F, $17, $2C, $00, $42, $00, $6B, $7B, $1D, $C8, $DA, $33, $04
   Data.b $DA, $EE, $40, $1B, $EA, $91, $18, $65, $61, $A8, $96, $F3, $04, $E9, $25, $12
   Data.b $A5, $3C, $CD, $8E, $43, $5B, $3C, $66, $AA, $5A, $8F, $2F, $55, $FD, $57, $07
   Data.b $73, $C5, $97, $7F, $67, $68, $FC, $8D, $B1, $42, $39, $6B, $BD, $13, $6C, $C6
   Data.b $3B, $97, $7A, $C0, $FB, $F2, $EE, $EE, $83, $77, $B5, $34, $3E, $79, $4F, $47
   Data.b $CB, $81, $6D, $89, $86, $98, $56, $2A, $F4, $F7, $06, $00, $7A, $23, $00, $29
   Data.b $31, $22, $FC, $8A, $A4, $C5, $5A, $87, $16, $68, $2C, $C9, $13, $12, $23, $25
   Data.b $81, $EB, $51, $F3, $5C, $CA, $A5, $0C, $F5, $EC, $32, $B1, $CC, $0A, $ED, $AE
   Data.b $43, $B3, $EB, $A1, $94, $93, $5B, $AD, $D5, $DF, $38, $5F, $AE, $BE, $F2, $77
   Data.b $53, $F3, $2F, $3D, $33, $3E, $7D, $DE, $32, $80, $FA, $95, $3C, $73, $69, $15
   Data.b $92, $6F, $A5, $0B, $FA, $B9, $F9, $D5, $EC, $37, $C7, $67, $B3, $43, $A9, $B4
   Data.b $1F, $0D, $02, $AF, $2F, $E2, $C5, $94, $72, $C2, $09, $95, $10, $F6, $1F, $C5
   Data.b $DA, $C4, $7F, $C3, $1B, $C4, $C6, $2F, $01, $17, $EE, $85, $44, $21, $88, $18
   Data.b $49, $C2, $4D, $10, $4D, $76, $22, $FA, $F6, $90, $8E, $27, $59, $74, $24, $2B
   Data.b $D9, $74, $24, $22, $D8, $B3, $3B, $16, $79, $70, $B4, $54, $6E, $7F, $69, $31
   Data.b $35, $67, $85, $7E, $79, $B3, $00, $B0, $BC, $64, $D9, $C0, $F9, $91, $42, $E5
   Data.b $DC, $BF, $CC, $AD, $4C, $7F, $67, $72, $6E, $39, $5D, $28, $D0, $2A, $45, $B4
   Data.b $D3, $73, $23, $46, $3A, $E1, $0C, $D4, $88, $F5, $CA, $64, $6C, $9D, $DD, $08
   Data.b $CE, $58, $70, $42, $08, $1B, $6E, $E1, $90, $4B, $4A, $85, $AB, $05, $0D, $5E
   Data.b $12, $65, $A2, $2C, $A4, $57, $91, $F9, $A2, $F9, $ED, $33, $13, $0B, $7F, $3A
   Data.b $3A, $BD, $68, $BB, $F9, $F4, $D5, $34, $3B, $F5, $3E, $33, $9F, $9A, $6D, $46
   Data.b $8B, $76, $46, $39, $5E, $0E, $F4, $B9, $B7, $33, $85, $73, $DF, $9D, $5A, $98
   Data.b $79, $61, $6E, $29, $67, $AA, $65, $D5, $E7, $AA, $78, $C2, $71, $94, $91, $CE
   Data.b $45, $A7, $7D, $61, $42, $BD, $E6, $A1, $B5, $9F, $2D, $ED, $DE, $00, $AC, $5A
   Data.b $2C, $30, $F9, $EE, $11, $3A, $74, $D5, $3C, $39, $36, $95, $FB, $F7, $B9, $95
   Data.b $05, $3B, $2B, $3A, $6A, $79, $52, $E9, $4A, $1E, $10, $57, $91, $23, $8E, $ED
   Data.b $AA, $2D, $96, $1A, $EC, $04, $FA, $A5, $10, $FD, $0F, $75, $35, $DF, $FA, $E9
   Data.b $9E, $AE, $5D, $F7, $76, $77, $B5, $39, $B1, $A4, $34, $8E, $67, $3D, $22, $D1
   Data.b $A8, $F5, $9C, $40, $2A, $BB, $43, $1D, $2D, $94, $43, $B9, $54, $60, $E6, $CC
   Data.b $00, $ED, $51, $C7, $3C, $71, $7A, $3C, $F3, $56, $2A, $37, $65, $47, $2E, $2F
   Data.b $00, $C7, $6C, $D3, $AB, $5F, $37, $17, $BA, $44, $7E, $BA, $76, $B8, $DB, $06
   Data.b $F4, $01, $BB, $81, $9B, $5B, $3D, $A7, $FF, $B1, $9E, $F6, $5B, $1E, $EA, $ED
   Data.b $DE, $BE, $B7, $BD, $3D, $59, $8F, $24, $D1, $D2, $59, $4F, $FA, $30, $D9, $D5
   Data.b $FA, $2E, $15, $73, $2C, $4C, $0C, $D3, $1C, $73, $F5, $E7, $07, $47, $D3, $43
   Data.b $21, $11, $3C, $6C, $F5, $C1, $89, $0D, $F3, $A2, $1B, $32, $DC, $15, $16, $4C
   Data.b $C4, $92, $B6, $4E, $E0, $26, $A0, $1F, $E8, $BF, $AD, $31, $7E, $CB, $67, $7A
   Data.b $3B, $F6, $3C, $D8, $DB, $D3, $DD, $92, $68, $F1, $EA, $91, $44, $28, $29, $A5
   Data.b $83, $91, $92, $42, $3E, $C3, $EA, $F4, $28, $B1, $58, $24, $F8, $CC, $C9, $91
   Data.b $D4, $B9, $62, $65, $C2, $7E, $85, $7C, $C1, $92, $BC, $CC, $66, $B4, $B1, $D8
   Data.b $82, $46, $B8, $31, $C4, $B6, $01, $BB, $80, $7E, $25, $44, $FF, $27, $BA, $9A
   Data.b $6F, $7D, $B8, $BB, $63, $D7, $47, $B6, $F5, $B4, $89, $78, $8B, $CC, $96, $4B
   Data.b $64, $17, $A6, $20, $E2, $06, $8F, $9E, $18, $59, $59, $A8, $D4, $C6, $AC, $36
   Data.b $78, $D1, $CE, $4A, $37, $CD, $50, $C5, $16, $D2, $92, $0F, $0C, $B1, $36, $CF
   Data.b $E9, $7F, $AC, $B7, $FD, $D6, $7D, $D1, $58, $EF, $8A, $31, $3C, $3D, $3E, $93
   Data.b $CD, $FA, $F5, $35, $E3, $5F, $B2, $33, $D2, $6B, $62, $A8, $82, $1B, $B3, $D4
   Data.b $25, $21, $B6, $03, $D8, $63, $C3, $AC, $CB, $36, $A9, $E3, $36, $69, $47, $6D
   Data.b $CD, $37, $5B, $C2, $85, $6E, $00, $59, $74, $80, $98, $D5, $05, $DB, $AC, $77
   Data.b $2A, $56, $C8, $CF, $5F, $CB, $28, $E5, $FF, $12, $C0, $A5, $21, $E6, $D8, $30
   Data.b $33, $37, $92, $62, $FF, $BF, $5A, $FF, $03, $14, $40, $F3, $DA, $D8, $5F, $19
   Data.b $B7, $00, $00, $00, $00, $49, $45, $4E, $44, $AE, $42, $60, $82
EndDataSection
 
Sélectionnez
;Overlay diagonal scanlines by reducing color and leaving Alpha unchanged
Procedure DiagonalScanlines(x,y,SourceColor,TargetColor)
  If ((x+y) % 3)
    ProcedureReturn RGBA(Red(TargetColor) * 0.1, Green(TargetColor) * 0.1, Blue(TargetColor) * 0.1, Alpha(TargetColor))
  Else
    ProcedureReturn TargetColor
  EndIf
EndProcedure

;invert color and keep alpha layer
Procedure InvertedColors(x,y,SourceColor,TargetColor)
    ProcedureReturn  TargetColor ! $FFFFFF
EndProcedure

;convert color to grayscale
Procedure GrayscaleFilter(x,y,SourceColor,TargetColor)
    grayLevel=(Red(TargetColor)+Green(TargetColor)+Blue(TargetColor))/3
    ProcedureReturn  RGBA(grayLevel,grayLevel,grayLevel,Alpha(TargetColor))
EndProcedure

Procedure SetDarkenPercent(percent)
   Global DarkFactor.f
   DarkFactor = 1 - percent / 100.0
   If DarkFactor < 0 : DarkFactor = 0 : EndIf
   If DarkFactor > 1 : DarkFactor = 1 : EndIf
EndProcedure

Procedure DarkenFilter(x, y, SourceColor, TargetColor)
   Global DarkFactor.f
   ProcedureReturn RGBA(Red(TargetColor) * DarkFactor, Green(TargetColor) * DarkFactor, Blue(TargetColor) * DarkFactor, Alpha(TargetColor))
EndProcedure

; SetDarkenPercent(10) ; make image 10% darker

Procedure SetLightenPercent(percent)
   Global LightFactor.f
   LightFactor =1-percent / 100.0
   If LightFactor < 0 : LightFactor = 0 : EndIf
   If LightFactor > 1 : LightFactor = 1 : EndIf
EndProcedure

Procedure LightenFilter(x, y, SourceColor, TargetColor)
   Global LightFactor.f
   ColorToWhite = $FFFFFF - TargetColor
   ProcedureReturn RGBA(255 - Red(ColorToWhite) * LightFactor, 255 - Green(ColorToWhite) * LightFactor, 255 - Blue(ColorToWhite) * LightFactor, Alpha(TargetColor))
EndProcedure

;SetLightenPercent(20) ;make image 20% lighter

;Fat pixel
Procedure PixelFilterCallback(x, y, SourceColor, TargetColor)
   #pixelSize=5
   xn=#pixelSize*(x/#pixelSize)
   yn=#pixelSize*(y/#pixelSize)
   ProcedureReturn Point(xn,yn)
EndProcedure
Procedure PixelFilter()
   CustomFilterCallback(@PixelFilterCallback())
EndProcedure

Les trois derniers filtres sont de Demivec :

 
Sélectionnez
;Transfer the Alpha layer into the visible layer.
Procedure MakeAlphaVisibleFilterCallback(x, y, SourceColor, TargetColor)
  ProcedureReturn RGBA(Alpha(SourceColor), Alpha(SourceColor),Alpha(SourceColor),00)
EndProcedure

;Overlay horizontal scanlines by reducing color and leaving Alpha unchanged
Procedure HorizontalScanlines(x,y,SourceColor,TargetColor)
  If y % 2
    ProcedureReturn RGBA(Red(TargetColor) * 0.1, Green(TargetColor) * 0.1, Blue(TargetColor) * 0.1, Alpha(TargetColor))
  Else
    ProcedureReturn TargetColor
  EndIf
EndProcedure


;Overlay vertical scanlines by reducing color and leaving Alpha unchanged
Procedure VerticalScanlines(x,y,SourceColor,TargetColor)
  If x % 2
    ProcedureReturn RGBA(Red(TargetColor) * 0.1, Green(TargetColor) * 0.1, Blue(TargetColor) * 0.1, Alpha(TargetColor))
  Else
    ProcedureReturn TargetColor
  EndIf
EndProcedure
Créé le 8 mars 2011  par eddy

Première version :

 
Sélectionnez
#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

Version encore plus jolie (avec un semblant de 3D) :

 
Sélectionnez
#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

Et une version de kenmo :

 
Sélectionnez
#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
Créé le 13 mars 2011  par einander
 
Sélectionnez
;- Color v1.1
;-
;- Procedures for handling colors not only in RGB, but also CMY, HSV and HSL (sometimes called HLS oder HSI)
;- Especially the last both let you modify the saturation and hue much more intuitively
;- See Wikipedia for more information on HSV and HSL
;-
;- The procedures contains all conversions between those color-types. The internal RGB-format
;- uses values in range [0.0, 1.0], so scale them manually to [0, 255] or use ColorRGB() for their usage in PB.
;-
;- Feel free to use this code for anything you want but without infringing its copyright.
;- (don't describe as it's author, don't sell itself - so just stay as nice as you are :)
;-
;- 19.09.06 by Froggerprogger
;-
;- v1.1:
;-         - added example 3
;-
;- please report any bugs, etc. to Froggerprogger in the Purebasic-Forums

Enumeration
  ; do not change their order!
  #COLOR_RGB
  #COLOR_CMY
  #COLOR_HSV
  #COLOR_HSL
EndEnumeration

Structure Color
  StructureUnion
    r.f ; Red in RGB [0.0, 1.0]
    c.f ; Cyan in CMY [0.0, 1.0]
    h.f ; Hue in HSV/HSL [0.0, 360.0[
  EndStructureUnion
  StructureUnion
    g.f ; Green in RGB [0.0, 1.0]
    m.f ; Magenta in CMY [0.0, 1.0]
    s.f ; Saturation in HSV/HSL [0.0, 1.0]
  EndStructureUnion
  StructureUnion
    b.f ; Blue in RGB [0.0, 1.0]
    y.f ; Yellow in CMY [0.0, 1.0]
    v.f ; Value in HSV [0.0, 1.0]
    l.f ; Lightness in HSL [0.0, 1.0]
  EndStructureUnion
  type.l ; gives the type. One of #COLOR_RGB, #COLOR_CMY, #COLOR_HSV, #COLOR_HSL
EndStructure

;- some neccessary declares
DeclareDLL.l Color2RGB(*c.Color)
DeclareDLL.l Color2CMY(*c.Color)
DeclareDLL.l Color2HSV(*c.Color)
DeclareDLL.l Color2HSL(*c.Color)

;- some helper-proceudures
Procedure.f Max3F(a.f, b.f, c.f)
  If a > b
    If a > c
      ProcedureReturn a
    Else
      ProcedureReturn c
    EndIf
  Else
    If b > c
      ProcedureReturn b
    Else
      ProcedureReturn c
    EndIf
  EndIf
EndProcedure

Procedure.f Min3F(a.f, b.f, c.f)
  If a < b
    If a < c
      ProcedureReturn a
    Else
      ProcedureReturn c
    EndIf
  Else
    If b < c
      ProcedureReturn b
    Else
      ProcedureReturn c
    EndIf
  EndIf
EndProcedure

;- some global color-procedures
ProcedureDLL.l IsColorValid(*c.Color) ; returns #True or #False whether *c specifies a valid color or not
  If *c\type < #COLOR_RGB Or *c\type > #COLOR_HSL
    ProcedureReturn #False
  EndIf

  ; check r, c in [0.0, 1.0] or h in [0.0, 360.0]
  If *c\type <= #COLOR_CMY
    If *c\r < 0 Or *c\r > 1.0
      ProcedureReturn #False
    EndIf
  Else
    If *c\h < 0 Or *c\h >= 360.0
      ProcedureReturn #False
    EndIf
  EndIf

  ; check g, m, s, b, y, v, l in [0.0, 1.0]
  If *c\g < 0 Or *c\g > 1.0
    ProcedureReturn #False
  EndIf
  If *c\b < 0 Or *c\b > 1.0
    ProcedureReturn #False
  EndIf

  ProcedureReturn #True
EndProcedure

ProcedureDLL.l ColorCopy(*c.Color) ; copies *c and returns *copy
  Protected *out = AllocateMemory(SizeOf(Color))
  CopyMemory(*c, *out, SizeOf(Color))
  ProcedureReturn *out
EndProcedure

ProcedureDLL.l ColorComplement(*c.Color) ; complements *c and returns *c
  If *c\type <= #COLOR_CMY
    ; if #COLOR_RGB or #COLOR_CMY
    *c\r = 1.0 - *c\r
    *c\g = 1.0 - *c\g
    *c\b = 1.0 - *c\b
  Else
    ; if #COLOR_HSV or #COLOR_HSL
    If *c\h >= 180.0
      *c\h - 180.0
    Else
      *c\h + 180.0
    EndIf
  EndIf
EndProcedure

ProcedureDLL.l ColorChangeType(*c.Color, type.l) ; changes the type of *c to the new type and returns *c. type = #COLOR_*
  Select type
    Case #COLOR_RGB : Color2RGB(*c)
    Case #COLOR_CMY : Color2CMY(*c)
    Case #COLOR_HSV : Color2HSV(*c)
    Case #COLOR_HSL : Color2HSL(*c)
  EndSelect
EndProcedure

ProcedureDLL.l IsSameColors(*c1.Color, *c2.Color, tolerance.f) ; compares the two colors (of any type) without modifiing them and returns #True if they describe the same color equal, #False otherwise
  Protected same.l

  ; compare in RGB to easy treat special cases in HSL, HSV
  *c1c.Color = ColorCopy(*c1)
  *c2c.Color = ColorCopy(*c2)
  Color2RGB(*c1c)
  Color2RGB(*c2c)

  If tolerance = 0
    same = CompareMemory(*c1c, *c2c, SizeOf(Color))
  Else
    same = #True
    If Abs(*c1c\r - *c2c\r) > tolerance
      same = #False
    EndIf
    If Abs(*c1c\g - *c2c\g) > tolerance
      same = #False
    EndIf
    If Abs(*c1c\b - *c2c\b) > tolerance
      same = #False
    EndIf
  EndIf
  FreeMemory(*c1c)
  FreeMemory(*c2c)
  ProcedureReturn same
EndProcedure

ProcedureDLL.s ColorToStr(*c.Color)
  Protected s.s
  Select *c\type
    Case #COLOR_RGB : s = "RGB"
    Case #COLOR_CMY : s = "CMY"
    Case #COLOR_HSV : s = "HSV"
    Case #COLOR_HSL : s = "HSL"
  EndSelect

  s + ": " + StrF(*c\r, 2) + ", " + StrF(*c\g, 2) + ", " + StrF(*c\b, 2)

  ProcedureReturn s
EndProcedure

;- change color to RGB
ProcedureDLL.l CMY2RGB(*c.Color) ; converts CMY-color *c to RGB and returns *c. No check if CMY is made!
  *c\r = 1.0 - *c\c
  *c\g = 1.0 - *c\m
  *c\b = 1.0 - *c\y
  *c\type = #COLOR_RGB

  ProcedureReturn *c
EndProcedure

ProcedureDLL.l HSV2RGB(*c.Color) ; converts HSV-color *c to RGB and returns *c. No check if HSV is made!
  Protected h.f, s.f, v.f
  Protected f.f, p.f, q.f, t.f, i.l

  h = *c\h
  s = *c\s
  v = *c\v

  If s = 0
    ; it's a gray-tone
    *c\r = v
    *c\g = v
    *c\b = v
  Else
    h / 60.0
    i = Round(h, 0)
    f = h-i
    p = v*(1.0-s)
    q = v*(1.0-s*f)
    t = v*(1.0-s*(1.0-f))
   
    Select i
      Case 0 : *c\r = v : *c\g = t : *c\b = p
      Case 1 : *c\r = q : *c\g = v : *c\b = p
      Case 2 : *c\r = p : *c\g = v : *c\b = t
      Case 3 : *c\r = p : *c\g = q : *c\b = v
      Case 4 : *c\r = t : *c\g = p : *c\b = v
      Case 5 : *c\r = v : *c\g = p : *c\b = q
    EndSelect
   
  EndIf

  *c\type = #COLOR_RGB

  ProcedureReturn *c
EndProcedure

Procedure.f HSL2RGBHelper(q1.f, q2.f, h.f)
  If h >= 360.0
    h - 360.0
  ElseIf h < 0.0
    h + 360.0
  EndIf

  If h < 60.0
    ProcedureReturn q1+(q2-q1)*h/60.0
  ElseIf h < 180.0
    ProcedureReturn q2
  ElseIf h < 240.0
    ProcedureReturn q1+(q2-q1)*(240.0-h)/60.0
  Else
    ProcedureReturn q1
  EndIf
EndProcedure

ProcedureDLL.l HSL2RGB(*c.Color) ; converts HSL-color *c to RGB and returns *c. No check if HSL is made!
  Protected h.f, l.f, s.f
  Protected f.f, p1.f, p2.f, t.f
  Protected i.l

  h = *c\h
  l = *c\l
  s = *c\s

  If l<=0.5
    p2 = l*(1.0+s)
  Else
    p2 = l+s-l*s
  EndIf

  p1 = 2.0*l-p2

  If s=0.0
    ; it's a gray-tone
    *c\r = l
    *c\g = l
    *c\b = l
  Else
    *c\r = HSL2RGBHelper(p1, p2, h+120.0)
    *c\g = HSL2RGBHelper(p1, p2, h)
    *c\b = HSL2RGBHelper(p1, p2, h-120.0)
  EndIf

  *c\type = #COLOR_RGB

  ProcedureReturn *c
EndProcedure

ProcedureDLL.l Color2RGB(*c.Color) ; converts *c from any color-type to RGB and returns *c
  Select *c\type
    Case #COLOR_RGB : ProcedureReturn *c
    Case #COLOR_CMY : ProcedureReturn CMY2RGB(*c)
    Case #COLOR_HSV : ProcedureReturn HSV2RGB(*c)
    Case #COLOR_HSL : ProcedureReturn HSL2RGB(*c)
  EndSelect
EndProcedure

ProcedureDLL.l ColorSetRGB(*c.Color, r.f, g.f, b.f) ; sets *c to the RGB-color given by r,g,b, each in range [0.0, 1.0] (no check is made) and returns *c
  *c\r = r
  *c\g = g
  *c\b = b
  *c\type = #COLOR_RGB

  ProcedureReturn *c
EndProcedure

;- change color to CMY
ProcedureDLL.l RGB2CMY(*c.Color) ; converts RGB-color *c to CMY and returns *c. No check if RGB is made!
  *c\c = 1.0 - *c\r
  *c\m = 1.0 - *c\g
  *c\y = 1.0 - *c\b
  *c\type = #COLOR_CMY

  ProcedureReturn *c
EndProcedure

ProcedureDLL.l HSV2CMY(*c.Color) ; converts HSV-color *c to CMY and returns *c. No check if HSV is made!
  ; complement
  If *c\h >= 180.0
    *c\h - 180.0
  Else
    *c\h + 180.0
  EndIf

  HSV2RGB(*c) ; HSV2RGB of complement

  *c\type = #COLOR_CMY

  ProcedureReturn *c
EndProcedure

ProcedureDLL.l HSL2CMY(*c.Color) ; converts HSL-color *c to CMY and returns *c. No check if HSL is made!
  ; complement
  If *c\h >= 180.0
    *c\h - 180.0
  Else
    *c\h + 180.0
  EndIf

  HSL2RGB(*c) ; HSL2RGB of complement

  *c\type = #COLOR_CMY

  ProcedureReturn *c
EndProcedure

ProcedureDLL.l Color2CMY(*c.Color) ; converts *c from any color-type to CMY and returns *c
  Select *c\type
    Case #COLOR_RGB : ProcedureReturn RGB2CMY(*c)
    Case #COLOR_CMY : ProcedureReturn *c
    Case #COLOR_HSV : ProcedureReturn HSV2CMY(*c)
    Case #COLOR_HSL : ProcedureReturn HSL2CMY(*c)
  EndSelect
EndProcedure

ProcedureDLL.l ColorSetCMY(*c.Color, c.f, m.f, y.f) ; sets *c to the CMY-color given by c,m,y, each in range [0.0, 1.0] (no check is made) and returns *c
  *c\c = c
  *c\m = m
  *c\y = y
  *c\type = #COLOR_CMY

  ProcedureReturn *c
EndProcedure

;- change color to HSV
ProcedureDLL.l RGB2HSV(*c.Color) ; converts RGB-color *c to HSV and returns *c. No check if RGB is made!
  Protected r.f, g.f, b.f, max.f, min.f, delta.f
  r = *c\r
  g = *c\g
  b = *c\b

  max = Max3F(r,g,b)
  min = Min3F(r,g,b)

  ; get value
  *c\v = max
  If max <> 0.0
    delta = max - min
   
    ; get saturation
    *c\s = delta/max
   
    ; get hue
    If delta <> 0.0
      If r = max
        *c\h = (g-b)/delta
      ElseIf g = max
        *c\h = 2.0 + (b-r)/delta
      ElseIf b = max
        *c\h = 4.0 + (r-g)/delta
      EndIf
     
      *c\h * 60.0
     
      If *c\h<0.0
        *c\h + 360.0
      EndIf
    Else
      ; it's a gray-tone
      *c\h = 0 ; *c\h is even undefined
    EndIf
   
  Else
    ; it's black
    *c\s = 0
    *c\h = 0 ; *c\h is even undefined
  EndIf

  *c\type = #COLOR_HSV

  ProcedureReturn *c
EndProcedure

ProcedureDLL.l CMY2HSV(*c.Color) ; converts CMY-color *c to HSV and returns *c. No check if CMY is made!
  ; treat as RGB-color
  RGB2HSV(*c)

  ; complement
  If *c\h >= 180.0
    *c\h - 180.0
  Else
    *c\h + 180.0
  EndIf

  ProcedureReturn *c
EndProcedure

ProcedureDLL.l HSL2HSV(*c.Color) ; converts HSL-color *c to HSV and returns *c. No check if HSL is made!
  ProcedureReturn RGB2HSV(HSL2RGB(*c)) ; it's the easiest, though not fastet way
EndProcedure

ProcedureDLL.l Color2HSV(*c.Color) ; converts *c from any color-type to HSV And returns *c
  Select *c\type
    Case #COLOR_RGB : ProcedureReturn RGB2HSV(*c)
    Case #COLOR_CMY : ProcedureReturn CMY2HSV(*c)
    Case #COLOR_HSV : ProcedureReturn *c
    Case #COLOR_HSL : ProcedureReturn HSL2HSV(*c)
  EndSelect
EndProcedure

ProcedureDLL.l ColorSetHSV(*c.Color, h.f, s.f, v.f) ; sets *c to the HSV-color given by h in range [0.0, 360.0] and s,v in range [0.0, 1.0] (no check is made) and returns *c
  If h = 360.0
    h = 0
  EndIf

  *c\h = h
  *c\s = s
  *c\v = v
  *c\type = #COLOR_HSV

  ProcedureReturn *c
EndProcedure


;- change color to HSL
ProcedureDLL.l RGB2HSL(*c.Color) ; converts RGB-color *c to HSL and returns *c. No check if RGB is made!
  Protected r.f, g.f, b.f, max.f, min.f, delta.f
  r = *c\r
  g = *c\g
  b = *c\b

  max = Max3F(r,g,b)
  min = Min3F(r,g,b)
  delta = max - min

  If delta <> 0.0
    ; get lightness
    *c\l = (max + min) / 2.0
   
    ; get saturation
    If *c\l <= 0.5
      *c\s = delta/(max+min)
    Else
      *c\s = delta/(2-max-min)
    EndIf
   
    ; get hue
    If r = max
      *c\h = (g-b)/delta
    ElseIf g = max
      *c\h = 2.0 + (b-r)/delta
    ElseIf b = max
      *c\h = 4.0 + (r-g)/delta
    EndIf
   
    *c\h * 60.0
   
    If *c\h<0.0
      *c\h + 360.0
    EndIf
  Else
    ; it's black
    *c\s = 0
    *c\h = 0 ; *c\h is even undefined
  EndIf

  *c\type = #COLOR_HSL

  ProcedureReturn *c
EndProcedure

ProcedureDLL.l CMY2HSL(*c.Color) ; converts CMY-color *c to HSL and returns *c. No check if CMY is made!
  ; treat as RGB-color
  RGB2HSL(*c)

  ; complement
  If *c\h >= 180.0
    *c\h - 180.0
  Else
    *c\h + 180.0
  EndIf

  ProcedureReturn *c
EndProcedure

ProcedureDLL.l HSV2HSL(*c.Color) ; converts HSV-color *c to HSL and returns *c. No check if HSV is made!
  ProcedureReturn RGB2HSL(HSV2RGB(*c)) ; it's the easiest, though not fastet way
EndProcedure

ProcedureDLL.l Color2HSL(*c.Color) ; converts *c from any color-type to HSL and returns *c
  Select *c\type
    Case #COLOR_RGB : ProcedureReturn RGB2HSL(*c)
    Case #COLOR_CMY : ProcedureReturn CMY2HSL(*c)
    Case #COLOR_HSV : ProcedureReturn HSV2HSL(*c)
    Case #COLOR_HSL : ProcedureReturn *c
  EndSelect
EndProcedure

ProcedureDLL.l ColorSetHSL(*c.Color, h.f, l.f, s.f) ; sets *c to the HSL-color given by h in range [0.0, 360.0[ and l,s in range [0.0, 1.0] (no check is made) and returns *c
  *c\h = h
  *c\l = l
  *c\s = s
  *c\type = #COLOR_HSL

  ProcedureReturn *c
EndProcedure

;- change color to PureBasic's RGB
ProcedureDLL.l ColorRGBFast(*c.Color) ; converts *c to RGB and returns a Purebasic-RGB-colorcode same as returned by PB's RGB()
  Color2RGB(*c)
  ProcedureReturn RGB(255 * *c\r, 255 * *c\g, 255 * *c\b)
EndProcedure

ProcedureDLL.l ColorRGB(*c.Color) ; converts an internal copy of *c to RGB and returns a Purebasic-RGB-colorcode same as returned by PB's RGB()
  Protected *cc.Color, rgb.l
  *cc = ColorCopy(*c)
  Color2RGB(*cc)
  rgb = RGB(255 * *cc\r, 255 * *cc\g, 255 * *cc\b)
  FreeMemory(*cc)
  ProcedureReturn rgb
EndProcedure


;-
;- debug test functionality
;-
Procedure.l DebugTestFunctionality()
  ; RGB <-> CMY
  For i=0 To 10000
    ColorSetRGB(c.Color, Random(100)/100.0, Random(100)/100.0, Random(100)/100.0)
    *c2.Color = Color2RGB(Color2CMY(ColorCopy(c)))
   
    If IsSameColors(c, *c2, 0.1) = #False
      Debug "ERROR RGB <-> CMY"
      End
    EndIf
    FreeMemory(*c2)
  Next

  ; RGB <-> HSV
  For i=0 To 10000
    ColorSetRGB(c.Color, Random(100)/100.0, Random(100)/100.0, Random(100)/100.0)
    *c2.Color = Color2RGB(Color2HSV(ColorCopy(c)))
   
    If IsSameColors(c, *c2, 0.1) = #False
      Debug "ERROR RGB <-> HSV"
      End
    EndIf
    FreeMemory(*c2)
  Next

  ; RGB <-> HSL
  For i=0 To 10000
    ColorSetRGB(c.Color, Random(100)/100.0, Random(100)/100.0, Random(100)/100.0)
    *c2.Color = Color2RGB(Color2HSL(ColorCopy(c)))
   
    If IsSameColors(c, *c2, 0.1) = #False
      Debug "ERROR RGB <-> HSL"
      End
    EndIf
    FreeMemory(*c2)
  Next

  ; CMY <-> HSV
  For i=0 To 10000
    ColorSetCMY(c.Color, Random(100)/100.0, Random(100)/100.0, Random(100)/100.0)
    *c2.Color = Color2CMY(Color2HSV(ColorCopy(c)))
   
    If IsSameColors(c, *c2, 0.1) = #False
      Debug "ERROR CMY <-> HSV"
      End
    EndIf
    FreeMemory(*c2)
  Next

  ; CMY <-> HSL
  For i=0 To 10000
    ColorSetCMY(c.Color, Random(100)/100.0, Random(100)/100.0, Random(100)/100.0)
    *c2.Color = Color2CMY(Color2HSL(ColorCopy(c)))
   
    If IsSameColors(c, *c2, 0.1) = #False
      Debug "ERROR CMY <-> HSL"
      End
    EndIf
    FreeMemory(*c2)
  Next

  ; HSV <-> HSL
  For i=0 To 10000
    ColorSetHSV(c.Color, Random(360)/100.0, Random(100)/100.0, Random(100)/100.0)
    *c2.Color = Color2HSV(Color2HSL(ColorCopy(c)))
   
    If IsSameColors(c, *c2, 0.1) = #False
      Debug "ERROR HSV <-> HSL"
      End
    EndIf
    FreeMemory(*c2)
  Next

  Debug "All Tests done."
EndProcedure

;Goto example3

;-
;- example 1
;-
example1:

ColorSetRGB(rgbCol.Color, 0.0, 0.0, 1.0) ; full blue
s.s = "Create blue, decrease its saturation towards gray and move it" + #CRLF$
s.s + "slightly towards green without changing it's intensity" + #CRLF$ + #CRLF$

s.s + "Original color: " + ColorToStr(rgbCol) + #CRLF$

; we dont' like this green, we want to make it a little bit darker and remove it's saturation
Color2HSL(rgbCol)

s.s + "Original color: " + ColorToStr(rgbCol) + #CRLF$
rgbCol\h - 30 ; be careful to stay in range [0, 360[. Here we know h is 240
rgbCol\s = 0.5

s.s + "Modified color: " + ColorToStr(rgbCol) + #CRLF$
Color2RGB(rgbCol)
s.s + "Modified color: " + ColorToStr(rgbCol) + #CRLF$


MessageRequester("Color example 1/3:", s)

MessageRequester("Color example 2/3:", "Click OK to run a HSL-demonstration in fullscreen.")
;-
;- example 2
;-
example2:

InitSprite()
InitKeyboard()

OpenScreen(1024, 768, 32, "Color-example")

framecounter = 0
fps = 0
lastFrametimer = 0

Repeat
  ; fps-calculation
  framecounter+1
  If ElapsedMilliseconds() - lastFrametimer > 1000
    fps = framecounter
    framecounter = 0
    lastFrametimer = ElapsedMilliseconds()
  EndIf

  ; draw the colorbars
  ClearScreen(RGB(0, 0, 50))
  StartDrawing(ScreenOutput())
  FrontColor(RGB(255,255,255))
  DrawingMode(1)
  DrawText(10,10, "HSL-colors for 1.440.000 individual colored pixels at " + Str(fps) + " fps. Press ESC to exit.")

  ; create 1.440.000 combinations of hue, sat and lightness and display them
  sat.f = 0.05
  While sat <= 1.0
    lig.f = 0
    While lig <= 1.0
      hue.f = 0
      While hue < 360.0
        ; create a new hsl-colored pixel (you might fill your structure manually, too)
        ColorSetHSL(HSLCol.Color, hue, sat, lig)
       
        ; draw it on the screen after converting to PB's RGB
        Plot(152 + 2*hue, 180 + 20*lig + 400*sat, ColorRGBFast(HSLCol))
       
        hue + 0.5
      Wend
      lig + 0.05
    Wend
    sat + 0.1
  Wend
  StopDrawing()
  FlipBuffers()

  Delay(10)

  ExamineKeyboard()
Until KeyboardPushed(#PB_Key_Escape)
CloseScreen()

;-
;- example 3
;-
example3:

Procedure.l GetContrastedPBColor(red.l, green.l, blue.l)
  Protected col.Color
  ColorSetRGB(col.Color, red/255.0, green/255.0, blue/255.0)
  Color2HSV(col)
  ColorComplement(col) ; build the normal complement

  ; modify saturation and value
  ; you might experiment with those to achieve other results
  col\s + 0.5
  If col\s > 1.0
    col\s - 1.0
  EndIf

  col\v + 0.5
  If col\v > 1.0
    col\v - 1.0
  EndIf

  Color2RGB(col)
  ProcedureReturn RGB(col\r*255, col\g*255, col\b*255)
EndProcedure

CreateImage(0, 500, 500)
For i=0 To 9
  Select i
    Case 0 : col.l = $000000
    Case 1 : col.l = $FFFFFF
    Case 2 : col.l = $7F7F7F
    Case 3 : col.l = $660000
    Case 4 : col.l = $00FF00
    Case 5 : col.l = $000033
    Case 6 : col.l = $FF9900
    Case 7 : col.l = $FF33FF
    Case 8 : col.l = $3754A9
    Case 9 : col.l = $9F3F20
  EndSelect

  contrCol = GetContrastedPBColor(Red(col), Green(col), Blue(col))

  StartDrawing(ImageOutput(0))
  Box(0, i*50, 500, 50, col)
  DrawingMode(#PB_2DDrawing_Transparent)
    DrawText(10, i*50 + 20, "This is just an example-text in a color contrasted to the background", contrCol)
  StopDrawing()
Next

OpenWindow(0, 0, 0, 500, 500, "Color example 3/3:")
ImageGadget(0, 0, 0, 500, 500, ImageID(0))
Repeat
Until WaitWindowEvent() = #PB_Event_CloseWindow
Créé le 24 mars 2011  par Froggerprogger
 
Sélectionnez
;********************************
;*
;* LOTUS DEMO
;* djes 28/03/2011
;*
;********************************

Procedure FilterCallback(x, y, SourceColor, TargetColor)
  r.l = (0.5 * Sqr((x - 64) * (x - 256) + (y - 256) * (y - 256) ))
  v.l = (0.5 * Sqr((x - 256) * (x - 64) + (y - 256) * (y - 64) ))
  b.l = (0.5 * Sqr((x - 256) * (x - 256) + (y - 64) * (y - 256) ))
  a.l = (256 * (512 - Sqr((x - 256) * (x - 256) + (y - 256) * (y - 256) )))
  u%255
  ProcedureReturn RGBA(r, v, b, a)
EndProcedure

If InitSprite() = 0 Or InitKeyboard() = 0
  MessageRequester("Error", "Sprite system can't be initialized", 0)
  End
EndIf

If InitSprite3D() = 0
  MessageRequester("Error", "Sprite3D system can't be initialized correctly", 0)
  End
EndIf

If OpenWindow(0, 0, 0, 512, 512, "Un écran dans une fenêtre...", #PB_Window_SystemMenu | #PB_Window_ScreenCentered)
 
  If OpenWindowedScreen(WindowID(0), 0, 0, 512, 512, 0, 0, 0)

    If CreateImage(0, 512, 512, 32) And StartDrawing(ImageOutput(0))

      DrawingMode(#PB_2DDrawing_AlphaChannel)
      Box(0, 0, 512, 512, $00000000)
      DrawingMode(#PB_2DDrawing_CustomFilter)     
      CustomFilterCallback(@FilterCallback())     
      Circle( 256, 256, 256 )
      StopDrawing()
     
    EndIf
   
    If StartDrawing(ScreenOutput())     
      DrawImage(ImageID(0), 0, 0)
      StopDrawing()     
    EndIf
   
    GrabSprite(0, 0, 0, 512, 512, #PB_Sprite_Texture|#PB_Sprite_AlphaBlending)
   
    For u = 0 To 31
      CreateSprite3D(u, 0)
    Next u
     
    Sprite3DQuality(#PB_Sprite3D_BilinearFiltering)
   
    i.f = 0
    bl_src = 2
    bl_dst = 6
   
    Repeat
     
      Event = WindowEvent()
     
      Select Event
        Case #PB_Event_Gadget
          If EventGadget() = 0
            End
          EndIf
       
        Case #PB_Event_CloseWindow
          End
      EndSelect
     
      FlipBuffers()
     
      ClearScreen(RGB(0,50,128))
     
     
      If Start3D()
       
        Sprite3DBlendingMode(bl_src, bl_dst)
 
        For u = 0 To 31
          w = 512 * Sin(i + u * 5)
          h = 512 * Sin(i + u * 5)
          ZoomSprite3D(u, w, h)
          RotateSprite3D(u, i * 100 + u * 5, 0)
          DisplaySprite3D(u, 256 - w / 2 - 8 * Sin(i * u), 256 - h / 2 - 8 * Cos(i * u), 127)
        Next u   
       
        Stop3D()
      EndIf
     
      ExamineKeyboard()
     
      If KeyboardReleased(#PB_Key_Up)
        bl_src + 1
      EndIf
      If KeyboardReleased(#PB_Key_Down)
        bl_src - 1
      EndIf
      If KeyboardReleased(#PB_Key_Left)
        bl_dst + 1
      EndIf
      If KeyboardReleased(#PB_Key_Right)
        bl_dst - 1
      EndIf
       
      i+0.01
    Until KeyboardPushed(#PB_Key_Escape)
 
  Else
    MessageRequester("Erreur", "Can't open a screen !", 0)
    End
  EndIf 

Else
  MessageRequester("Error", "Can't open a window !", 0)
EndIf
 
End
Créé le 29 mars 2011  par djes

Cover Flow est une interface utilisateur tridimensionnelle servant à naviguer dans une bibliothèque (de musique, d'image, ...) via des représentations graphiques signifiantes (pochettes d'albums, image réduite,...).

C'est un bon exemple de manipulation des images, il faudrait tenter d'obtenir le même effet avec des sprite3D, qui s'y colle ?

 
Sélectionnez
EnableExplicit

; Mit 'UseRealAplhaMirror = #True' kann festgelegt werden, ob ein Spiegelbild mit ECHTEM Alpha-Kanal erstellt und genutzt werden soll, oder nicht.
; Andernfalls wird 'nur' ein Spiegelbild erstellt, welches auf eine feste Hintergrundfarbe 'geblendet' wird.
; (Die letztgenannte Methode hat den Vorteil, dass Bilder mit diesem Spiegelbild nahezu ohne Performanceeinbussen verkleinert dargestellt werden können.)

; Define UseRealAplhaMirror = #True
Define UseRealAplhaMirror = #False

Define TempDir.s = GetTemporaryDirectory()
Define Quit = #True
Define DeleteCoverImages = #False; #True
Define ScrWidth = 800
Define ScrHeight = 600
Define ScrXCenter = 400
Define ScrYCenter = 300
Define LoopHeight = 70
Define LoopWidth = 300
Define CoverURL.s
Define Covers.l
Define AktWinkel.f
Define OldWinkel.f = -1
Define WinkelSchrittweite.f
Define DoFShrink.f   = 0.2
Define FrameColor.l = $ff0000
Define DummyImage.i
Define HintergrundFarbe = $0  ; $400000
Define n

Structure str_CoverZBuffer
  ImageID.i
  XPos.l
  YPos.f
  Zoom.f
  Width.l
  Height.l
  CoverName.s
EndStructure
NewList CoverFiles.s()


;{ Flip-Image Procedures by Balatro.  => http://www.purebasic.fr/english/viewtopic.php?t=25276&highlight=image+mirror

Procedure CopyImageToMemory(ImageNumber, Memory)
  
  Protected TemporaryDC.L, TemporaryBitmap.BITMAP, TemporaryBitmapInfo.BITMAPINFO
  
  TemporaryDC = CreateDC_("DISPLAY", #Null, #Null, #Null)
  
  GetObject_(ImageID(ImageNumber), SizeOf(BITMAP), TemporaryBitmap.BITMAP)
  
  TemporaryBitmapInfo\bmiHeader\biSize        = SizeOf(BITMAPINFOHEADER)
  TemporaryBitmapInfo\bmiHeader\biWidth       = TemporaryBitmap\bmWidth
  TemporaryBitmapInfo\bmiHeader\biHeight      = -TemporaryBitmap\bmHeight
  TemporaryBitmapInfo\bmiHeader\biPlanes      = 1
  TemporaryBitmapInfo\bmiHeader\biBitCount    = 32
  TemporaryBitmapInfo\bmiHeader\biCompression = #BI_RGB
  
  GetDIBits_(TemporaryDC, ImageID(ImageNumber), 0, TemporaryBitmap\bmHeight, Memory, TemporaryBitmapInfo, #DIB_RGB_COLORS)
  
  DeleteDC_(TemporaryDC)
  
EndProcedure

Procedure CopyMemoryToImage(Memory, ImageNumber)
  
  Protected TemporaryDC.L, TemporaryBitmap.BITMAP, TemporaryBitmapInfo.BITMAPINFO
  
  TemporaryDC = CreateDC_("DISPLAY", #Null, #Null, #Null)
  
  GetObject_(ImageID(ImageNumber), SizeOf(BITMAP), TemporaryBitmap.BITMAP)
  
  TemporaryBitmapInfo\bmiHeader\biSize        = SizeOf(BITMAPINFOHEADER)
  TemporaryBitmapInfo\bmiHeader\biWidth       = TemporaryBitmap\bmWidth
  TemporaryBitmapInfo\bmiHeader\biHeight      = -TemporaryBitmap\bmHeight
  TemporaryBitmapInfo\bmiHeader\biPlanes      = 1
  TemporaryBitmapInfo\bmiHeader\biBitCount    = 32
  TemporaryBitmapInfo\bmiHeader\biCompression = #BI_RGB
  
  SetDIBits_(TemporaryDC, ImageID(ImageNumber), 0, TemporaryBitmap\bmHeight, Memory, TemporaryBitmapInfo, #DIB_RGB_COLORS)
  
  DeleteDC_(TemporaryDC)
  
EndProcedure
Procedure Flip(ImageNumber)
  
  Protected MemorySize, *MemoryOrigin, *MemoryTarget
  
  Protected Origin, Target, W, H, X, Y
  
  MemorySize = (ImageWidth(ImageNumber) * ImageHeight(ImageNumber) << 2)
  
  *MemoryOrigin = AllocateMemory(MemorySize)
  *MemoryTarget = AllocateMemory(MemorySize)
  
  CopyImageToMemory(ImageNumber, *MemoryOrigin)
  
  W = ImageWidth(ImageNumber)
  H = ImageHeight(ImageNumber)   
  
  For Y = 0 To H - 1
    
    For X = 0 To W - 1
      
      Origin = (Y * W + X) << 2
      
      Target = ((H - Y - 1) * W + X) << 2
      
      PokeL(*MemoryTarget + Target, PeekL(*MemoryOrigin + Origin))
      
    Next
    
  Next
  
  CopyMemoryToImage(*MemoryTarget, ImageNumber)
  
  FreeMemory(*MemoryOrigin)
  FreeMemory(*MemoryTarget)
  
EndProcedure
;}

Procedure AddAlphaMirrorToImage(ImageNum, HeightPercentage, MirrorOffest = 0, StartBlend = 40, EndBlend = 100)
  Protected MirrorImage.i = CopyImage(ImageNum, #PB_Any)
  Protected MirrorHeight.l = ImageHeight(ImageNum) * HeightPercentage / 100
  Protected OrigImageHeight.l = ImageHeight(ImageNum)
  Protected OrigImageWidth.l = ImageWidth(ImageNum)
  Protected ActBlend.f = 255-(2.55 * StartBlend)
  Protected BlendStep.f = (2.55 * (EndBlend-StartBlend)) / MirrorHeight
  Protected n.l
  CreateImage(ImageNum,ImageWidth(ImageNum),OrigImageHeight+MirrorHeight+MirrorOffest,32)
  If StartDrawing(ImageOutput(ImageNum))
    DrawImage(ImageID(MirrorImage),0,0)
    ResizeImage(MirrorImage,ImageWidth(MirrorImage),MirrorHeight)
    Flip(MirrorImage)
    DrawImage(ImageID(MirrorImage),0,OrigImageHeight+MirrorOffest)
    DrawingMode(#PB_2DDrawing_AlphaChannel)
    Box(0, OrigImageHeight, OrigImageWidth, MirrorHeight+MirrorOffest, $00000000)
    For n = OrigImageHeight+MirrorOffest To ImageHeight(ImageNum)
      LineXY(0,n,OrigImageWidth,n,RGBA(0,0,0,ActBlend))
      ActBlend - BlendStep
    Next
    StopDrawing()
  EndIf
EndProcedure

Procedure AddMirrorToImage(ImageNum, HeightPercentage, BGColor = 0, MirrorOffest = 0, StartBlend = 40, EndBlend = 100)
  Protected MirrorImage.i = CopyImage(ImageNum, #PB_Any)
  Protected MirrorHeight.l = ImageHeight(ImageNum) * HeightPercentage / 100
  Protected OrigImageHeight.l = ImageHeight(ImageNum)
  Protected OrigImageWidth.l = ImageWidth(ImageNum)
  Protected ActBlend.f = 255 - (2.55 * StartBlend)
  Protected BlendStep.f = (2.55 * (EndBlend-StartBlend)) / MirrorHeight
  Protected n.l
  ResizeImage(ImageNum,ImageWidth(ImageNum),OrigImageHeight+MirrorHeight+MirrorOffest)
  If StartDrawing(ImageOutput(ImageNum))
    Box(0, 0, OrigImageWidth, ImageHeight(ImageNum), BGColor)
    DrawImage(ImageID(MirrorImage),0,0)
    ResizeImage(MirrorImage,ImageWidth(MirrorImage),MirrorHeight)
    Flip(MirrorImage)
    DrawImage(ImageID(MirrorImage),0,OrigImageHeight+MirrorOffest)
    DrawingMode(#PB_2DDrawing_AlphaBlend)
    For n = OrigImageHeight+MirrorOffest To ImageHeight(ImageNum)
      LineXY(0,n,OrigImageWidth,n,RGBA(Red(BGColor),Green(BGColor),Blue(BGColor),ActBlend))
      ActBlend - BlendStep
    Next
    StopDrawing()
  EndIf
EndProcedure

; Read URL from DataSection and Download Cover Images from Internet
InitNetwork()
UseJPEGImageDecoder()
Restore CoverFileNames
Read.s CoverURL
While CoverURL <> ""
  AddElement(CoverFiles())
  CoverFiles() = TempDir+GetFilePart(CoverURL)
  If FileSize(CoverFiles()) <= 0
    If ReceiveHTTPFile(CoverURL, CoverFiles())
      LoadImage(ListSize(CoverFiles())-1,CoverFiles())
      If UseRealAplhaMirror
        AddAlphaMirrorToImage(ListSize(CoverFiles())-1,40,10,80,100)
      Else
        AddMirrorToImage(ListSize(CoverFiles())-1,40,HintergrundFarbe,10,20,0)
      EndIf
    Else
      DeleteElement(CoverFiles())
    EndIf
  Else
    LoadImage(ListSize(CoverFiles())-1,CoverFiles())
    If UseRealAplhaMirror
      AddAlphaMirrorToImage(ListSize(CoverFiles())-1,40,10,80,100)
    Else
      AddMirrorToImage(ListSize(CoverFiles())-1,40,HintergrundFarbe,10,20,0)
    EndIf
  EndIf
  Read.s CoverURL
Wend

Covers = ListSize(CoverFiles())
If Covers < 1
  Debug "Es konnten keine Cover-Bilder geladen werden."
  End
EndIf

InitSprite()
InitKeyboard()
InitMouse()
Dim CoverZBuff.str_CoverZBuffer(Covers-1)

If OpenWindow(0,0,0,ScrWidth,ScrHeight,"Medien-Bibliothek   (press ESC to exit)",#PB_Window_SystemMenu | #PB_Window_ScreenCentered)
  If OpenWindowedScreen(WindowID(0),0,0,ScrWidth,ScrHeight,0,0,0)
    Quit = #False
  EndIf
EndIf

While Not Quit
  WaitWindowEvent(2)
  ExamineKeyboard()
  ExamineMouse()
  AktWinkel + 0.01 * MouseDeltaX()
  If AktWinkel <> OldWinkel
    Define starttime.i = ElapsedMilliseconds()
    ClearScreen(HintergrundFarbe)
    WinkelSchrittweite = #PI * 2 / Covers
    If StartDrawing(ScreenOutput())
      
      ; =============================================================================================
      Plot(0,0,0)   ; <= BUG in PB !!!   Ohne den Plot()-Befehl wird kein ClearScreen() ausgeführt !!!
      ; =============================================================================================
      
      ; Position und Größe der Cover an Hand der aktuellen Drehung (AktWinkel) berechnen
      For n = 0 To Covers-1
        CoverZBuff(n)\ImageID = n
        CoverZBuff(n)\Zoom = DoFShrink + (Cos(AktWinkel + n * WinkelSchrittweite) + 1) * (1-DoFShrink) / 2
        CoverZBuff(n)\Width = ImageWidth(n) * CoverZBuff(n)\Zoom
        CoverZBuff(n)\Height = ImageHeight(n) * CoverZBuff(n)\Zoom
        CoverZBuff(n)\XPos = ScrXCenter + Sin(AktWinkel + n * WinkelSchrittweite) * LoopWidth - CoverZBuff(n)\Width/2
        CoverZBuff(n)\YPos = ScrYCenter + Cos(AktWinkel + n * WinkelSchrittweite) * LoopHeight - CoverZBuff(n)\Height/2
        SelectElement(CoverFiles(),n)
        CoverZBuff(n)\CoverName = GetFilePart(CoverFiles())
        CoverZBuff(n)\CoverName = Left(CoverZBuff(n)\CoverName, Len(CoverZBuff(n)\CoverName)-4)
      Next
      
      ; Sortieren nach Y-Position der Cover, um Überlappungen korrekt darzustellen.
      SortStructuredArray(CoverZBuff(), #PB_Sort_Ascending, OffsetOf(str_CoverZBuffer\YPos), #PB_Sort_Float)
      DrawingMode(#PB_2DDrawing_AlphaBlend)
      For n = 0 To Covers-1
        If UseRealAplhaMirror
          
          ; ------ Anzeige der Images mit ECHTEM Alpha-Kanal Spiegelbild -------
          
          ; Da ein AlphaImage nicht "on-the-fly" gezoomed werden kann, wird hier ein Dummy-Image erzeugt, welches dann verkleinert wird.
          ; Dieser Vorgang kostet extrem viel Zeit, wodurch die Framerate stark sinkt.
          
          DummyImage = CopyImage(CoverZBuff(n)\ImageID, #PB_Any)
          ResizeImage(DummyImage, CoverZBuff(n)\Width, CoverZBuff(n)\Height)
          DrawAlphaImage(ImageID(DummyImage),CoverZBuff(n)\XPos, CoverZBuff(n)\YPos)
          FreeImage(DummyImage)
          
          ; Sollte die "on-the-fly" Verkleinerung nicht benötigt werden, so kann nachfolgende Zeile statt der vorstehenden 4 Zeilen aktiviert werden.
          ; hierdurch steigt die Performance enorm - trotz Spiegelbild mit ECHTEM Alpha-Kanal.
          
          ;             DrawAlphaImage(ImageID(CoverZBuff(n)\ImageID),CoverZBuff(n)\XPos, CoverZBuff(n)\YPos)
        Else
          
          ; ------ Anzeige der Images mit Spiegelbild, welches auf einen einfarbigen Hintergrund geblendet wurde -------
          
          DrawImage(ImageID(CoverZBuff(n)\ImageID),CoverZBuff(n)\XPos, CoverZBuff(n)\YPos, CoverZBuff(n)\Width, CoverZBuff(n)\Height)
          
        EndIf
      Next
      DrawingMode(#PB_2DDrawing_Transparent)
      DrawText((ScrWidth-TextWidth(CoverZBuff(n-1)\CoverName))/2, ScrHeight - 30, CoverZBuff(n-1)\CoverName, $888888, $0)
      DrawText(10,ScrHeight - 30,Str(ElapsedMilliseconds()-starttime)+"ms/Frame",$444444)
      StopDrawing()
    EndIf
    FlipBuffers()
    OldWinkel = AktWinkel
  EndIf
  If KeyboardPushed(#PB_Key_Escape)
    Quit = #True
  EndIf
Wend

; ggfl. die heruntergeladenen Cover wieder löschen
If DeleteCoverImages
  ForEach CoverFiles()
    DeleteFile(CoverFiles())
  Next
EndIf

DataSection
  CoverFileNames:
  Data.s "http://www.fan-lexikon.de/musik/depeche-mode/bilder/m/depeche-mode-the-best-of-volume-1-cover-8981.jpg"
  Data.s "http://www.fan-lexikon.de/musik/depeche-mode/bilder/m/depeche-mode-a-broken-frame-cover-8980.jpg"
  Data.s "http://www.fan-lexikon.de/musik/depeche-mode/bilder/m/depeche-mode-music-for-the-masses-cover-8977.jpg"
  Data.s "http://www.fan-lexikon.de/musik/depeche-mode/bilder/m/depeche-mode-construction-time-again-cover-8974.jpg"
  Data.s "http://www.fan-lexikon.de/musik/depeche-mode/bilder/m/depeche-mode-the-singles-81-98-cover-8972.jpg"
  Data.s "http://www.fan-lexikon.de/musik/depeche-mode/bilder/m/depeche-mode-speak-and-spell-cover-8976.jpg"
  Data.s "http://www.fan-lexikon.de/musik/depeche-mode/bilder/m/depeche-mode-violator-cover-8978.jpg"
  Data.s "http://www.fan-lexikon.de/musik/seal/bilder/m/seal-i-cant-stand-the-rain-cover-9837.jpg"
  Data.s "http://www.fan-lexikon.de/musik/seal/bilder/m/seal-soul-cover-9826.jpg"
  Data.s "http://www.fan-lexikon.de/musik/seal/bilder/m/seal-amazing-single-cover-4416.jpg"
  Data.s ""
  Data.s ""
  Data.s ""
  Data.s ""
  Data.s ""
  Data.s ""
  Data.s ""
EndDataSection
Créé le 30 mars 2011  par PureLust

Les sources présentées sur cette page sont libres de droits et vous pouvez les utiliser à votre convenance. Par contre, la page de présentation constitue une œuvre intellectuelle protégée par les droits d'auteur. Copyright © 2008 Developpez Developpez LLC. Tous droits réservés Developpez LLC. Aucune reproduction, même partielle, ne peut être faite de ce site ni de l'ensemble de son contenu : textes, documents et images sans l'autorisation expresse de Developpez LLC. Sinon vous encourez selon la loi jusqu'à trois ans de prison et jusqu'à 300 000 € de dommages et intérêts.