Das deutsche QBasic- und FreeBASIC-Forum Foren-Übersicht Das deutsche QBasic- und FreeBASIC-Forum
Für euch erreichbar unter qb-forum.de, fb-forum.de und freebasic-forum.de!
 
FAQFAQ   SuchenSuchen   MitgliederlisteMitgliederliste   BenutzergruppenBenutzergruppen  RegistrierenRegistrieren
ProfilProfil   Einloggen, um private Nachrichten zu lesenEinloggen, um private Nachrichten zu lesen   LoginLogin
Zur Begleitseite des Forums / Chat / Impressum
Aktueller Forenpartner:

Gfx Spielereien
Gehe zu Seite Zurück  1, 2, 3, 4, 5, 6  Weiter
 
Neues Thema eröffnen   Neue Antwort erstellen    Das deutsche QBasic- und FreeBASIC-Forum Foren-Übersicht -> Projektvorstellungen
Vorheriges Thema anzeigen :: Nächstes Thema anzeigen  
Autor Nachricht
Sebastian
Administrator


Anmeldungsdatum: 10.09.2004
Beiträge: 5969
Wohnort: Deutschland

BeitragVerfasst am: 04.03.2018, 18:25    Titel: Antworten mit Zitat

Cool! lächeln
_________________

Der Markt regelt das! | Opas Leistung muss sich wieder lohnen - für 6 bis 10 Generationen!
Nach oben
Benutzer-Profile anzeigen Private Nachricht senden E-Mail senden Website dieses Benutzers besuchen
nemored



Anmeldungsdatum: 22.02.2007
Beiträge: 4594
Wohnort: ~/

BeitragVerfasst am: 04.03.2018, 20:34    Titel: Antworten mit Zitat

Dem kann ich mich nur anschießen. Sehr hübsch!
_________________
Deine Chance beträgt 1:1000. Also musst du folgendes tun: Vergiss die 1000 und konzentriere dich auf die 1.
Nach oben
Benutzer-Profile anzeigen Private Nachricht senden
UEZ



Anmeldungsdatum: 24.06.2016
Beiträge: 129
Wohnort: Opel Stadt

BeitragVerfasst am: 27.04.2018, 12:53    Titel: Simple Recursive Tree Generator Antworten mit Zitat

Rekursive Baum Generierung (prozedurale Grafik)



Code:

'coded by UEZ build 2018-04-27
'thanks to dodicat for the DrawThickLine function
'use 64-bit compilation for faster progress

#include "string.bi"
#include "fbgfx.bi"
#if __FB_LANG__ = "fb"
   Using FB '' Scan code constants are stored in the FB namespace in lang FB
#endif

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

Declare Sub DrawRecTree(x As Single, y As Single, length As Single, angle As Single, col As Ulong)
Declare Sub DrawThickLine(Byval x1 As Integer, Byval y1 As Integer, Byval x2 As Integer, Byval y2 As Integer, Byval size As Integer, Byval c As Uinteger)


Const As Ushort iW = 1200, iH = 800, iCenterX = iW \ 2, iCenterY = iH \ 2
Const As Single fD2R = Acos(-1) / 180, thresholdBloom = 0.03, treeSize = 0.275
Const As Ubyte maxLevel = 14, bloomLevel = Cubyte(maxLevel * 0.75), lineThickness = 10, maxBloomSize = 8
Const As Ulong bloomColor = &h910F66, colorTree = &h800

Screenres iW, iH, 32, , GFX_WINDOWED Or GFX_NO_SWITCH
Color 0, &hA0A0A0
Cls

'======================= maybe needed later
Dim Shared As Integer w, h, depth, bpp, bpsl
ScreenInfo w, h, depth, bpp, bpsl
Dim Shared As Any Ptr pScreen
pScreen = Screenptr()
'=======================

Windowtitle("Simple Recursive Tree Generator v0.90 / " & Format((3^maxLevel) Shr 1, "#,##") & " function calls")
Randomize

Dim Shared As Ulong level
level = 0

DrawRecTree(iCenterX, iH, 90, -90, colorTree)
Draw String(10, 10), "Press space / lmb to regenerate tree", &hFFFFFF

Dim As Single fTimer
Dim As Integer x, y, buttons

Do   
   Getmouse(x, y, , buttons)
   If Multikey(SC_SPACE) Or buttons = 1 Then
      fTimer = Timer()
      Cls
      Screenlock
      DrawRecTree(iCenterX, iH, 90, -90, colorTree)
      Screenunlock
      Draw String(10, iH - 10), Format((Timer() - fTimer) * 1000, "0.0000") & " ms", &hFFFFFF
   End If
    Sleep 50, 1
Loop Until Multikey(SC_ESCAPE)


Sub DrawRecTree(x As Single, y As Single, length As Single, angle As Single, col As Ulong)
   level += 1
   Dim As Single destX, destY, col2
   destX = x + length * Cos(angle * fD2R)
   destY = y + length * Sin(angle * fD2R)
   
   col += 256 * level

   If level > bloomLevel And Rnd() < thresholdBloom Then
      col = bloomColor 'this will overwrite the green color and will change the color of the branches, too.
      Circle (x, y), Min(maxBloomSize, (destX - x)), col, , , 1.25 + Rnd() / 4, F
   Else   
      DrawThickLine(x, y, destX, destY, 1 + lineThickness / level, col)
      'Line (x, y)-(destX, destY), col
   End If
   
   If level < maxLevel Then
       DrawRecTree(destX, destY, length * (1 + 3 * Rnd()) * treeSize, angle + 60 * (Rnd() - Rnd()), col)
       DrawRecTree(destX, destY, length * (1 + 3 * Rnd()) * treeSize, angle + 60 * (Rnd() - Rnd()), col)
       DrawRecTree(destX, destY, length * (1 + 3 * Rnd()) * treeSize, angle + 60 * (Rnd() - Rnd()), col)
   End If
   
   level -= 1
End Sub

Sub DrawThickLine(Byval x1 As Integer, Byval y1 As Integer, Byval x2 As Integer, Byval y2 As Integer, Byval size As Integer, Byval c As Uinteger) 'by dodicat
   If x1 = x2 And y1 = y2 Then
      Circle (x1, y1), size, c, , , , f
   Elseif Abs(x2 - x1) >= Abs(y2 - y1) Then
      Dim K As Single = (y2 - y1) / (x2 - x1)
      For I As Integer = x1 To x2 Step Sgn(x2 - x1)
        Circle (I, K * (I - x1) + y1), size, c, , , , f
      Next I
   Else
      Dim L As Single = (x2 - x1) / (y2 - y1)
      For J As Integer = y1 To y2 Step Sgn(y2 - y1)
        Circle (L * (J - y1) + x1, J), size, c, , , , f
      Next J
   End If
End Sub

_________________
Gruß,
UEZ


Zuletzt bearbeitet von UEZ am 12.10.2018, 12:01, insgesamt einmal bearbeitet
Nach oben
Benutzer-Profile anzeigen Private Nachricht senden
UEZ



Anmeldungsdatum: 24.06.2016
Beiträge: 129
Wohnort: Opel Stadt

BeitragVerfasst am: 05.07.2018, 18:59    Titel: GDI+ Star Wars Intro Antworten mit Zitat

GDI+ Star Wars Intro build 2018-07-07 [nur für Windows und als x86]:




Download mit allen nötigen Dateien (Audio + Font): http://www.mediafire.com/file/nncqb4e7ubnqs1x/GDI__Star_Wars_Scroller_v0.6_build_2018-07-07.zip/file


Source Code lauffähig ohne Audio und Font:
Code:

'coded by UEZ build 2018-07-07
'
'WINDOWS and x86 ONLY!!!

#Include "fbgfx.bi"
#include "file.bi"
#Include "win/gdiplus.bi"
Using gdiplus

Using FB

#Define CRLF  Chr(13) + Chr(10)


'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 = 854, iH = iW / 2, 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+ Star Wars Scroller v0.6 / FPS: "
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))

'Create canvas
Dim Shared As Any Ptr hCanvas, hPen, hBrush, hBrush_Warp, hBitmap, hGfx, hTexture, hFamily, hFamily_Logo, hFamily_Warp, _
                 hStringFormat, hStringFormat_Logo, hStringFormat_Warp, hFont, hFont2, hCollection, hPath_Logo, hPath_Warp, hPath_Temp
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)
GdipSetSmoothingMode(hCanvas, SmoothingModeAntiAlias)
GdipSetPixelOffsetMode(hCanvas, PixelOffsetModeHalf)
GdipSetTextRenderingHint(hCanvas, TextRenderingHintAntiAliasGridFit)

Dim As GpPointF StartPoint, EndPoint
StartPoint.x = iWh
StartPoint.y = -iHh * 0.25
EndPoint.x = iWh
EndPoint.y = iH
Dim As ULong iColorTxt1_RGB = &h001367FD, iColorTxt2_RGB = &hF8DA37, i
GdipCreateSolidFill(iColorTxt1_RGB, @hBrush)
GdipCreateSolidFill(&hFFD7A501, @hBrush_Warp)
GdipCreateLineBrush(@StartPoint, @EndPoint, &h00D7A501, &hFFD7A501, 0, @hBrush_Warp)
GdipSetLineGammaCorrection(hBrush_Warp, True)

GdipCreatePen1(iColorTxt2_RGB, 4, UnitPixel, @hPen)
GdipSetPenLineJoin(hPen, LineJoinRound)

'create font
Dim As GpRectF tLayout, tLayout_Logo, tLayout_Warp
tLayout.x = iW * 0.12
tLayout.y = 0
tLayout.Width = iW
tLayout.height = iH
GdipCreateFontFamilyFromName("Times New Roman", Null, @hFamily)
GdipCreateStringFormat(0, 0, @hStringFormat)
GdipCreateFont(hFamily, iH / 12.5, FontStyleBold, UnitPoint, @hFont)
GdipSetStringFormatLineAlign(hStringFormat, StringAlignmentCenter)
'GdipSetStringFormatAlign(hStringFormat, StringAlignmentFar)

'Create 2nd gfx buffer
GdipCreateBitmapFromScan0(iW, iH, 0, PixelFormat32bppARGB, 0, @hBitmap)
GdipGetImageGraphicsContext(hBitmap, @hGfx)
GdipSetPixelOffsetMode(hGfx, PixelOffsetModeHalf)
GdipSetSmoothingMode(hGfx, SmoothingModeAntiAlias)
GdipSetTextRenderingHint(hGfx, TextRenderingHintAntiAliasGridFit)

'create some Random stars
Dim As Ulong aColor(0 To 6) = {&hFFFFFFFF, &hFFDDDDDD, &hFFBBBBBB, &hFF999999, &hFF777777, &hFF555555, &hFF333333}
For i As Ulong = 1 To 2000
   GdipBitmapSetPixel(hBitmap, Rnd() * iW, Rnd() * iH, aColor(Int(Rnd() * 6)))
Next


'create STAR WARS logo
tLayout_Logo.x = -iWh
tLayout_Logo.y = -iHh
tLayout_Logo.Width = iW * 2
tLayout_Logo.height = iH * 2

Dim As Ubyte bFont = 1
If Fileexists(Curdir & "\Death Star.otf") = 0 Then
   GdipCreateFontFamilyFromName("Impact", Null, @hFamily_Logo)
   bFont = 0
Else
   GdipNewPrivateFontCollection(@hCollection)
   GdipPrivateAddFontFile(hCollection, Curdir & "\Death Star.otf")
   GdipCreateFontFamilyFromName("Death Star", hCollection, @hFamily_Logo)
EndIf

GdipCreatePath(FillModeAlternate, @hPath_Logo)
GdipCreateStringFormat(0, 0, @hStringFormat_Logo)
GdipSetStringFormatAlign(hStringFormat_Logo, StringAlignmentCenter)
GdipSetStringFormatLineAlign(hStringFormat_Logo, StringAlignmentCenter)


