GDI+ Impossible Possible build 2018-03-24 [Windows only!]

[UEZ]

I was inspired by https://lab.hakim.se/hypnos and thought how can this be adapted to FB using native gfx functions but did not find a way. So I decided to code it using GDI+ again -> thus windows only!

Should work with x86 and x64.

Code: Select all

'coded by UEZ build 2018-03-24
'inspirated by https://lab.hakim.se/hypnos/

#Include "fbgfx.bi"

#Ifdef __FB_64BIT__
    #Inclib "gdiplus"
    #Include once "win/gdiplus-c.bi"
#Else
    #Include once "win/gdiplus.bi"
    using gdiplus
#Endif

Using FB

Dim Shared As Any Ptr hCanvas, hPen, hBrush

Declare Sub _Paint()
Declare Sub PaintLayer(iPos As Ushort, bMask As Ubyte = 0, hB As Any Ptr = hBrush)
Declare Sub PaintLayer2(iPos As Ushort)


'init GDIPlus
Dim Shared gdipToken As ULONG_PTR
Dim Shared GDIp As GdiplusStartupInput
GDIp.GdiplusVersion = 1
If GdiplusStartup(@gdipToken, @GDIp, NULL) <> 0 Then End
'--------------------------------------------------------


Const As Ushort iW = 600, iH = 600, iWh = iW \ 2, iHh = iH \ 2


ScreenControl SET_DRIVER_NAME, "GDI"
ScreenRes iW, iH, 32, 1, GFX_HIGH_PRIORITY Or GFX_NO_SWITCH

Dim As String sTitle = "GDI+ Impossible Possible"
WindowTitle sTitle

'center windows by adding the taskbar to the calculation
Dim as Integer iDW, iDH
ScreenControl GET_DESKTOP_SIZE, iDW, iDH
Dim tWorkingArea As RECT
SystemParametersInfo(SPI_GETWORKAREA, null, @tWorkingArea, null)
ScreenControl SET_WINDOW_POS, (iDW - iW) \ 2, _
                              ((tWorkingArea.Bottom - iH) - (iDH - tWorkingArea.Bottom)) \ 2


'init GDI / GDI+ canvas, pens, brushes, etc. for drawing
Dim as HWND hHWND
ScreenControl(FB.GET_WINDOW_HANDLE, Cast(Integer, hHWND))

Dim As Any Ptr hDC = GetDC(hHWND), _
               hHBitmap = CreateCompatibleBitmap(hDC, iW, iH), _
               hDC_backbuffer = CreateCompatibleDC(hDC), hObjOld

hObjOld = SelectObject(hDC_backbuffer, hHBitmap)

GdipCreateFromHDC(hDC_backbuffer, @hCanvas)
GdipGraphicsClear(hCanvas, &hFFFFFFFF)
GdipSetSmoothingMode(hCanvas, SmoothingModeAntiAlias)
GdipSetPixelOffsetMode(hCanvas, PixelOffsetModeHalf)
GdipCreatePen1(&hC0000000, 2, 2, @hPen)
GdipCreateSolidFill(&hD0FFFFFF, @hBrush)


Dim Shared As Any Ptr hBitmap, hGfx, hTexture
   
Type tagRects
  x As Single
  y As Single
  a As Single
End Type

Const As Single fPi = Acos(-1), f2Pi = 2 * fPi
Dim Shared As Ushort iQuantity

iQuantity = 180

Dim Shared As tagRects tRect(iQuantity)
Dim Shared As Single fRadius, fSize, fOverlap

fRadius = Min(iW, iH) * 0.5
fSize = fRadius * 0.25
fOverlap = iQuantity * 0.1

Dim As Ushort i

For i = 0 To iQuantity - 1
   tRect(i).x = iWh + Sin(i / iQuantity * f2Pi) * (fRadius - fSize)
   tRect(i).y = iHh + Cos(i / iQuantity * f2Pi) * (fRadius - fSize)
   tRect(i).a = i Shl 1
Next

GdipCreateBitmapFromScan0(iW, iH, 0, PixelFormat32bppARGB, 0, @hBitmap)
GdipGetImageGraphicsContext(hBitmap, @hGfx)
GdipSetPixelOffsetMode(hGfx, 4)
GdipSetSmoothingMode(hGfx, SmoothingModeAntiAlias)
   
Do
   GdipGraphicsClear(hCanvas, &hFFFFFFFF)
   _Paint()
   BitBlt(hDC, 0, 0, iW, iH, hDC_backbuffer, 0, 0, SRCCOPY)

   Sleep(10, 1)
Loop Until Len(Inkey())

