# Sources PureBasicConsultez toutes les sources

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

Sommaire→Images

- Affichage d'un texte sur toute la diagonale d'une image
- Déformation d'une image
- Quelques exemples d'utilisation de la fonction CustomFilterCallback()
- Démo : Contour d'un texte dans une image, avec de très jolis effets.
- Codage informatique des couleurs : RGB, CMY, HLS, HSL (HLS, HSI)
- Lotus démo , ou un nouvel exemple avec CustomFilterCallback()
- Réaliser une interface de type 'Cover Flow'

Version hors-ligne
Affichage d'un texte sur toute la diagonale d'une image

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
Déformation d'une image

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
Quelques exemples d'utilisation de la fonction CustomFilterCallback()

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
Démo : Contour d'un texte dans une image, avec de très jolis effets.

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
Codage informatique des couleurs : RGB, CMY, HLS, HSL (HLS, HSI)
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
Lotus démo , ou un nouvel exemple avec CustomFilterCallback()
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
Réaliser une interface de type 'Cover Flow'

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
Version hors-ligne

Les sources présentés sur cette page sont libres de droits et vous pouvez les utiliser à votre convenance. Par contre cette page de présentation de ces sources constitue une œuvre intellectuelle protégée par les droits d'auteurs. Copyright ©2008 Developpez LLC. Tous droits réservés Developpez LLC. Aucune reproduction, même partielle, ne peut être faite de ce site et 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.