'create warp
Dim As String aWarpText(26) = {   _
   "It  is  a  period  of civil war.", _
   "Rebel  spaceships,  striking", _
   "from  a  hidden base, have", _
   "won    their   first   victory", _
   "against  the  evil  Galactic", _
   "Empire.", _
   " ", _
   "During   the   battle,  rebel", _
   "spies   managed   to   steal", _
   "secret plans to the Empire's", _
   "ultimate     weapon,      the", _
   "Death Star, an armored space", _
   "station       with       enough", _
   "power  to destroy an entire", _
   "planet.", _
   " ", _
   "Pursued   by  the  Empire's", _
   "sinister   agents,   Princess", _
   "Leia races home aboard her", _
   "starship,  custodian  of the", _
   "stolen  plans that can save", _
   "her   people   and   restore", _
   "freedom  to the  galaxy....", _
   " ", _
   " ", _
   "Intro  coded by  UEZ :-)"}

             
GdipCreatePath(FillModeAlternate, @hPath_Warp)
GdipCreatePath(FillModeAlternate, @hPath_Temp)

GdipCreateStringFormat(0, 0, @hStringFormat_Warp)
GdipSetStringFormatAlign(hStringFormat_Warp, 0)
GdipSetStringFormatLineAlign(hStringFormat_Warp, 0)
GdipCreateFontFamilyFromName("Verdana", 0, @hFamily_Warp)

Dim As GpRectF tRECTF_Bound
Dim As Single fFontSize = iH / 6.6875

For i = 0 To Ubound(aWarpText)
   tLayout_Warp.y = i * (fFontSize + 5)
   GdipAddPathString(hPath_Warp, aWarpText(i), -1, hFamily_Warp, FontStyleRegular, (fFontSize + 5), @tLayout_Warp, hStringFormat_Warp)
Next
         
GdipGetPathWorldBounds(hPath_Warp, @tRECTF_Bound, Null, Null)

tLayout_Warp.X = 0
tLayout_Warp.Y = 0
tLayout_Warp.Width = tRECTF_Bound.Width
tLayout_Warp.Height = tRECTF_Bound.Height


Dim aPoints(3) AS GpPointF
aPoints(0).x = iW * 0.4
aPoints(0).y = iH * 0.33
aPoints(1).x = iW - iW * 0.4
aPoints(1).y = iH * 0.33
aPoints(2).x = -60
aPoints(2).y = iH
aPoints(3).x = iW
aPoints(3).y = iH



Sleep(250)
Dim As Ushort iFPS = 0, iStage = 1
Dim As Single fTimer, fAlpha = 0, fWait, fSize = iH * 1.168, y = iH * 1.45

Do
   GdipGraphicsClear(hCanvas, &hFF000000)
   
   Select Case iStage
      Case 1   
         If fAlpha < 255 Then
            fAlpha += 1
            GdipSetSolidFillColor(hBrush, fAlpha Shl 24 + iColorTxt1_RGB)
         Else
            fAlpha = 255
            fWait = Timer
            iStage += 1
         End If
         GdipDrawString(hCanvas, "A long time ago in a galaxy far," & CrLf & "far away....", -1, hFont, @tLayout, hStringFormat, hBrush)
     
      Case 2
         If Timer - fWait > 2.0 Then
            If fAlpha > 0 Then
               fAlpha -= 1
               GdipSetSolidFillColor(hBrush, fAlpha Shl 24 + iColorTxt1_RGB)
               GdipDrawString(hCanvas, "A long time ago in a galaxy far," & CrLf & "far away....", -1, hFont, @tLayout, hStringFormat, hBrush)
            Else
               iStage += 1
               GdipSetSolidFillColor(hBrush, &hFF000000)
               fAlpha = 255
            End If
         Else
            GdipDrawString(hCanvas, "A long time ago in a galaxy far," & CrLf & "far away....", -1, hFont, @tLayout, hStringFormat, hBrush)   
         End If   
         
      Case 3
         GdipDrawImageRect(hCanvas, hBitmap, 0, 0, iW, iH)
   
         If fSize > 1 And fAlpha > 0 Then
            GdipAddPathString(hPath_Logo, "STAR" & CrLf & "WARS", -1, hFamily_Logo, FontStyleRegular, fSize, @tLayout_Logo, hStringFormat_Logo)
            GdipFillPath(hCanvas, hBrush, hPath_Logo)
            GdipDrawPath(hCanvas, hPen, hPath_Logo)
            GdipResetPath(hPath_Logo)
            'GdipSetSolidFillColor(hBrush, fAlpha Shl 24)
            GdipSetPenColor(hPen, fAlpha Shl 24 + iColorTxt2_RGB)
            fSize -= 1.0
            fAlpha -= 0.475
         EndIf
   
     
         GdipResetPath(hPath_Warp)
         For i = 0 To Ubound(aWarpText)
            GdipResetPath(hPath_Temp)
            tLayout_Warp.Y = i * fFontSize + y
            GdipAddPathString(hPath_Temp, aWarpText(i), -1, hFamily_Warp, FontStyleRegular, fFontSize, @tLayout_Warp, hStringFormat_Warp)
            GdipGetPathWorldBounds(hPath_Temp, @tRECTF_Bound, Null, Null)
            If tRECTF_Bound.Y > -iH And tRECTF_Bound.Y <= iH + 30 Then
               GdipAddPathString(hPath_Warp, aWarpText(i), -1, hFamily_Warp, FontStyleRegular, fFontSize, @tLayout_Warp, hStringFormat_Warp)
            EndIf
         Next
         GdipWarpPath(hPath_Warp, Null, @aPoints(0), 4, 0, 0, iW, iH, WarpModePerspective, FlatnessDefault)
         
         GdipFillPath(hCanvas, hBrush_Warp, hPath_Warp)
         y -= 0.55
         If y < -2100 Then Exit Do
         
   End Select
   

   BitBlt(hDC, 0, 0, iW, iH, hDC_backbuffer, 0, 0, SRCCOPY)


     If Timer - fTimer > 0.99 Then
      WindowTitle sTitle & iFPS
      iFPS = 0
      fTimer = Timer
   Else
      iFPS += 1
   EndIf

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


'release resources
GdipDeletePath(hPath_Logo)
GdipDeletePath(hPath_Warp)
GdipDeletePath(hPath_Temp)
If bFont = 1 Then GdipDeletePrivateFontCollection(hCollection)
GdipDeleteFont(hFont)
GdipDeleteFontFamily(hFamily)
GdipDeleteFontFamily(hFamily_Logo)
GdipDeleteFontFamily(hFamily_Warp)
GdipDeleteStringFormat(hStringFormat)
GdipDeleteStringFormat(hStringFormat_Logo)
GdipDeleteStringFormat(hStringFormat_Warp)
GdipDeleteGraphics(hGfx)
GdipDisposeImage(hBitmap)
SelectObject(hDC_backbuffer, hObjOld)
DeleteDC(hDC_backbuffer)
ReleaseDC(hHWND, hDC)
DeleteObject(hHBitmap)
GdipDeleteGraphics(hCanvas)
GdipDeletePen(hPen)
GdipDeleteBrush(hBrush)
GdipDeleteBrush(hBrush_Warp)
GdiplusShutdown(gdipToken)


Möge die Macht mir dir sein. zwinkern
_________________
Gruß,
UEZ


Zuletzt bearbeitet von UEZ am 12.10.2018, 12:00, insgesamt einmal bearbeitet
Nach oben
Benutzer-Profile anzeigen Private Nachricht senden
UEZ



Anmeldungsdatum: 24.06.2016
Beiträge: 129
Wohnort: Opel Stadt

BeitragVerfasst am: 12.10.2018, 11:58    Titel: GDI / GDI+ Matrix Code Rain Antworten mit Zitat

GDI / GDI+ Matrix Code Rain (nur für Windows):



Code:

'Matrix Code Rain coded by UEZ v1.35 build 2018-10-12
'Windows only!

#Include "fbgfx.bi"
#Include "windows.bi"

#Ifdef __Fb_64bit__
    #Inclib "gdiplus"
    #Include Once "win/gdiplus-c.bi"
#Else
    #Include Once "win/gdiplus.bi"
    Using gdiplus
#Endif

Declare Function SetTimerInterval Lib "winmm" Alias "timeBeginPeriod" (As Ulong = 1) As Long ' dodicat snippet
Declare Function EndTimerInterval Lib "winmm" Alias "timeEndPeriod" (As Ulong = 1) As Long ' dodicat snippet

Using FB

Declare Function RandomRange(fStart as Single, fEnd as Single) as Single

#Define unicode

SetTimerInterval

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

Const As Ulong iW = 800, iH = 400

Dim As String sTitle = "The MATRIX v1.35 / FPS: "
Dim As Single fFontSize = 7.5, fPosX
Dim As UShort iFPS = 0, iW_Char = Cushort(fFontSize * 1.6666), iH_Char = Cushort(fFontSize * 1.6666), iAmountChars = 75, iMaxSpeed = 12, iMinSpeed = 4, i

Dim As Double fTime, fTimer

Screencontrol FB.SET_DRIVER_NAME, "GDI"
Screenres iW, iH, 32, 1, GFX_HIGH_PRIORITY Or GFX_NO_SWITCH
Windowtitle sTitle

Dim As HWND hHWND
Screencontrol(FB.GET_WINDOW_HANDLE, Cast(Integer, hHWND))

Dim as GpRectF  tLayout1, tLayout2
tLayout1.x = 0
tLayout1.y = 0
tLayout1.width = iW_Char
tLayout1.height = iH_Char
tLayout2.x = 0
tLayout2.y = 0
tLayout2.width = iW_Char
tLayout2.height = iH_Char

Dim As Any Ptr    hDC = GetDC(hHWND), _
            hHBitmap = CreateCompatibleBitmap(hDC, iW, iH), _
            hDC_backbuffer = CreateCompatibleDC(hDC), _
            hHBitmap2 = CreateCompatibleBitmap(hDC, iW, iH), _
            hDC_backbuffer2 = CreateCompatibleDC(hDC), _
            hCanvas, hCanvas2, hBrush_Clr, hBrush_Char, hBrush_CharGlow, hBrush_Bg, hFamily, hFont, hFont_Glow, hStringFormat, hGfx

Var hDC_obj = SelectObject(hDC_backbuffer, hHBitmap), hDC_obj2 = SelectObject(hDC_backbuffer2, hHBitmap2)
GdipCreateFromHDC(hDC_backbuffer, @hCanvas)
GdipCreateFromHDC(hDC_backbuffer2, @hCanvas2)
GdipSetSmoothingMode(hCanvas, SmoothingModeAntiAlias)
GdipSetPixelOffsetMode(hCanvas, PixelOffsetModeHalf)
GdipSetTextRenderingHint(hCanvas, TextRenderingHintAntiAlias)
GdipSetSmoothingMode(hCanvas2, SmoothingModeAntiAlias)
GdipSetPixelOffsetMode(hCanvas2, PixelOffsetModeHalf)
GdipSetTextRenderingHint(hCanvas2, TextRenderingHintAntiAlias)
GdipCreateStringFormat(0, 0, @hStringFormat)
GdipCreateFontFamilyFromName("Times New Roman", Null, @hFamily)
GdipCreateFont(hFamily, fFontSize, 1, 3, @hFont)
GdipCreateFont(hFamily, iW_Char, 1, 3, @hFont_Glow)
GdipSetStringFormatAlign(hStringFormat, StringAlignmentCenter)
GdipSetStringFormatLineAlign(hStringFormat, StringAlignmentCenter)
GdipCreateSolidFill(&h0D000000, @hBrush_Clr)
GdipCreateSolidFill(&hE8E8FFE8, @hBrush_Char)
GdipCreateLineBrushFromRectWithAngle(@tLayout2, &h1000FF00, &hE0A0FFA0, 0, False, 1, @hBrush_CharGlow)
GdipSetLineSigmaBlend(hBrush_CharGlow, 0.5, 1)
GdipSetLineGammaCorrection(hBrush_CharGlow, True)
GdipCreateHatchBrush(9, &hF0003800, &hFF000000, @hBrush_Bg)