'release resources
GdipDeleteGraphics(hGfx)
GdipDisposeImage(hBitmap)
SelectObject(hDC_backbuffer, hObjOld)
DeleteDC(hDC_backbuffer)
ReleaseDC(hHWND, hDC)
DeleteObject(hHBitmap)
GdipDeleteGraphics(hCanvas)
GdipDeletePen(hPen)
GdipDeleteBrush(hBrush)
GdiplusShutdown(gdipToken)

Sub _Paint()
   Dim i As Short
      
   For i = iQuantity - 1 To 0 Step - 1
      tRect(i).a += 1.25
      PaintLayer(i)
   Next
   
   GdipGraphicsClear(hGfx, 0)
   For i = iQuantity - 1 To iQuantity - fOverlap Step - 1
      PaintLayer2(i)
   Next
   GdipCreateTexture(hBitmap, 0, @hTexture)   
   GdipRotateTextureTransform(hTexture, -tRect(0).a, 0)
   GdipTranslateTextureTransform(hTexture, -tRect(0).x, -tRect(0).y, 0)
   PaintLayer(0, 1, hTexture)
   GdipDeleteBrush(hTexture)
End Sub

Sub PaintLayer(iPos As Ushort, bMask As Ubyte = 0, hB As Any Ptr = hBrush)
   Dim As Single size, size2
   
   size = fSize + Iif(bMask, 10, 0)
   size2 = size / 2
   
   GdipTranslateWorldTransform(hCanvas, tRect(iPos).x, tRect(iPos).y, 0)
   GdipRotateWorldTransform(hCanvas, tRect(iPos).a, 0)

   If bMask = 0 Then
      GdipDrawRectangle(hCanvas, hPen, -size2, -size2, size, size)   
   End If
   GdipFillRectangle(hCanvas, hB, -size2, -size2, size, size)
   
   GdipResetWorldTransform(hCanvas)
End Sub

Sub PaintLayer2(iPos As Ushort)
   Dim As Single size, size2

   size = fSize
   size2 = size / 2
   
   GdipTranslateWorldTransform(hGfx, tRect(iPos).x, tRect(iPos).y, 0)
   GdipRotateWorldTransform(hGfx, tRect(iPos).a, 0)

   GdipDrawRectangle(hGfx, hPen, -size2, -size2, size, size)   
   GdipFillRectangle(hGfx, hBrush, -size2, -size2, size, size)
   
   GdipResetWorldTransform(hGfx)
   
End Sub


If you know a way to use FB native gfx commands only, please post it.

Edit1: changed formula to create angle

[dodicat]

Thanks UEZ
Nice graphics.
For native graphics, not so well smoothed here.
The main difficulty was merging one end to another.
I cheated by transferring one bit of as image to another place (rotated 180 degrees)
Not perfect of course!

As usual with direct pixels, use 32 bit -gen gas or -gen gcc with -O3 optimisation.
64 bit is too slow (useless).

Code: Select all


Type screendata
    As Integer w,h,depth,pitch
    As Any Pointer row
    as long p
End Type

Sub bline(sd As screendata,x1 As long,y1 As long,x2 As long,y2 As long,col As Ulong)
    #define ppset32(_x,_y,colour)    *cptr(ulong ptr,sd.row+ (_y)*sd.pitch+ (_x) shl 2)  =(colour)
    #define ppset8(_x,_y,colour)     *cptr(ubyte ptr,(sd.row+(_y)* sd.pitch+(_x)))       =(colour)
    #define ppset16(_x,_y,colour)    *cptr(ushort ptr,(sd.row+(_y)* sd.pitch+(_x) shl 1))=(colour)
    #define onscreen(n) ((x1)>=0) And ((x1)<(sd.w-n)) And ((y1)>=0) And ((y1)<(sd.h-n))
    Var dx=Abs(x2-x1),dy=Abs(y2-y1),sx=Sgn(x2-x1),sy=Sgn(y2-y1)
    dim as long e
    If dx<dy Then  e=dx\2 Else e=dy\2
    Do
                If onscreen(sd.p) Then
                  ppset32((x1),(y1),col)
                  ppset32((x1),(y1+1),col)
                  ppset32((x1+1),(y1),col)
                  ppset32((x1+1),(y1+1),col) 
                End If
       
        If x1 = x2 Then If y1 = y2 Then Exit Do
        If dx > dy Then
            x1 += sx : e -= dy : If e < 0 Then e += dx : y1 += sy
        Else
            y1 += sy : e -= dx : If e < 0 Then e += dy : x1 += sx
        End If
    Loop
End Sub