Type tTable
   x As Single
   y As Single
   vy As Single
   c As integer
End Type

Dim As tTable aTable(0 To iAmountChars)

For i = 0 To iAmountChars - 1
   fPosX = Rnd() * (iW - iW_Char)
   aTable(i).x = fPosX - (fPosX Mod iW_Char)
   aTable(i).y = -fFontSize - RandomRange(10, 200)
   aTable(i).vy = RandomRange(iMinSpeed, iMaxSpeed)
   aTable(i).c = aTable(i).y - iH_Char - 1
Next

GdipGraphicsClear(hCanvas, &hFF000000)

Dim As Ushort iLen = 55, iChar = 0
Dim As Wstring * 2 aChars(iLen)
For i = 0 To iLen
   aChars(i) = WChr(i + 65382)
Next
Dim As WString * 2 sChar = aChars(0)

Type tPrePaintedChars
   hBitmap As Any Ptr
End Type

Dim As tPrePaintedChars aChars_pre(iLen, 2)
For i = 0 To iLen
   GdipCreateBitmapFromScan0(iW_Char, iH_Char, 0, PixelFormat32bppARGB, 0, @aChars_pre(i, 0).hBitmap)
   GdipGetImageGraphicsContext(aChars_pre(i, 0).hBitmap, @hGfx)
   GdipSetPixelOffsetMode(hGfx, PixelOffsetModeHalf)
   GdipSetTextRenderingHint(hGfx, TextRenderingHintAntiAlias)
   GdipSetSmoothingMode(hGfx, SmoothingModeAntiAlias)
   GdipDrawString(hGfx, aChars(i), -1, hFont_Glow, @tLayout1, hStringFormat, hBrush_CharGlow)
   GdipDeleteGraphics(hGfx)
   GdipCreateBitmapFromScan0(iW_Char, iH_Char, 0, PixelFormat32bppARGB, 0, @aChars_pre(i, 1).hBitmap)
   GdipGetImageGraphicsContext(aChars_pre(i, 1).hBitmap, @hGfx)
   GdipSetPixelOffsetMode(hGfx, PixelOffsetModeHalf)
   GdipSetTextRenderingHint(hGfx, TextRenderingHintAntiAlias)
   GdipSetSmoothingMode(hGfx, SmoothingModeAntiAlias)
   GdipDrawString(hGfx, aChars(i), -1, hFont, @tLayout1, hStringFormat, hBrush_Char)
   GdipDeleteGraphics(hGfx)
Next

fTimer = Timer

Do
   GdipFillRectangle(hCanvas2, hBrush_Bg, 0, 0, iW, iH)
   GdipFillRectangle(hCanvas, hBrush_Clr, 0, 0, iW, iH)
   
   For i = 0 To iAmountChars - 1
      If aTable(i).y - aTable(i).c > iH_Char Then
         GdipDrawImageRect(hCanvas, aChars_pre(iChar, 0).hBitmap, aTable(i).x, aTable(i).y, iW_Char, iH_Char)
         aTable(i).c = aTable(i).y
      Endif
      iChar = Cushort(Rnd() * iLen)
      GdipDrawImageRect(hCanvas2, aChars_pre(iChar, 0).hBitmap, aTable(i).x, aTable(i).y, iW_Char, iH_Char)
      GdipDrawImageRect(hCanvas2, aChars_pre(iChar, 1).hBitmap, aTable(i).x, aTable(i).y, iW_Char, iH_Char)
      aTable(i).y += aTable(i).vy
      If aTable(i).y > iH Then
         fPosX = Rnd() * (iW - iW_Char)
         aTable(i).x = fPosX - (fPosX Mod iW_Char)
         aTable(i).y = -fFontSize - 1
         aTable(i).vy = RandomRange(iMinSpeed, iMaxSpeed)
         aTable(i).c = aTable(i).y - iH_Char - 1
      EndIf
   Next
   
   
   BitBlt(hDC_backbuffer2, 0, 0, iW, iH, hDC_backbuffer, 0, 0, SRCPAINT)
   BitBlt(hDC, 0, 0, iW, iH, hDC_backbuffer2, 0, 0, SRCCOPY)
   
   If(Timer - fTimer > 0.99) Then
      Windowtitle (sTitle & iFPS)
      iFPS = 0
      fTimer = Timer
   Else
      iFPS += 1
   Endif
   
   Sleep(1)
Loop Until Len(Inkey())

EndTimerInterval

'GDI
SelectObject(hDC_backbuffer, hDC_obj)
DeleteDC(hDC_backbuffer)
DeleteObject(hHBitmap)
SelectObject(hDC_backbuffer2, hDC_obj2)
DeleteDC(hDC_backbuffer2)
DeleteObject(hHBitmap2)
ReleaseDC(hHWND, hDC)

'GDIPlus
For i = 0 To iLen
   GdipDisposeImage(aChars_pre(i, 0).hBitmap)
   GdipDisposeImage(aChars_pre(i, 1).hBitmap)
Next
GdipDeleteBrush(hBrush_Clr)
GdipDeleteBrush(hBrush_Char)
GdipDeleteBrush(hBrush_CharGlow)            
GdipDeleteBrush(hBrush_Bg)            
GdipDeleteFont(hFont)
GdipDeleteFont(hFont_Glow)
GdipDeleteFontFamily(hFamily)
GdipDeleteStringFormat(hStringFormat)
GdipDeleteGraphics(hCanvas)
GdipDeleteGraphics(hCanvas2)
GdiplusShutdown(gdipToken)


Function RandomRange(fStart as Single, fEnd as Single) as Single
   Return Rnd() * (fEnd - fStart) + fStart
End Function

_________________
Gruß,
UEZ
Nach oben
Benutzer-Profile anzeigen Private Nachricht senden
UEZ



Anmeldungsdatum: 24.06.2016
Beiträge: 129
Wohnort: Opel Stadt

BeitragVerfasst am: 27.12.2018, 14:48    Titel: Snowfall Antworten mit Zitat

Schneefall:

Code:

'Snowfall v0.65 build 28.12.2018
'Coded by UEZ Using classes (my 1st attempt^^)

#Include "fbgfx.bi"
#Include "string.bi"

Using FB

Declare Function _ASM_ImageBlur(pImage As Any Ptr, iRadius As Integer, iExpandEdge As Integer = 0) As Any Ptr 'Function by Eukalyptus

Dim Shared As Integer iDW, iDH, scrw, scrh
Screencontrol GET_DESKTOP_SIZE, iDW, iDH
scrw = iDW * 0.95
scrh = iDH * 0.85


Const iSnowflakes = 10000


' Simplex noise in 2D
' from paper http:'webstaff.itn.liu.se/~stegu/simplexnoise/simplexnoise.pdf
' https://www.freebasic.net/forum/viewtopic.php?t=20526#p180192

Type float As Single 'Double
 
Dim Shared As Integer perm(512) = { _
151,160,137, 91, 90, 15,131, 13,201, 95, 96, 53,194,233,  7,225,_
140, 36,103, 30, 69,142,  8, 99, 37,240, 21, 10, 23,190,  6,148, _
247,120,234, 75,  0, 26,197, 62, 94,252,219,203,117, 35, 11, 32, _
 57,177, 33, 88,237,149, 56, 87,174, 20,125,136,171,168, 68,175, _
 74,165, 71,134,139, 48, 27,166, 77,146,158,231, 83,111,229,122, _
 60,211,133,230,220,105, 92, 41, 55, 46,245, 40,244,102,143, 54, _
 65, 25, 63,161,  1,216, 80, 73,209, 76,132,187,208, 89, 18,169, _
200,196,135,130,116,188,159, 86,164,100,109,198,173,186,  3, 64, _
 52,217,226,250,124,123,  5,202, 38,147,118,126,255, 82, 85,212, _
207,206, 59,227, 47, 16, 58, 17,182,189, 28, 42,223,183,170,213, _
119,248,152,  2, 44,154,163, 70,221,153,101,155,167, 43,172,  9, _
129, 22, 39,253, 19, 98,108,110, 79,113,224,232,178,185,112,104, _
218,246, 97,228,251, 34,242,193,238,210,144, 12,191,179,162,241, _
 81, 51,145,235,249, 14,239,107, 49,192,214, 31,181,199,106,157, _
184, 84,204,176,115,121, 50, 45,127,  4,150,254,138,236,205, 93, _
222,114, 67, 29, 24, 72,243,141,128,195, 78, 66,215, 61,156,180, _
151,160,137, 91, 90, 15,131, 13,201, 95, 96, 53,194,233,  7,225,_
140, 36,103, 30, 69,142,  8, 99, 37,240, 21, 10, 23,190,  6,148, _
247,120,234, 75,  0, 26,197, 62, 94,252,219,203,117, 35, 11, 32, _
 57,177, 33, 88,237,149, 56, 87,174, 20,125,136,171,168, 68,175, _
 74,165, 71,134,139, 48, 27,166, 77,146,158,231, 83,111,229,122, _
 60,211,133,230,220,105, 92, 41, 55, 46,245, 40,244,102,143, 54, _
 65, 25, 63,161,  1,216, 80, 73,209, 76,132,187,208, 89, 18,169, _
200,196,135,130,116,188,159, 86,164,100,109,198,173,186,  3, 64, _
 52,217,226,250,124,123,  5,202, 38,147,118,126,255, 82, 85,212, _
207,206, 59,227, 47, 16, 58, 17,182,189, 28, 42,223,183,170,213, _
119,248,152,  2, 44,154,163, 70,221,153,101,155,167, 43,172,  9, _
129, 22, 39,253, 19, 98,108,110, 79,113,224,232,178,185,112,104, _
218,246, 97,228,251, 34,242,193,238,210,144, 12,191,179,162,241, _
 81, 51,145,235,249, 14,239,107, 49,192,214, 31,181,199,106,157, _
184, 84,204,176,115,121, 50, 45,127,  4,150,254,138,236,205, 93, _
222,114, 67, 29, 24, 72,243,141,128,195, 78, 66,215, 61,156,180}

Function SimplexNoise2D(xin As float, yin As float, scale As float = 20.0) As float 'by D.J.Peters aka Joshy
  Const As float F2 = 0.5*(Sqr(3.0)-1.0)
  Const As float G2 = (3.0-Sqr(3.0))/6.0
  Const As float G22 = G2 + G2
  Static As Integer grad2(11,1) = {{ 1, 1},{-1, 1},{1,-1},{-1,-1}, _
                                   { 1, 0},{-1, 0},{1, 0},{-1, 0}, _
                                   { 0, 1},{ 0,-1},{0, 1},{ 0,-1}}
  Dim As float s = (xin+yin)*F2
  Dim As Integer i = Int(xin+s)
  Dim As Integer j = Int(yin+s)
  Dim As float t = (i+j)*G2
  Dim As float x  = i-t  , y = j-t
  Dim As float x0 = xin-x, y0 = yin-y
  Dim As Integer i1=Any, j1=Any
  i And=255
  j And=255
 
  If (x0>y0) Then
    i1=1: j1=0
  Else
    i1=0: j1=1
  End If         

  Dim As float x1 = x0 - i1 + G2
  Dim As float y1 = y0 - j1 + G2
  Dim As float x2 = x0 - 1.0 + G22
  Dim As float y2 = y0 - 1.0 + G22
  Dim As Integer ii = i 'And 255
  Dim As Integer jj = j 'And 255
  Dim As Integer ind = Any
  Dim As float n=Any
  t = 0.5 - x0*x0-y0*y0
  If (t<0) Then
    n=0
  Else
    ind = perm(i+perm(j)) Mod 12
    n = t*t*t*t  * (grad2(ind,0)*x0 + grad2(ind,1)*y0)
  End If
  t = 0.5 - x1*x1-y1*y1
  If (t<0) Then
  Else
    ind = perm(i+i1+perm(j+j1)) Mod 12
    n+= t*t*t*t  * (grad2(ind,0)*x1 + grad2(ind,1)*y1)
  End If
  t = 0.5 - x2*x2-y2*y2
  If(t<0) Then
  Else
    i+=1:j+=1 
    ind= perm(i+perm(j)) Mod 12
    n+= t*t*t*t  * (grad2(ind,0)*x2 + grad2(ind,1)*y2)
  End If
  ' scaled in the interval [-1,1].
  Return scale * n
End Function

Function RandomRange(fStart As Single, fEnd As Single) As Single
   Return Rnd() * (fEnd - fStart) + fStart
End Function

Type Snowflake
   Public:
      Declare Constructor()
      Declare Destructor()
      Declare Sub Init()
      Declare Sub Reset()
      Declare Sub update()
      As Ushort w, h
      As Single x, y, vx, vy, wvx, wvy, radius, Alpha
End Type

Sub Snowflake.init()
   This.radius = RandomRange(1, 3)
   This.x = Rnd() * (This.w - This.radius)
   This.y = Rnd() * (This.h - This.radius)
   This.vx = 0
   This.vy = 2 * This.radius 'RandomRange(1, 4)
   This.Alpha = RandomRange(0.25, 0.95)
End Sub

Sub Snowflake.Reset()
   This.radius = RandomRange(1, 3)
   This.x = Rnd() * (This.w - This.radius)
   This.y = Rnd() * -This.radius
   This.vx = 0
   This.vy = 2 * This.radius
   This.Alpha = RandomRange(0.25, 0.95)
End Sub

Sub Snowflake.Update()
   This.wvx += SimplexNoise2D(This.x * This.x, 2 * This.y) + SimplexNoise2D(This.y, This.x) 'turbulance x
   This.wvy += 1.05 * SimplexNoise2D(-This.x, -This.y + This.radius) - SimplexNoise2D(2 * This.y, This.x + This.y + This.radius) 'turbulance y
   If This.wvx > 3 Or This.wvx < -3 Then This.wvx = 0
   If This.wvy > 3 Or This.wvy < -3 Then This.wvy = 0
   This.x += This.wvx
   This.y += This.vy + This.wvy / 2
   If (This.y > This.h + This.radius) Or (This.x < -This.radius) Or (This.x > This.w) Then This.Reset()
End Sub

Constructor Snowflake()
   This.w = scrw
   This.h = scrh
   This.Init()
End Constructor

Destructor Snowflake()
End Destructor

Type Snowflakes
      Declare Constructor(n As Ushort = iSnowflakes)
      Declare Destructor()
      Declare Sub Draw()
   Private:
      As Ushort w, h, amount     
      As Snowflake Ptr pBuffer
      As Image Ptr Img_Empty, Img_Snowfall, Img_Blur
End Type

Sub Snowflakes.Draw()
   Put This.Img_Snowfall, (0, 0), This.Img_Empty, Pset
   For i As Ushort = 0 To This.amount - 1
      Circle This.Img_Snowfall, (pBuffer[i].x, pBuffer[i].y), pBuffer[i].radius, Rgba(255, 255, 255, 255 * pBuffer[i].Alpha),,,,F
      pBuffer[i].update
   Next
   This.Img_Blur = _ASM_ImageBlur(This.Img_Snowfall, 2)
   Put (0, 0), This.Img_Blur, Trans
   Imagedestroy This.Img_Blur
End Sub

Constructor Snowflakes(n As Ushort)
   With This
      .amount = n
      .w = scrw                       
      .h = scrh
   End With
   Img_Empty = Imagecreate(This.w, This.h, &hFF010512, 32)
   Img_Snowfall = Imagecreate(This.w, This.h, , 32)
   pBuffer = New Snowflake[amount]
End Constructor

Destructor Snowflakes()
   Delete[] pBuffer
   pBuffer = 0
   Imagedestroy This.Img_Empty
   Imagedestroy This.Img_Snowfall
End Destructor



Screenres (scrw, scrh, 32, 1, GFX_ALPHA_PRIMITIVES Or GFX_NO_SWITCH Or GFX_ALWAYS_ON_TOP)

#Ifdef __Fb_win32__
   #Include "windows.bi"
   Dim tWorkingArea As RECT
   SystemParametersInfo(SPI_GETWORKAREA, null, @tWorkingArea, null)
   Screencontrol SET_WINDOW_POS, (iDW - scrw) \ 2, ((tWorkingArea.Bottom - scrh) - (iDH - tWorkingArea.Bottom)) \ 2
#Endif
                             
Windowtitle "Simple Snowfall with " & Format(iSnowflakes, "###,###") & " snowflakes @ " & scrw & "x" & scrh & ". Coded by UEZ"
Dim As Snowflakes Snowfall
Dim As Ulong i, iFPS = 0, iFPS_current = 0
Dim As Double fTimer = Timer


Do
   Screenlock
   Snowfall.Draw
   Draw String(0, 0), iFPS_current & " fps", Rgb(&hFF, &h00, &h00)
   Screenunlock
   If Timer - fTimer > 0.99 Then
      iFPS_current = iFPS
      iFPS = 0
      fTimer = Timer
   Else
      iFPS += 1
   Endif
   Sleep 1
Loop Until Inkey = Chr(27)

Function _ASM_ImageBlur(pImage As Any Ptr, iRadius As Integer, iExpandEdge As Integer = 0) As Any Ptr
   'By Eukalyptus / modified by D.J. Peters aka Joshy
   Dim As Integer iWidth, iHeight, iPX, iPitch, iPitchBlur
   Dim As Any Ptr pData, pDataBlur, pDataTmp
   
   If Imageinfo(pImage, iWidth, iHeight, iPX, iPitch, pData) <> 0 Then Return 0
   If iPX <> 4 Then Return 0
   
   If iRadius < 0 Then
      iRadius = 0
   Elseif iRadius > 127 Then
      iRadius = 127
   Endif
   
   Dim As Any Ptr pImgBlur, pImgTmp
   If iExpandEdge <> 0 Then
      iWidth += iRadius * 2
      iHeight += iRadius * 2
   Endif
   
   pImgBlur = Imagecreate(iWidth, iHeight, 0, 32)
   pImgTmp = Imagecreate(iWidth, iHeight, 0, 32)
   
   Imageinfo(pImgBlur, , , , iPitchBlur, pDataBlur)
   Imageinfo(pImgTmp, , , , , pDataTmp)
   If pImgBlur = 0 Orelse pImgTmp = 0 Then
      Imagedestroy(pImgBlur)
      Imagedestroy(pImgTmp)
      Return 0
   End If
   
   If iExpandEdge <> 0 Then
      Put pImgBlur, (iRadius, iRadius), pImage, Alpha
   Else
      Put pImgBlur, (0, 0), pImage, Alpha
   End If
 
#Ifndef __Fb_64bit__

  #Define REG_SIZE 4
  #Define REG_ACCESS DWORD
  #Define REG_AX eax
  #Define REG_BX ebx
  #Define REG_CX ecx
  #Define REG_DX edx
  #Define REG_DI edi
  #Define REG_SI esi
  #Define REG_SP esp
  #Define REG_BP ebp

#Else

  #Define REG_SIZE 8
  #Define REG_ACCESS QWORD
  #Define REG_AX rax
  #Define REG_BX rbx
  #Define REG_CX rcx
  #Define REG_DX rdx
  #Define REG_DI rdi
  #Define REG_SI rsi
  #Define REG_SP rsp
  #Define REG_BP rbp

#Endif

  #Define LOCAL_VAR_SPACE 16*REG_SIZE
  'esp/rsp = [X] [Y] [W] [H] [Stride] [R] [pDst] [pSrc] [pDstO] [pSrcO]
 
  #Define X_OFF    [REG_SP]
  #Define Y_OFF    [REG_SP+1*REG_SIZE]
  #Define W_OFF    [REG_SP+2*REG_SIZE]
  #Define H_OFF    [REG_SP+3*REG_SIZE]
  #Define S_OFF    [REG_SP+4*REG_SIZE]
  #Define R_OFF    [REG_SP+5*REG_SIZE]
  #Define DST_OFF  [REG_SP+6*REG_SIZE]
  #Define SRC_OFF  [REG_SP+7*REG_SIZE]
  #Define DSTO_OFF [REG_SP+8*REG_SIZE]
  #Define SRCO_OFF [REG_SP+9*REG_SIZE]
 
 
  Asm
  mov REG_CX, [iWidth]
  mov REG_BX, [iHeight]
  mov REG_DX, [iPitchBlur]
  mov REG_DI, [pDataTmp]
  mov REG_SI, [pDataBlur]
       
  mov REG_AX, [iRadius]
  inc REG_AX
 
  push REG_BP
  mov REG_BP, REG_AX
  Sub REG_SP, LOCAL_VAR_SPACE
 
  mov W_OFF,    REG_CX
  mov H_OFF,    REG_BX
  mov S_OFF,    REG_DX
  mov R_OFF,    REG_BP
  mov DST_OFF,  REG_DI
  mov DSTO_OFF, REG_DI
  mov SRC_OFF,  REG_SI
  mov SRCO_OFF, REG_SI 

  mov REG_AX, 0x47000000 'ByteToFloat MSK
  movd xmm7, REG_AX
  pshufd xmm7, xmm7, 0

  ' ####################################################
  ' # W-Loop
  ' ####################################################
   mov REG_BX, H_OFF
   mov Y_OFF, REG_BX