'rotate/scale one image into another
Function rotate(im As Any Ptr,angle As Single,shiftx As Long=0,shifty As Long=0,sc As Single=1, tmp As Any Ptr) As Any Ptr
    Static As Integer pitch,pitchs,xres,yres,runflag
    Static As Any Ptr row
    Static As Integer ddx,ddy,resultx,resulty
    Imageinfo im,ddx,ddy,,pitch,row
    Dim As Any Ptr rowS
    Imageinfo tmp,xres,yres,,pitchS,rows
    Dim As Long centreX=ddx\2,centreY=ddy\2
    Dim As Single sx=Sin(angle)
    Dim As Single cx=Cos(angle)
    Dim As Long mx=Iif(ddx>=ddy,ddx,ddy),shftx,shfty
    Var fx=sc*.7071067811865476,sc2=1/sc
     shiftx+=centreX*sc-centrex
     shiftY+=centrey*sc-centrey
    For y As Long=centrey-fx*mx+1 To centrey+ fx*mx
        Dim As Single sxcy=Sx*(y-centrey),cxcy=Cx*(y-centrey)
        shfty=y+shifty
        For x As Long=centrex-mx*fx To centrex+mx*fx
                 If x+shiftx >=0 Then
                    If x+shiftx <xres Then
                        If shfty >=0 Then
                            If shfty<yres Then
            resultx=sc2*(Cx*(x-centrex)-Sxcy) +centrex:resulty=sc2*(Sx*(x-centrex)+Cxcy) +centrey
                If resultx >=0 Then
                    If resultx<ddx Then
                        If resulty>=0 Then
                            If resulty<ddy Then
    *Cast(Ulong Ptr,rowS+pitchS*(y+shifty)+(x+shiftx) Shl 2)= _
    *Cast(Ulong Ptr,row+pitch*((resultY))+((resultX)) Shl 2 )
                End If:End If:End If:End If
                End If:End If:End If:End If
        Next x
    Next y
    Return 0
End Function

Screen 20,32
Color ,Rgb(255,255,255)

Dim As Any Ptr tmp=Imagecreate(1024,768)
Dim As Any Ptr b=Imagecreate(201,201,Rgb(255,255,255))
Dim As Any Ptr c=Imagecreate(201,201,Rgb(255,255,255))

Dim As Long cx=1024/2,cy=768/2-50
Dim As Any Ptr i=Imagecreate(100,100,Rgb(255,255,255))
Dim  As screendata S
With S
    imageinfo i,.w,.h,.depth,.pitch,.row
    .p=1
End With
'draw square on image
bline(s,1,1,98,1,0)
bline(s,98,1,98,98,0)
bline(s,98,98,1,98,0)
bline(s,1,98,1,1,0)

Dim As Double pi2=8*Atn(1),a

Do
    a+=.05
 'clear the images with white   
Line tmp,(0,0)-(1024,768),Rgb(255,255,255),bf
Line b,(0,0)-(500,500),Rgb(255,255,255),bf
Line c,(0,0)-(500,500),Rgb(255,255,255),bf

screenlock
cls

For z As Single=0 To pi2 Step .049
    Var x=cx+250*Cos(z),y=cy+250*Sin(z)
    rotate(i,a,x,y,1,tmp)
Next

Get tmp,(200,384-100)-(400,384+100),b
rotate(b,pi2/2,0,0,1,c)
Put(0,0),tmp,Pset
Put(723,284),c,Pset

Screenunlock
Sleep 1,1
Loop Until Len(Inkey)
Sleep
imagedestroy tmp
imagedestroy b
imagedestroy c

[UEZ]

...The main difficulty was merging one end to another...

Exactly, that was the main challenge to get this run properly. In the GDI+ version there is also some cheating. :-P

Is there a function within the code editors to tidy the code? Otherwise to read your code is very hard for me. :-)
Anyhow nice implementation.

I've also some ideas how to implement it with native FB gfx functions...

[dodicat]

I have tidied up a little and added another twist (Like yours)

Code: Select all

 