_Blur_LoopW:
  mov REG_DI, DST_OFF
  mov REG_SI, SRC_OFF
  mov REG_DX, S_OFF 'Stride
  Add REG_ACCESS Ptr DST_OFF, 4 'Next RowCol(Transform vertical<->horizontal)
  Add SRC_OFF, REG_DX 'Next Row

  mov REG_DX, H_OFF 'Y-Stride
  Shl REG_DX, 2

  pxor xmm6, xmm6 'Reset In-Out
  pxor xmm5, xmm5 'Reset Sum
  pxor xmm4, xmm4 'UnPack

  mov REG_AX, 0 'Reset SumDiv
  mov REG_BX, 0 'Reset DivInc
  ' ----------------------------------------------------
  ' | X-In += Next
  ' ----------------------------------------------------
  mov REG_BP, 0 'Offset
  mov REG_CX, R_OFF 'iR
  _Blur_LoopX_In:
    movd      xmm0, [REG_SI+REG_BP]
    punpcklbw xmm0, xmm4 '[ ][ ][ ][ ][An][Rn][Gn][Bn] Next
    paddw     xmm6, xmm0 'IN+=Next
    movdqa    xmm0, xmm6
    punpcklwd xmm0, xmm4 '[AI][RI][GI][BI]
    paddd     xmm5, xmm0 'Stack += IN

    Add REG_BX, 1 'SumDivInc += 1
    Add REG_AX, REG_BX 'SumDiv += Inc
    Add REG_BP, 4
    Sub REG_CX, 1
  jg _Blur_LoopX_In
  ' ----------------------------------------------------
  ' | XIn += Next / XIn -= Mid / XOut += Mid
  ' ----------------------------------------------------
  mov REG_CX, R_OFF 'iR
  _Blur_LoopX_InOut:
    cvtsi2ss  xmm3, REG_AX
    rcpss     xmm3, xmm3
    pshufd    xmm3, xmm3, 0 'SumDiv
    movdqa    xmm0, xmm5
    paddd     xmm0, xmm7 ' Ubyte -> Float
    subps     xmm0, xmm7 ' /
    mulps     xmm0, xmm3
    addps     xmm0, xmm7 ' Float -> Ubyte
    psubd     xmm0, xmm7 ' /
    packssdw  xmm0, xmm0 '[A][R][G][B][A][R][G][B]
    packuswb  xmm0, xmm0 '[ARGB][ARGB][ARGB][ARGB]
    movd      [REG_DI], xmm0
    movd      xmm0, [REG_SI+REG_BP]
    movd      xmm1, [REG_SI]
    punpcklbw xmm0, xmm4 '[ ][ ][ ][ ][An][Rn][Gn][Bn] Next
    punpcklbw xmm1, xmm4 '[ ][ ][ ][ ][Am][Rm][Gm][Bm] Mid
    movlhps   xmm0, xmm1 '[Am][Rm][Gm][Bm][An][Rn][Gn][Bn] = [Mid][Next]
    paddw     xmm6, xmm0 'Out+=Mid / IN+=Next
    psubw     xmm6, xmm1 '(Out-=Last) / IN-=Mid
    movdqa    xmm1, xmm6
    movdqa    xmm0, xmm6
    punpckhwd xmm1, xmm4 '[AO][RO][GO][BO]
    punpcklwd xmm0, xmm4 '[AI][RI][GI][BI]
    psubd     xmm5, xmm1 'Stack -= Out
    paddd     xmm5, xmm0 'Stack += IN
    Sub       REG_BX, 1 'SumDivInc += 1
    Add       REG_AX, REG_BX 'SumDiv += Inc
    Add       REG_SI, 4
    Add       REG_DI, REG_DX
    Sub       REG_CX, 1
  jg _Blur_LoopX_InOut

  cvtsi2ss  xmm3, REG_AX
  rcpss     xmm3, xmm3
  pshufd    xmm3, xmm3, 0 'SumDiv
  mov       REG_BX, REG_BP
  neg       REG_BX 'Last Index
  ' ----------------------------------------------------
  ' | XIn += Next / XIn -= Mid / XOut += Mid / XOut -= Last
  ' ----------------------------------------------------
  mov REG_CX, W_OFF 'iWidth
  Sub REG_CX, R_OFF
  Sub REG_CX, R_OFF
  _Blur_LoopX:
    movdqa    xmm0, xmm5
    paddd     xmm0, xmm7 ' Ubyte -> Float
    subps     xmm0, xmm7 ' /
    mulps     xmm0, xmm3
    addps     xmm0, xmm7 ' Float -> Ubyte
    psubd     xmm0, xmm7 ' /
    packssdw  xmm0, xmm0 '[A][R][G][B][A][R][G][B]
    packuswb  xmm0, xmm0 '[ARGB][ARGB][ARGB][ARGB]
    movd      [REG_DI], xmm0
    movd xmm0,[REG_SI+REG_BP]
    movd xmm1,[REG_SI]
    movd xmm2,[REG_SI+REG_BX]
    punpcklbw xmm0, xmm4 '[ ][ ][ ][ ][An][Rn][Gn][Bn] Next
    punpcklbw xmm1, xmm4 '[ ][ ][ ][ ][Am][Rm][Gm][Bm] Mid
    punpcklbw xmm2, xmm4 '[ ][ ][ ][ ][Al][Rl][Gl][Bl] Last
    movlhps   xmm0, xmm1 '[Am][Rm][Gm][Bm][An][Rn][Gn][Bn] = [Mid][Next]
    movlhps   xmm1, xmm2 '[Al][Rl][Gl][Bl][Ao][Ro][Go][Bo] = [Last][Mid]
    paddw     xmm6, xmm0 'Out+=Mid / IN+=Next
    psubw     xmm6, xmm1 'Out-=Last / IN-=Mid
    movdqa    xmm1, xmm6
    movdqa    xmm0, xmm6
    punpckhwd xmm1, xmm4 '[AO][RO][GO][BO]
    punpcklwd xmm0, xmm4 '[AI][RI][GI][BI]
    psubd     xmm5, xmm1 'Stack -= Out
    paddd     xmm5, xmm0 'Stack += IN
    Add       REG_SI, 4
    Add       REG_DI, REG_DX
    Sub       REG_CX, 1
  jg _Blur_LoopX
  ' ----------------------------------------------------
  ' | XIn -= Mid / XOut += Mid / XOut -= Last
  ' ----------------------------------------------------
  mov REG_BP, 0 'DivInc
  mov REG_CX, R_OFF 'iR
  _Blur_LoopX_Out:
    cvtsi2ss  xmm3, REG_AX
    rcpss     xmm3, xmm3
    pshufd    xmm3, xmm3, 0 'SumDiv
    movdqa    xmm0, xmm5
    paddd     xmm0, xmm7 ' Ubyte -> Float
    subps     xmm0, xmm7 ' /
    mulps     xmm0, xmm3
    addps     xmm0, xmm7 ' Float -> Ubyte
    psubd     xmm0, xmm7 ' /
    packssdw  xmm0, xmm0 '[A][R][G][B][A][R][G][B]
    packuswb  xmm0, xmm0 '[ARGB][ARGB][ARGB][ARGB]
    movd      [REG_DI], xmm0
    movd      xmm0, [REG_SI]
    movd      xmm1, [REG_SI+REG_BX]
    punpcklbw xmm0, xmm4 '[ ][ ][ ][ ][Am][Rm][Gm][Bm] Mid
    punpcklbw xmm1, xmm4 '[ ][ ][ ][ ][Al][Rl][Gl][Bl] Last
    movlhps   xmm0, xmm1 '[Al][Rl][Gl][Bl][Am][Rm][Gm][Bm] = [Last][Mid]
    psubw     xmm6, xmm0 'Out-=Last / IN-=Mid
    pslldq    xmm0, 8
    paddw     xmm6, xmm0 'Out+=Mid / (IN+=Next)
    movdqa    xmm1, xmm6
    movdqa    xmm0, xmm6
    punpckhwd xmm1, xmm4 '[AO][RO][GO][BO]
    punpcklwd xmm0, xmm4 '[AI][RI][GI][BI]
    psubd     xmm5, xmm1 'Stack -= Out
    paddd     xmm5, xmm0 'Stack += IN
    Add       REG_BP, 1
    Sub       REG_AX, REG_BP
    Add       REG_SI, 4
    Add       REG_DI, REG_DX
    Sub       REG_CX, 1
  jg _Blur_LoopX_Out

  Sub REG_ACCESS Ptr Y_OFF, 1
  jg _Blur_LoopW


  ' ####################################################
  ' # H-Loop
  ' ####################################################
  mov REG_DI, SRCO_OFF
  mov REG_SI, DSTO_OFF
  mov DST_OFF, REG_DI
  mov SRC_OFF, REG_SI

  mov REG_BX, W_OFF
  mov X_OFF, REG_BX
 _Blur_LoopH:
  mov REG_DI, DST_OFF
  mov REG_SI, SRC_OFF
  mov REG_DX, H_OFF
  Shl REG_DX, 2
  Add REG_ACCESS Ptr DST_OFF, 4 'Next Col
  Add SRC_OFF, REG_DX 'Next ColRow
  mov REG_DX, S_OFF 'Stride
  pxor xmm6, xmm6 'Reset In-Out
  pxor xmm5, xmm5 'Reset Sum
  pxor xmm4, xmm4 'UnPack
  mov REG_AX, 0 'Reset SumDiv
  mov REG_BX, 0 'Reset DivInc
  ' ----------------------------------------------------
  ' | X-In += Next
  ' ----------------------------------------------------
  mov REG_BP, 0 'Offset
  mov REG_CX, R_OFF 'iR
 
  _Blur_LoopY_In:
    movd xmm0, [REG_SI+REG_BP]
    punpcklbw xmm0, xmm4 '[ ][ ][ ][ ][An][Rn][Gn][Bn] Next
    paddw xmm6, xmm0 'IN+=Next
    movdqa xmm0, xmm6
    punpcklwd xmm0, xmm4 '[AI][RI][GI][BI]
    paddd xmm5, xmm0 'Stack += IN
    Add REG_BX, 1 'SumDivInc += 1
    Add REG_AX, REG_BX 'SumDiv += Inc
    Add REG_BP, 4
    Sub REG_CX, 1
  jg _Blur_LoopY_In

  ' ----------------------------------------------------
  ' | XIn += Next / XIn -= Mid / XOut += Mid
  ' ----------------------------------------------------
  mov REG_CX, R_OFF 'iR
  _Blur_LoopY_InOut:
    cvtsi2ss xmm3, REG_AX
    rcpss xmm3, xmm3
    pshufd xmm3, xmm3, 0 'SumDiv
    movdqa xmm0, xmm5
    paddd xmm0, xmm7 ' Ubyte -> Float
    subps xmm0, xmm7 '/
    mulps xmm0, xmm3
    addps xmm0, xmm7 ' Float -> Ubyte
    psubd xmm0, xmm7 '/
    packssdw xmm0, xmm0 '[A][R][G][B][A][R][G][B]
    packuswb xmm0, xmm0 '[ARGB][ARGB][ARGB][ARGB]
    movd [REG_DI], xmm0
    movd xmm0, [REG_SI+REG_BP]
    movd xmm1, [REG_SI]
    punpcklbw xmm0, xmm4 '[ ][ ][ ][ ][An][Rn][Gn][Bn] Next
    punpcklbw xmm1, xmm4 '[ ][ ][ ][ ][Am][Rm][Gm][Bm] Mid
    movlhps xmm0, xmm1 '[Am][Rm][Gm][Bm][An][Rn][Gn][Bn] = [Mid][Next]
    paddw xmm6, xmm0 'Out+=Mid / IN+=Next
    psubw xmm6, xmm1 '(Out-=Last) / IN-=Mid
    movdqa xmm1, xmm6
    movdqa xmm0, xmm6
    punpckhwd xmm1, xmm4 '[AO][RO][GO][BO]
    punpcklwd xmm0, xmm4 '[AI][RI][GI][BI]
    psubd xmm5, xmm1 'Stack -= Out
    paddd xmm5, xmm0 'Stack += IN
    Sub REG_BX, 1 'SumDivInc += 1
    Add REG_AX, REG_BX 'SumDiv += Inc
    Add REG_SI, 4
    Add REG_DI, REG_DX
    Sub REG_CX, 1
  jg _Blur_LoopY_InOut

  cvtsi2ss xmm3, REG_AX
  rcpss xmm3, xmm3
  pshufd xmm3, xmm3, 0 'SumDiv
  mov REG_BX, REG_BP
  neg REG_BX 'Last Index
  ' ----------------------------------------------------
  ' | XIn += Next / XIn -= Mid / XOut += Mid / XOut -= Last
  ' ----------------------------------------------------
  mov REG_CX, H_OFF 'iHeight
  Sub REG_CX, R_OFF
  Sub REG_CX, R_OFF
  _Blur_LoopY:
    movdqa xmm0, xmm5
    paddd xmm0, xmm7 ' Ubyte -> Float
    subps xmm0, xmm7 '/
    mulps xmm0, xmm3
    addps xmm0, xmm7 ' Float -> Ubyte
    psubd xmm0, xmm7 '/
    packssdw xmm0, xmm0 '[A][R][G][B][A][R][G][B]
    packuswb xmm0, xmm0 '[ARGB][ARGB][ARGB][ARGB]
    movd [REG_DI], xmm0
    movd xmm0, [REG_SI+REG_BP]
    movd xmm1, [REG_SI]
    movd xmm2, [REG_SI+REG_BX]
    punpcklbw xmm0, xmm4 '[ ][ ][ ][ ][An][Rn][Gn][Bn] Next
    punpcklbw xmm1, xmm4 '[ ][ ][ ][ ][Am][Rm][Gm][Bm] Mid
    punpcklbw xmm2, xmm4 '[ ][ ][ ][ ][Al][Rl][Gl][Bl] Last
    movlhps xmm0, xmm1 '[Am][Rm][Gm][Bm][An][Rn][Gn][Bn] = [Mid][Next]
    movlhps xmm1, xmm2 '[Al][Rl][Gl][Bl][Ao][Ro][Go][Bo] = [Last][Mid]
    paddw xmm6, xmm0 'Out+=Mid / IN+=Next
    psubw xmm6, xmm1 'Out-=Last / IN-=Mid
    movdqa xmm1, xmm6
    movdqa xmm0, xmm6
    punpckhwd xmm1, xmm4 '[AO][RO][GO][BO]
    punpcklwd xmm0, xmm4 '[AI][RI][GI][BI]
    psubd xmm5, xmm1 'Stack -= Out
    paddd xmm5, xmm0 'Stack += IN
   
    Add REG_SI, 4
    Add REG_DI, REG_DX
    Sub REG_CX, 1
  jg _Blur_LoopY
  ' ----------------------------------------------------
  ' | XIn -= Mid / XOut += Mid / XOut -= Last
  ' ----------------------------------------------------
  mov REG_BP, 0 'DivInc
  mov REG_CX, R_OFF 'iR
  _Blur_LoopY_Out:
    cvtsi2ss xmm3, REG_AX
    rcpss xmm3, xmm3
    pshufd xmm3, xmm3, 0 'SumDiv
   
    movdqa xmm0, xmm5
    paddd xmm0, xmm7 ' Ubyte -> Float
    subps xmm0, xmm7 '/
    mulps xmm0, xmm3
    addps xmm0, xmm7 ' Float -> Ubyte
    psubd xmm0, xmm7 '/
    packssdw xmm0, xmm0 '[A][R][G][B][A][R][G][B]
    packuswb xmm0, xmm0 '[ARGB][ARGB][ARGB][ARGB]
    movd [REG_DI], xmm0
   
    movd xmm0, [REG_SI]
    movd xmm1, [REG_SI+REG_BX]
    punpcklbw xmm0, xmm4 '[ ][ ][ ][ ][Am][Rm][Gm][Bm] Mid
    punpcklbw xmm1, xmm4 '[ ][ ][ ][ ][Al][Rl][Gl][Bl] Last
    movlhps xmm0, xmm1 '[Al][Rl][Gl][Bl][Am][Rm][Gm][Bm] = [Last][Mid]
    psubw xmm6, xmm0 'Out-=Last / IN-=Mid
    pslldq xmm0, 8
    paddw xmm6, xmm0 'Out+=Mid / (IN+=Next)
    movdqa xmm1, xmm6
    movdqa xmm0, xmm6
    punpckhwd xmm1, xmm4 '[AO][RO][GO][BO]
    punpcklwd xmm0, xmm4 '[AI][RI][GI][BI]
    psubd xmm5, xmm1 'Stack -= Out
    paddd xmm5, xmm0 'Stack += IN
   
    Add REG_BP, 1
    Sub REG_AX, REG_BP
   
    Add REG_SI, 4
    Add REG_DI, REG_DX
    Sub REG_CX, 1
  jg _Blur_LoopY_Out

  Sub REG_ACCESS Ptr X_OFF, 1
 jg _Blur_LoopH

  Add REG_SP, LOCAL_VAR_SPACE
  pop REG_BP

  End Asm
  Imagedestroy(pImgTmp)
  Return pImgBlur
End Function


happy


Edit1: kleine Modifikationen an den Parametern
_________________
Gruß,
UEZ


Zuletzt bearbeitet von UEZ am 28.12.2018, 23:23, insgesamt 2-mal bearbeitet
Nach oben
Benutzer-Profile anzeigen Private Nachricht senden
grindstone



Anmeldungsdatum: 03.10.2010
Beiträge: 1208
Wohnort: Ruhrpott

BeitragVerfasst am: 28.12.2018, 08:32    Titel: Antworten mit Zitat

Beeindruckend, aber es gibt einige Querulanten unter den Schneeflocken, die sich aufwärts bewegen. verwundert

Gruß
grindstone
_________________
For ein halbes Jahr wuste ich nich mahl wie man Proggramira schreibt. Jetzt bin ich einen!
Nach oben
Benutzer-Profile anzeigen Private Nachricht senden E-Mail senden
UEZ



Anmeldungsdatum: 24.06.2016
Beiträge: 129
Wohnort: Opel Stadt

BeitragVerfasst am: 28.12.2018, 11:06    Titel: Antworten mit Zitat

grindstone hat Folgendes geschrieben:
Beeindruckend, aber es gibt einige Querulanten unter den Schneeflocken, die sich aufwärts bewegen. verwundert

Gruß
grindstone


Danke für deine Rückmeldung. Aufgrund der gewollten Turbulenzen fliegen einige Schneeflocken nach oben.

In der der Sub Snowflake.Update() einfach die Zeile
Code:
This.wvy += 2.05 * SimplexNoise2D(-This.x, -This.y + This.radius) - SimplexNoise2D(2 * This.y, This.x + This.y + This.radius) 'turbulance y
auskommentieren und die Schneeflocken sollten nicht mehr sich nach oben bewegen.
_________________
Gruß,
UEZ
Nach oben
Benutzer-Profile anzeigen Private Nachricht senden
UEZ



Anmeldungsdatum: 24.06.2016
Beiträge: 129
Wohnort: Opel Stadt

BeitragVerfasst am: 09.02.2019, 14:02    Titel: van Gogh Style Malerei [Windows] Antworten mit Zitat

van Gogh Style Malerei [Windows]:



Code:

'Coded by UEZ build 2019-02-16
'Windows only!
'Original idea (Noise flow field painter) by Jose 

#Include "fbgfx.bi"
#Include "windows.bi"
#Include "vbcompat.bi"
#include "win\wininet.bi"

#Ifdef __Fb_64bit__
    #Inclib "gdiplus"
    #Include "win/gdiplus-c.bi"
#Else
    #Include "win/gdiplus.bi"
    Using gdiplus
#Endif

Using FB

Declare Function RandomRange(fStart as Single, fEnd as Single) as Single
Declare Function _GDIPlus_ImageSaveToFile(hImage As Any Ptr, Filename As Wstring, JPGQual As Ulong = 85) As Boolean
Declare Function _GDIPlus_BitmapCreateFromMemory3(aBinImage As Ubyte Ptr, iLen As Ulong, bBitmap_GDI As Bool = False) As Any Ptr
Declare Function LoadDataFromINet(sUrl As String, Byref iSize As Ulong) As Byte Ptr

'--------------------------------------------------------------------------------------------------
Type float As Single 'Double
 
Dim Shared As Integer perm(512) = { _
151,160,137, 91, 90, 15,131, 13,201, 95, 96, 53,194,233,  7,225,_
140, 36,103, 30, 69,142,  8, 99, 37,240, 21, 10, 23,190,  6,148, _
247,120,234, 75,  0, 26,197, 62, 94,252,219,203,117, 35, 11, 32, _
 57,177, 33, 88,237,149, 56, 87,174, 20,125,136,171,168, 68,175, _
 74,165, 71,134,139, 48, 27,166, 77,146,158,231, 83,111,229,122, _
 60,211,133,230,220,105, 92, 41, 55, 46,245, 40,244,102,143, 54, _
 65, 25, 63,161,  1,216, 80, 73,209, 76,132,187,208, 89, 18,169, _
200,196,135,130,116,188,159, 86,164,100,109,198,173,186,  3, 64, _
 52,217,226,250,124,123,  5,202, 38,147,118,126,255, 82, 85,212, _
207,206, 59,227, 47, 16, 58, 17,182,189, 28, 42,223,183,170,213, _
119,248,152,  2, 44,154,163, 70,221,153,101,155,167, 43,172,  9, _
129, 22, 39,253, 19, 98,108,110, 79,113,224,232,178,185,112,104, _
218,246, 97,228,251, 34,242,193,238,210,144, 12,191,179,162,241, _
 81, 51,145,235,249, 14,239,107, 49,192,214, 31,181,199,106,157, _
184, 84,204,176,115,121, 50, 45,127,  4,150,254,138,236,205, 93, _
222,114, 67, 29, 24, 72,243,141,128,195, 78, 66,215, 61,156,180, _
151,160,137, 91, 90, 15,131, 13,201, 95, 96, 53,194,233,  7,225,_
140, 36,103, 30, 69,142,  8, 99, 37,240, 21, 10, 23,190,  6,148, _
247,120,234, 75,  0, 26,197, 62, 94,252,219,203,117, 35, 11, 32, _
 57,177, 33, 88,237,149, 56, 87,174, 20,125,136,171,168, 68,175, _
 74,165, 71,134,139, 48, 27,166, 77,146,158,231, 83,111,229,122, _
 60,211,133,230,220,105, 92, 41, 55, 46,245, 40,244,102,143, 54, _
 65, 25, 63,161,  1,216, 80, 73,209, 76,132,187,208, 89, 18,169, _
200,196,135,130,116,188,159, 86,164,100,109,198,173,186,  3, 64, _
 52,217,226,250,124,123,  5,202, 38,147,118,126,255, 82, 85,212, _
207,206, 59,227, 47, 16, 58, 17,182,189, 28, 42,223,183,170,213, _
119,248,152,  2, 44,154,163, 70,221,153,101,155,167, 43,172,  9, _
129, 22, 39,253, 19, 98,108,110, 79,113,224,232,178,185,112,104, _
218,246, 97,228,251, 34,242,193,238,210,144, 12,191,179,162,241, _
 81, 51,145,235,249, 14,239,107, 49,192,214, 31,181,199,106,157, _
184, 84,204,176,115,121, 50, 45,127,  4,150,254,138,236,205, 93, _
222,114, 67, 29, 24, 72,243,141,128,195, 78, 66,215, 61,156,180}

Function SimplexNoise2D(xin As float, yin As float, scale As float = 1.0) As float 'by D.J.Peters aka Joshy
  Const As float F2 = 0.5*(Sqr(3.0)-1.0)
  Const As float G2 = (3.0-Sqr(3.0))/6.0
  Const As float G22 = G2 + G2
  Static As Integer grad2(11,1) = {{ 1, 1},{-1, 1},{1,-1},{-1,-1}, _
                                   { 1, 0},{-1, 0},{1, 0},{-1, 0}, _
                                   { 0, 1},{ 0,-1},{0, 1},{ 0,-1}}
  Dim As float s = (xin+yin)*F2
  Dim As Integer i = Int(xin+s)
  Dim As Integer j = Int(yin+s)
  Dim As float t = (i+j)*G2
  Dim As float x  = i-t  , y = j-t
  Dim As float x0 = xin-x, y0 = yin-y
  Dim As Integer i1=Any, j1=Any
  i And=255
  j And=255
 
  If (x0>y0) Then
    i1=1: j1=0
  Else
    i1=0: j1=1
  End If         

  Dim As float x1 = x0 - i1 + G2
  Dim As float y1 = y0 - j1 + G2
  Dim As float x2 = x0 - 1.0 + G22
  Dim As float y2 = y0 - 1.0 + G22
  Dim As Integer ii = i 'And 255
  Dim As Integer jj = j 'And 255
  Dim As Integer ind = Any
  Dim As float n=Any
  t = 0.5 - x0*x0-y0*y0
  If (t<0) Then
    n=0
  Else
    ind = perm(i+perm(j)) Mod 12
    n = t*t*t*t  * (grad2(ind,0)*x0 + grad2(ind,1)*y0)
  End If
  t = 0.5 - x1*x1-y1*y1
  If (t<0) Then
  Else
    ind = perm(i+i1+perm(j+j1)) Mod 12
    n+= t*t*t*t  * (grad2(ind,0)*x1 + grad2(ind,1)*y1)
  End If
  t = 0.5 - x2*x2-y2*y2
  If(t<0) Then
  Else
    i+=1:j+=1 
    ind= perm(i+perm(j)) Mod 12
    n+= t*t*t*t* (grad2(ind,0)*x2 + grad2(ind,1)*y2)
  End If
  ' scaled in the interval [-1,1].
  Return scale * n
End Function
'--------------------------------------------------------------------------------------------------


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

Dim As Single iW, iH, iPixel, iRowOffset
Dim As Any Ptr hImage


'load image from internet
Dim As Integer iSize
'Dim As String sURL = "https://pics.freiepresse.de/DYNIMG/74/95/6397495_W740.jpg"
'Dim As String sURL = "https://www.tpi.it/app/uploads/2019/01/van-gogh.jpg"
'Dim As String sURL = "https://d2jv9003bew7ag.cloudfront.net/uploads/Pablo-Picasso-old.jpg"
Dim As String sURL = "https://leaders.economicblogs.org/wp-content/uploads/2018/12/AEG.jpg"
Dim As String sFilename = Curdir & "\AEG.jpg"
Dim As Byte Ptr binImg = LoadDataFromINet(sURL, iSize)
If Fileexists(sFilename) = -1 Then
   'local load
   GdipLoadImageFromFile(sFilename, @hImage)