'rotate/scale one image into another(scale is 1 as default)
sub rotate(im As Any Ptr,angle As Single,shiftx As Long=0,shifty As Long=0,sc As Single=1, tmp As Any Ptr)
    Static As Integer pitch,pitchs,xres,yres,runflag
    Static As Any Ptr row
    Static As Integer ddx,ddy,resultx,resulty
    Imageinfo im,ddx,ddy,,pitch,row      'get pixel data for im
    Dim As Any Ptr rowS
    Imageinfo tmp,xres,yres,,pitchS,rows 'get pixel data for tmp
    Dim As Long centreX=ddx\2,centreY=ddy\2
    Dim As Single sx=Sin(angle)
    Dim As Single cx=Cos(angle)
    Dim As Long mx=Iif(ddx>=ddy,ddx,ddy),shftx,shfty
    Var fx=sc*.7071067811865476,sc2=1/sc
    'tweaked to avoid moire spaces
     shiftx+=centreX*sc-centrex
     shiftY+=centrey*sc-centrey
     'loop through im pixels and transfer to tmp
    For y As Long=centrey-fx*mx+1 To centrey+ fx*mx
        Dim As Single sxcy=Sx*(y-centrey),cxcy=Cx*(y-centrey)
        shfty=y+shifty
        For x As Long=centrex-mx*fx To centrex+mx*fx
            'The pixel positions must be clipped in each image (if..if... ...) else a CRASH
                 If x+shiftx >=0 Then
                    If x+shiftx <xres Then
                        If shfty >=0 Then
                            If shfty<yres Then
            resultx=sc2*(Cx*(x-centrex)-Sxcy) +centrex:resulty=sc2*(Sx*(x-centrex)+Cxcy) +centrey
                If resultx >=0 Then
                    If resultx<ddx Then
                        If resulty>=0 Then
                            If resulty<ddy Then
                                'direct pixel (pset(on tmp) (point(on im))
    *Cast(Ulong Ptr,rowS+pitchS*(y+shifty)+(x+shiftx) Shl 2)= _ 'pset bit
    *Cast(Ulong Ptr,row+pitch*((resultY))+((resultX)) Shl 2 )   'point bit
                End If:End If:End If:End If
                End If:End If:End If:End If
        Next x
    Next y
End sub

Screen 20,32,,64 'use an alpha screen to assist anti alaising

Dim As Any Ptr tmp=Imagecreate(1024,768)              'main image whole screen
Dim As Any Ptr b=Imagecreate(201,201,Rgb(255,255,255))'small image to catch a good part of main image
Dim As Any Ptr c=Imagecreate(201,201,Rgb(255,255,255))'to transfer small image  to

Dim As Long cx=1024/2,cy=768/2-50 'screen centre approx
Dim As Any Ptr i=Imagecreate(100,100,Rgb(255,255,255))'the image containing a box
'draw square on image
'try  anti alaising a little
for k as long=0 to 4
    dim as long a '(alpha value)
    select case k
    case 0:a=50
    case 1:a=150
    case 2:a=255
    case 3:a=150
    case 4:a=50
    end select
line i,(k,k)-(99-k,99-k),rgba(0,0,0,a),b 'draw the square to i
next k

Dim As Double pi2=8*Atn(1),a 'a=rotate angle

Do
    a+=.05
 'clear the images with white   
Line tmp,(0,0)-(1024,768),Rgb(255,255,255),bf
Line b,(0,0)-(500,500),Rgb(255,255,255),bf
Line c,(0,0)-(500,500),Rgb(255,255,255),bf

screenlock
'direct pixels must be in a locked screen (rotate)
For z As Single=0 To pi2 Step .049
    Var x=cx+250*Cos(z),y=cy+250*Sin(z)
    rotate(i,z+a,x,y,1,tmp)'draw the images around a circle (twisting) to the main image
Next

Get tmp,(200,384-100)-(400,384+100),b 'get a good part of the main image
rotate(b,pi2/2,0,0,1,c)               'transfer the good part to image c (rotated 180 degrees)
Put(0,0),tmp,pset                     'place the main image on the screen
Put(723,284),c,pset                   'this (c) is the patch over the ends

Screenunlock
Sleep 1,1
Loop Until Len(Inkey)
Sleep
imagedestroy tmp
imagedestroy b
imagedestroy c
imagedestroy i

[UEZ]

Looks very good dodicat - thx. :-)

By code tidy I mean more the code formatting in the editor. ^^

If you change the value

Code: Select all

...
tRect(i).a = i Shl 1
...


you can add more twists.