Else
   If Messagebox(0, "Do you agree to download an image from internet?", "Information", MB_ICONQUESTION or MB_YESNO) = 7 Then
      Messagebox(0, "This demo requires an image. Please enable code line to load from local disk and disable code for download! Do not forget to adjust the path to the image!", "Information", MB_ICONWARNING)
      GdiplusShutdown(gdipToken)
      End
   End If
   'internet load
   Dim As Ulong iSize
   Dim As Byte Ptr binImg = LoadDataFromINet(sURL, iSize)
   Dim As Integer hFile = FreeFile()
   Open sFilename For Binary Access Write As #hFile
   Put #hFile, 0, binImg[0], iSize
   Close #hFile
   hImage = _GDIPlus_BitmapCreateFromMemory3(binImg, iSize)
   Deallocate binImg
Endif

GdipGetImageDimension(hImage, @iW, @iH)

If iW = 0 Then
   GdiplusShutdown(gdipToken)
   Messagebox(0, "Something went wrong to download the image!", "ERROR", 16)
   End
End If


'read all colors to an array for faster access
Dim As ULong aColors(0 To iH - 1, 0 To iW - 1), iX, iY, iARGB
For iY = 0 To iH - 1
   For iX = 0 To iW - 1
      GdipBitmapGetPixel(hImage, iX, iY, @iARGB)
      aColors(iY, iX) = iARGB
   Next
Next
   

Dim As String sTitle = "GDIPlus Image Painting 4 Demo / FPS: "
Dim As UShort iFPS = 0

Dim As Double fTimer
Dim evt As Event

Screencontrol SET_DRIVER_NAME, "GDI"
Screenres iW, iH, 32, 1, GFX_HIGH_PRIORITY Or GFX_NO_SWITCH
Windowtitle sTitle

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


Dim As HWND hHWND
Screencontrol(GET_WINDOW_HANDLE, Cast(Integer, hHWND))

Dim As Any Ptr   hDC = GetDC(hHWND), _
            hHBitmap = CreateCompatibleBitmap(hDC, iW, iH), _
            hDC_backbuffer = CreateCompatibleDC(hDC), _
            hDC_obj = SelectObject(hDC_backbuffer, hHBitmap), _
            hCanvas, hPen, hBrush, hBitmap

GdipCreateFromHDC(hDC_backbuffer, @hCanvas)
GdipSetSmoothingMode(hCanvas, SmoothingModeAntiAlias)
GdipSetPixelOffsetMode(hCanvas, PixelOffsetModeHalf)
GdipGraphicsClear(hCanvas, &hFFFFFFFF)
GdipCreatePen1(&hFF000000, 1, 2, @hPen)
GdipSetPenStartCap(hPen, 2)
GdipSetPenEndCap(hPen, 2)

Randomize(, 2)

#Define Map(n, s, e, ns, ne) (ns - (ns - ne) * (n / (e - s)))
#Define Red(iCol) ((iCol And &hFF0000) Shr 16)
#Define Green(iCol) ((iCol And &hFF00) Shr 8)
#Define Blue(iCol) (iCol And &hFF)

Const fPI = Acos(-1), rad = Acos(-1) * 180
Dim As Single x, y, xx, yy, frame, count, sw, angle, lengthVariation, _fMax = Max(iW, iH), _fMin = Min(iW, iH), _
      noiseScale = 0.005, drawLength = _fMax / 2.5, fMSL = _fMin / 80, strokeLength = fMSL
Dim As Ulong col
Dim As Integer mx, my, mb
fTimer = Timer

Do
   If frame <= drawLength Then
      count = map(frame, 0, drawLength, 20, 80)
      For i As uShort = 0 To count
         strokeLength += RandomRange(-fMSL / 2, fMSL / 4)
         x = Rnd() * iW - strokeLength / 2 : xx = x
         y = Rnd() * iH - strokeLength / 2 : yy = y      
         col = aColors(Iif(y < 0, 0, Iif(y > iH - 1, iH - 1, y)), Iif(x < 0, 0, Iif(x > iW - 1, iW - 1, x)))
         GdipCreateHatchBrush(9, &h70FFFFFF And col, col, @hBrush)
         GdipSetPenBrushFill(hPen, hBrush)
         
         'GdipSetPenColor(hPen, &h70FFFFFF And col)
         sw = map(frame, 0, drawLength, 32, 1)
         GdipSetPenWidth(hPen, sw)
         angle = SimplexNoise2D(x * noiseScale, y * noiseScale, 0.2) * 3.3333
         lengthVariation = RandomRange(0.75, 1.25)
         xx += Cos((angle - fPi) * rad) * strokeLength
         yy += Sin((angle - fPi) * rad) * strokeLength
         x += Cos(angle * rad) * strokeLength
         y += Sin(angle * rad) * strokeLength
         GdipDrawLine(hCanvas, hPen, x, y, xx + strokeLength * lengthVariation, yy)
         col = RandomRange(&h18, &h40) Shl 24 Or Min(Red(col) * 3, 255) Shl 16 Or Min(Green(col * 3), 255) Shl 8 Or Min(Blue(col * 3), 255)
         GdipSetPenColor(hPen, col)
         GdipSetPenWidth(hPen, sw * 0.85)
         GdipDrawLine(hCanvas, hPen, x, y - sw * 0.15, xx + strokeLength * lengthVariation, yy - sw * 0.15)
         strokeLength = fMSL
         GdipDeleteBrush(hBrush)   
      Next
      frame += 0.25
   End If


   BitBlt(hDC, 0, 0, iW, iH, hDC_backbuffer, 0, 0, SRCCOPY)

   If(Timer - fTimer > 0.99) Then
      Windowtitle (sTitle & iFPS & " / Rendered: " & Format(frame / drawLength, "###%"))
      iFPS = 0
      fTimer = Timer
   Else
      iFPS += 1
   Endif
   
   If (Screenevent(@evt)) Then
      Select Case evt.Type
         Case EVENT_KEY_PRESS
            If evt.scancode = SC_ESCAPE Then Exit Do
            If evt.ascii = Asc("c") Then
               GdipGraphicsClear(hCanvas, &hFFFFFFFF)
               frame = 0
            Endif
         Case EVENT_WINDOW_CLOSE
            Exit Do
         Case EVENT_MOUSE_BUTTON_RELEASE
            If evt.button = BUTTON_RIGHT Then
               GdipCreateBitmapFromHBITMAP(hHBitmap, 0, @hBitmap)
               _GDIPlus_ImageSaveToFile(hBitmap, Curdir & "\Painting4_" & Format(Now(), "yyyymmdd_hhmmss") & ".jpg")
               GdipDisposeImage(hBitmap)
            End If
      End Select
   Endif
   Sleep(10, 1)
Loop

'GDI
SelectObject(hDC_backbuffer, hDC_obj)
DeleteDC(hDC_backbuffer)
DeleteObject(hHBitmap)
ReleaseDC(hHWND, hDC)

'GDIPlus
GdipDeletePen(hPen)     
GdipDeleteGraphics(hCanvas)
GdiplusShutdown(gdipToken)
End

Function RandomRange(fStart as Single, fEnd as Single) as Single
   Return Rnd() * (fEnd - fStart) + fStart
End Function

Function _GDIPlus_ImageSaveToFile(hImage As Any Ptr, Filename As Wstring, JPGQual As Ulong = 85) As Boolean
   'check If hImage Is a GDI+ image
   Dim As Single iW, iH
   If  GdipGetImageDimension(hImage, @iW, @iH) <> 0 Then Return 0
   
   Dim As Byte iErr = 0

   Dim As Ulong count, size
   GdipGetImageEncodersSize(@count, @size)
   
   Dim As CLSID clsid
   Dim As ImageCodecInfo Ptr pImageCodecInfo
   pImageCodecInfo = Allocate(size)
   GdipGetImageEncoders(count, size, pImageCodecInfo)

   #Define _MimeType(x)   (*Cast(Wstring Ptr, pImageCodecInfo[x].MimeType))
   #Define FnSuffix   (Right(Filename, 4))   
   
   For i As Ulong = 0 To count - 1
      If _MimeType(i) = "image/bmp" And FnSuffix = ".bmp" Then
         If (GdipSaveImageToFile(hImage, Wstr(Filename), @pImageCodecInfo[i].Clsid, NULL) <> 0) Then iErr += 1
      Elseif _MimeType(i) = "image/jpeg" And (FnSuffix = ".jpg" Or FnSuffix = ".jpe" Or Right(Filename, 5) = ".jpeg" Or Right(Filename, 5) = ".jfif") Then
         JPGQual = Iif(JPGQual < 0, 0, Iif(JPGQual > 100, 100, JPGQual))
         Dim tParams As EncoderParameters
         Dim EncoderQuality As String = "{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}"
         tParams.Count = 1
         CLSIDFromString(Wstr(EncoderQuality), @tParams.Parameter(0).GUID)
         With tParams.Parameter(0)
            .NumberOfValues = 1
            .Type = EncoderParameterValueTypeLong
            .Value = Varptr(JPGQual)
         End With
         If GdipSaveImageToFile(hImage, Wstr(Filename), @pImageCodecInfo[i].Clsid, @tParams) <> 0 Then iErr += 1         
      Elseif _MimeType(i) = "image/gif" And FnSuffix = ".gif" Then
         If (GdipSaveImageToFile(hImage, Wstr(Filename), @pImageCodecInfo[i].Clsid, NULL) <> 0) Then iErr += 1
      Elseif _MimeType(i) = "image/tiff" And (FnSuffix = ".tif" Or Right(Filename, 5) = ".tiff") Then
         If (GdipSaveImageToFile(hImage, Wstr(Filename), @pImageCodecInfo[i].Clsid, NULL) <> 0) Then iErr += 1
      Elseif _MimeType(i) = "image/png" And FnSuffix = ".png" Then
         If (GdipSaveImageToFile(hImage, Wstr(Filename), @pImageCodecInfo[i].Clsid, NULL) <> 0) Then iErr += 1     
      Else
         iErr += 1
      End If
   Next

   Deallocate(pImageCodecInfo)

   If iErr > 0 Then Return False

   Return True
End Function

Function _GDIPlus_BitmapCreateFromMemory3(aBinImage As Ubyte Ptr, iLen As Ulong, bBitmap_GDI As Bool = False) As Any Ptr
   Dim As HGLOBAL hGlobal
   Dim As LPSTREAM hStream
   Dim As Any Ptr hImage_Stream
   Dim As Any Ptr hMemory = GlobalAlloc(GMEM_MOVEABLE, iLen)
   Dim As Any Ptr lpMemory = GlobalLock(hMemory)
   RtlCopyMemory(lpMemory, @aBinImage[0], iLen)
   GlobalUnlock(hMemory)
   CreateStreamOnHGlobal(hMemory, 0, @hStream)
   GdipCreateBitmapFromStream(hStream, @hImage_Stream)
   IUnknown_Release(hStream)

   If bBitmap_GDI = TRUE Then
      Dim hImage_GDI As Any Ptr
      GdipCreateHBITMAPFromBitmap(hImage_Stream, @hImage_GDI, &hFF000000)
      GdipDisposeImage(hImage_Stream)
      Return hImage_GDI
   Endif

   Return hImage_Stream
End Function

Function LoadDataFromINet(sUrl As String, Byref iSize As Ulong) As Byte Ptr
   Dim As HINTERNET hOpen = InternetOpen("FB Downloader", INTERNET_OPEN_TYPE_DIRECT, NULL, NULL, INTERNET_FLAG_NO_COOKIES Or INTERNET_FLAG_NO_UI Or INTERNET_FLAG_PRAGMA_NOCACHE Or INTERNET_FLAG_SECURE), _
                hFile = InternetOpenUrl(hOpen, sURL, NULL, 0, INTERNET_FLAG_EXISTING_CONNECT, 0)
            
   Dim As Ulong iBuffLen = 32, iBytes = 1
   Dim As String sBuff = Space(32)
   HttpQueryInfo(hFile, HTTP_QUERY_CONTENT_LENGTH, StrPtr(sBuff), @iBuffLen, NULL)
   iBuffLen = Valint(Trim(sBuff))
   Dim As Byte Ptr imgBuffer
   If iBuffLen > 0 Then
      imgBuffer = Allocate(iBuffLen)
      Do Until iBytes = 0
         InternetReadFile(hFile, imgBuffer, iBuffLen, @iBytes)
      Loop
   Endif
   InternetCloseHandle(hFile)
   InternetCloseHandle(hOpen)
   iSize = iBuffLen
   Return imgBuffer