Unfortunately GDI+ is very slow and thus limited. :-( but it has rich gfx function repertoire.

[MrSwiss]

Unfortunately GDI+ is very slow and thus limited. :-( but it has rich gfx function repertoire.

The same probably applies to OpenGL, with the advantage of beeing: multi OS (WIN/LIN).

[UEZ]

Unfortunately GDI+ is very slow and thus limited. :-( but it has rich gfx function repertoire.

The same probably applies to OpenGL, with the advantage of beeing: multi OS (WIN/LIN).

Yep, working since this morning on a OpenGL version but it will take some time as I'm absolutely a newbie on OpenGL.

Current state:

Code: Select all

#include once "GL/gl.bi"
#include once "GL/glu.bi"

#Define Min(a, b)   Iif(a < b, a, b)

Const As UShort iW = 600, iH = iW, iWh = iW \ 2, iHh = iH \ 2
Const As ULong  iBGColor = &hFFFFFF

ScreenRes iW, iH, 32, , &h2 or &h0
Color 0, iBGColor

Type tagRects
  x As Single
  y As Single
  a As Single
End Type

Const As Single fPi = Acos(-1), f2Pi = 2 * fPi, fRad = fPi / 180
Dim Shared As Ushort iQuantity

iQuantity = 180

Dim Shared As tagRects tRect(iQuantity)
Dim Shared As Single fRadius, fSize, fSize2, fOverlap, x1, y1, x2, y2, x3, y3, x4, y4, cx, cy, r, vx, vy

fRadius = Min(iW, iH) * 0.5
fSize = fRadius * 0.25
fOverlap = iQuantity * 0.1
fSize2 = fSize / 2

Dim As Ushort i, j

For i = 0 To iQuantity - 1
   tRect(i).x = (iWh - fSize2) + Cos(i / iQuantity * f2Pi) * (fRadius - fSize)
   tRect(i).y = (iHh - fSize2) + Sin(i / iQuantity * f2Pi) * (fRadius - fSize)
   tRect(i).a = i Shl 2
Next


glMatrixMode(GL_PROJECTION)         ' Matrix definieren
glLoadIdentity
glViewport(0, 0, iW, iH)            ' Achse festlegen
glOrtho(0, iW, iH, 0, -128, 128)
glMatrixMode(GL_MODELVIEW)          ' Deaktivierung des Rendern der Rückseiten
glEnable(GL_CULL_FACE)
glCullFace(GL_BACK)
glEnable(GL_TEXTURE_2D)              ' Texturen aktivieren
glLoadIdentity
glEnable(GL_DEPTH_TEST)             ' Tiefentest
glDepthFunc(GL_LESS)
glEnable(GL_ALPHA_TEST)             ' Alphatest
glAlphaFunc(GL_GREATER, 0.1)
glClearColor(1.0, 1.0, 1.0, 0.5)


Do
   glClear(GL_COLOR_BUFFER_BIT OR GL_DEPTH_BUFFER_BIT)

   For i = 0 To iQuantity - 1
      x1 = tRect(i).x
      y1 = tRect(i).y
      x2 = x1 + fSize
      y2 = y1 + fSize
      vx = (x2 - x1)
      vy = (y2 - y1)
      cx = x1 + vx / 2
      cy = y1 + vy / 2
      r = Sqr((y2 - y1) * (y2 - y1) + (x2 - x1) * (x2 - x1)) / 2
      
      x1 = cx + Cos(tRect(i).a * fRad) * r
      y1 = cy + Sin(tRect(i).a * fRad) * r
      x2 = cx + Cos((90 + tRect(i).a) * fRad) * r
      y2 = cy + Sin((90 + tRect(i).a) * fRad) * r
      x3 = cx + Cos((180 + tRect(i).a) * fRad) * r
      y3 = cy + Sin((180 + tRect(i).a) * fRad) * r
      x4 = cx + Cos((270 + tRect(i).a) * fRad) * r
      y4 = cy + Sin((270 + tRect(i).a) * fRad) * r

      glPolygonMode(GL_FRONT_AND_BACK, GL_FILL)
      glColor3f(1.0, 1.0, 1.0)
      glBegin(GL_POLYGON)
         glVertex2i (x4, y4)    '' LINKS UNTEN  (1. Koordinate)
         glVertex2i (x3, y3)    '' RECHTS UNTEN (2. Koordinate)
         glVertex2i (x2, y2)    '' RECHTS OBEN  (3. Koordinate)
         glVertex2i (x1, y1)    '' LINKS OBEN   (4. Koordinate)
      glEnd()   
      
      glPolygonMode(GL_FRONT_AND_BACK, GL_LINE)
      glLineWidth(2)
      glColor3f(0.0, 0.0, 0.0)
      glBegin(GL_POLYGON)
         glVertex2i (x4, y4)    '' LINKS UNTEN  (1. Koordinate)
         glVertex2i (x3, y3)    '' RECHTS UNTEN (2. Koordinate)
         glVertex2i (x2, y2)    '' RECHTS OBEN  (3. Koordinate)
         glVertex2i (x1, y1)    '' LINKS OBEN   (4. Koordinate)
      glEnd()            
      glFlush() ' Verarbeitung der Befehle
            
      
      tRect(i).a += 0.75
   Next

   Flip

    Sleep 1, 1
Loop Until Len(InKey())