End Function

_________________
Gruß,
UEZ


Zuletzt bearbeitet von UEZ am 17.02.2019, 14:06, insgesamt 3-mal bearbeitet
Nach oben
Benutzer-Profile anzeigen Private Nachricht senden
grindstone



Anmeldungsdatum: 03.10.2010
Beiträge: 1208
Wohnort: Ruhrpott

BeitragVerfasst am: 10.02.2019, 13:50    Titel: Antworten mit Zitat

Der Download funktioniert nicht ("Something went wrong..."). Abschalten der Firewall nutzt auch nichts.

Gruß
grindstone
_________________
For ein halbes Jahr wuste ich nich mahl wie man Proggramira schreibt. Jetzt bin ich einen!
Nach oben
Benutzer-Profile anzeigen Private Nachricht senden E-Mail senden
UEZ



Anmeldungsdatum: 24.06.2016
Beiträge: 129
Wohnort: Opel Stadt

BeitragVerfasst am: 10.02.2019, 14:53    Titel: Antworten mit Zitat

Hmm, das ist komisch.

Du hast nicht zufällig einen Proxy eingetragen? Läuft die Exe über Wine?

Hat jemand auch dieses Problem?
_________________
Gruß,
UEZ
Nach oben
Benutzer-Profile anzeigen Private Nachricht senden
grindstone



Anmeldungsdatum: 03.10.2010
Beiträge: 1208
Wohnort: Ruhrpott

BeitragVerfasst am: 10.02.2019, 15:38    Titel: Antworten mit Zitat

Kein Proxy, kein Wine (WinXP 32). Ich habe im Augenblick auch leider keine Zeit, den Fehler (oder zumindest die Stelle, an der es hakt) zu suchen. traurig

Gruß
grindstone
_________________
For ein halbes Jahr wuste ich nich mahl wie man Proggramira schreibt. Jetzt bin ich einen!
Nach oben
Benutzer-Profile anzeigen Private Nachricht senden E-Mail senden
UEZ



Anmeldungsdatum: 24.06.2016
Beiträge: 129
Wohnort: Opel Stadt

BeitragVerfasst am: 10.02.2019, 16:32    Titel: Antworten mit Zitat

WinXP? -> Never change a running system... zwinkern

Ich habe die Funktion in meiner VM getestet und es scheint, dass das Problem an der Funktion InternetOpenUrl() liegt, die 0 zurück gibt.

Warum das nicht mit WinXP funktioniert, habe ich noch nicht herausgefunden, aber es scheint an der URL (https://leaders.economicblogs.org/wp-content/uploads/2018/12/AEG.jpg) zu liegen, die sich nicht öffnen lässt.

Alternativ kannst du eine andere URL benutzen -> Zeile 136+
_________________
Gruß,
UEZ
Nach oben
Benutzer-Profile anzeigen Private Nachricht senden
grindstone



Anmeldungsdatum: 03.10.2010
Beiträge: 1208
Wohnort: Ruhrpott

BeitragVerfasst am: 11.02.2019, 10:14    Titel: Antworten mit Zitat

Bei unverschlüsselter Übertragung (also http: statt https:) funktioniert es, sofern der Server das unterstützt. Hast du (oder sonst irgendjemand) eine Ahnung, wie ich eine SSL - Verbindung hinbekomme?

Gruß
grindstone
_________________
For ein halbes Jahr wuste ich nich mahl wie man Proggramira schreibt. Jetzt bin ich einen!
Nach oben
Benutzer-Profile anzeigen Private Nachricht senden E-Mail senden
nemored



Anmeldungsdatum: 22.02.2007
Beiträge: 4594
Wohnort: ~/

BeitragVerfasst am: 11.02.2019, 18:05    Titel: Antworten mit Zitat

Unter Linux würde ich wget nehmen - das gibt es auch für Windows (nicht getestet), würde aber bedeuten, dass du immer ein externes Programm mitliefern musst.
_________________
Deine Chance beträgt 1:1000. Also musst du folgendes tun: Vergiss die 1000 und konzentriere dich auf die 1.
Nach oben
Benutzer-Profile anzeigen Private Nachricht senden
Sebastian
Administrator


Anmeldungsdatum: 10.09.2004
Beiträge: 5969
Wohnort: Deutschland

BeitragVerfasst am: 11.02.2019, 19:18    Titel: wininet.dll vs. Internet Explorer auf Windows XP Antworten mit Zitat

Hallo,

die benutzten, einfachen Windows-Bordmittel zum Zugriff auf HTTP(S) kommen aus der "wininet.dll" und gehören zur gleichen technischen Basis wie der Internet Explorer, wenn ich mich nicht täusche. (Hieß die zugrundeliegende SSL-Bibliothek "schannel"?)

Windows XP unterstützt ja nur höchstens den alten Internet Explorer 8. Der ist zu den aktuellen TLS-Versionen und CipherSuites nicht mehr kompatibel. Dadurch kann man damit auf viele HTTPS-verschlüsselte Seiten gar nicht mehr zugreifen, weil die Server die Legacy-Algorithmen gar nicht mehr anbieten und sich Server und Client somit nicht auf die Protokolleinstellungen einigen können. Von daher überrascht es mich nicht, dass diese wininet-Funktionen unter Windows XP mit so mancher verschlüsselter Website Probleme haben.

Hier ein Beispiel der SSLLabs-Testergebnisse für eine ganz gute Website lächeln Auch in dem Fall kommt unter Windows XP mit dem IE8 keine Übertragung zustande:




Alternativ könnte man die cURL-Bibliothek verwenden. Die wäre vom jeweils installierten Internet Explorer unabhängig.

Oder als ganz letzten Ausweg könnte man HTTPS auf Basis von Winsock und OpenSSL selber zu Fuß implementieren, aber das wäre so verrückt und kompliziert, das macht höchstens ThePuppetMaster. happy

Viele Grüße!
Sebastian
_________________

Der Markt regelt das! | Opas Leistung muss sich wieder lohnen - für 6 bis 10 Generationen!
Nach oben
Benutzer-Profile anzeigen Private Nachricht senden E-Mail senden Website dieses Benutzers besuchen
UEZ



Anmeldungsdatum: 24.06.2016
Beiträge: 129
Wohnort: Opel Stadt

BeitragVerfasst am: 11.02.2019, 19:40    Titel: Re: wininet.dll vs. Internet Explorer auf Windows XP Antworten mit Zitat

Sebastian hat Folgendes geschrieben:
Hallo,

die benutzten, einfachen Windows-Bordmittel zum Zugriff auf HTTP(S) kommen aus der "wininet.dll" und gehören zur gleichen technischen Basis wie der Internet Explorer, wenn ich mich nicht täusche. (Hieß die zugrundeliegende SSL-Bibliothek "schannel"?)

Windows XP unterstützt ja nur höchstens den alten Internet Explorer 8. Der ist zu den aktuellen TLS-Versionen und CipherSuites nicht mehr kompatibel. Dadurch kann man damit auf viele HTTPS-verschlüsselte Seiten gar nicht mehr zugreifen, weil die Server die Legacy-Algorithmen gar nicht mehr anbieten und sich Server und Client somit nicht auf die Protokolleinstellungen einigen können. Von daher überrascht es mich nicht, dass diese wininet-Funktionen unter Windows XP mit so mancher verschlüsselter Website Probleme haben.

Alternativ könnte man die cURL-Bibliothek verwenden. Die wäre vom jeweils installierten Internet Explorer unabhängig.

Oder als ganz letzten Ausweg könnte man HTTPS auf Basis von Winsock und OpenSSL selber zu Fuß implementieren, aber das wäre so verrückt und kompliziert, das macht höchstens ThePuppetMaster. happy

Viele Grüße!
Sebastian


Oder "einfach" das Betriebssystem aktualisieren. zwinkern

Meine Tests in der WinXP VM bestätigen Sebastian's Aussage. Manche HTTPS Seiten funktionieren, manche nicht.
_________________
Gruß,
UEZ
Nach oben
Benutzer-Profile anzeigen Private Nachricht senden
grindstone



Anmeldungsdatum: 03.10.2010
Beiträge: 1208
Wohnort: Ruhrpott

BeitragVerfasst am: 11.02.2019, 23:53    Titel: Re: wininet.dll vs. Internet Explorer auf Windows XP Antworten mit Zitat

UEZ hat Folgendes geschrieben:
Oder "einfach" das Betriebssystem aktualisieren. zwinkern
Schon... Die Sache ist nur die, daß ich für XP einen Aktivierungspatch habe, so daß ich nicht bei jeder kleinen Hardwareänderung die Firma M'soft anbetteln muß, mir mein Betriebssystem wieder freizuschalten. Außerdem wird Windows immer restriktiver.

Wenn ich nicht zu faul wäre, mich neu einzuarbeiten, wäre ich schon längst auf Linux umgestiegen. grinsen

Gruß
grindstone
_________________
For ein halbes Jahr wuste ich nich mahl wie man Proggramira schreibt. Jetzt bin ich einen!
Nach oben
Benutzer-Profile anzeigen Private Nachricht senden E-Mail senden
Sebastian
Administrator


Anmeldungsdatum: 10.09.2004
Beiträge: 5969
Wohnort: Deutschland

BeitragVerfasst am: 11.02.2019, 23:56    Titel: Antworten mit Zitat

[OT]
Aber grindstone, ist dir denn gar nicht danach, durch Übermittlung möglichst vieler Daten zur Verbesserung von Produkten und zur Kooperation mit Partnern beizutragen?! lachen
[/OT]
_________________

Der Markt regelt das! | Opas Leistung muss sich wieder lohnen - für 6 bis 10 Generationen!
Nach oben
Benutzer-Profile anzeigen Private Nachricht senden E-Mail senden Website dieses Benutzers besuchen
grindstone



Anmeldungsdatum: 03.10.2010
Beiträge: 1208
Wohnort: Ruhrpott

BeitragVerfasst am: 12.02.2019, 00:33    Titel: Antworten mit Zitat

Ehrlich gesagt: NEIN! grinsen

Ich habe z.B. vor einiger Zeit auf der Suche nach einem Ersatzteilträger für einen meiner Oldies den Suchbegriff "Ratte" eingegeben, im Sinne von "heruntergekommener Gebrauchtwagen". Danach habe ich dann tagelang Werbung von Schädlingsbekämpfern bekommen.

Vielleicht sollte ich meine Onlineaktivitäten ja komplett ins Darknet verlegen...

Gruß
grindstone
_________________
For ein halbes Jahr wuste ich nich mahl wie man Proggramira schreibt. Jetzt bin ich einen!
Nach oben
Benutzer-Profile anzeigen Private Nachricht senden E-Mail senden
Beiträge der letzten Zeit anzeigen:   
Neues Thema eröffnen   Neue Antwort erstellen    Das deutsche QBasic- und FreeBASIC-Forum Foren-Übersicht -> Projektvorstellungen Alle Zeiten sind GMT + 1 Stunde
Gehe zu Seite Zurück  1, 2, 3, 4, 5, 6  Weiter
Seite 4 von 6

 
Gehe zu:  
Du kannst keine Beiträge in dieses Forum schreiben.
Du kannst auf Beiträge in diesem Forum nicht antworten.
Du kannst deine Beiträge in diesem Forum nicht bearbeiten.
Du kannst deine Beiträge in diesem Forum nicht löschen.
Du kannst an Umfragen in diesem Forum nicht mitmachen.

 Impressum :: Datenschutz