|
Das deutsche QBasic- und FreeBASIC-Forum Für euch erreichbar unter qb-forum.de, fb-forum.de und freebasic-forum.de!
|
Vorheriges Thema anzeigen :: Nächstes Thema anzeigen |
Autor |
Nachricht |
Sebastian Administrator
Anmeldungsdatum: 10.09.2004 Beiträge: 5969 Wohnort: Deutschland
|
|
Nach oben |
|
|
nemored
Anmeldungsdatum: 22.02.2007 Beiträge: 4637 Wohnort: ~/
|
Verfasst am: 04.03.2018, 21:34 Titel: |
|
|
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 |
|
|
UEZ
Anmeldungsdatum: 24.06.2016 Beiträge: 130 Wohnort: Opel Stadt
|
Verfasst am: 27.04.2018, 13:53 Titel: Simple Recursive Tree Generator |
|
|
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, 13:01, insgesamt einmal bearbeitet |
|
Nach oben |
|
|
UEZ
Anmeldungsdatum: 24.06.2016 Beiträge: 130 Wohnort: Opel Stadt
|
Verfasst am: 05.07.2018, 19:59 Titel: GDI+ Star Wars Intro |
|
|
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. _________________ Gruß,
UEZ
Zuletzt bearbeitet von UEZ am 12.10.2018, 13:00, insgesamt einmal bearbeitet |
|
Nach oben |
|
|
UEZ
Anmeldungsdatum: 24.06.2016 Beiträge: 130 Wohnort: Opel Stadt
|
Verfasst am: 12.10.2018, 12:58 Titel: GDI / GDI+ Matrix Code Rain |
|
|
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 |
|
|
UEZ
Anmeldungsdatum: 24.06.2016 Beiträge: 130 Wohnort: Opel Stadt
|
Verfasst am: 27.12.2018, 15:48 Titel: Snowfall |
|
|
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
|
Edit1: kleine Modifikationen an den Parametern _________________ Gruß,
UEZ
Zuletzt bearbeitet von UEZ am 29.12.2018, 00:23, insgesamt 2-mal bearbeitet |
|
Nach oben |
|
|
grindstone
Anmeldungsdatum: 03.10.2010 Beiträge: 1230 Wohnort: Ruhrpott
|
Verfasst am: 28.12.2018, 09:32 Titel: |
|
|
Beeindruckend, aber es gibt einige Querulanten unter den Schneeflocken, die sich aufwärts bewegen.
Gruß
grindstone _________________ For ein halbes Jahr wuste ich nich mahl wie man Proggramira schreibt. Jetzt bin ich einen! |
|
Nach oben |
|
|
UEZ
Anmeldungsdatum: 24.06.2016 Beiträge: 130 Wohnort: Opel Stadt
|
Verfasst am: 28.12.2018, 12:06 Titel: |
|
|
grindstone hat Folgendes geschrieben: | Beeindruckend, aber es gibt einige Querulanten unter den Schneeflocken, die sich aufwärts bewegen.
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 |
|
|
UEZ
Anmeldungsdatum: 24.06.2016 Beiträge: 130 Wohnort: Opel Stadt
|
Verfasst am: 09.02.2019, 15:02 Titel: van Gogh Style Malerei [Windows] |
|
|
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, 15:06, insgesamt 3-mal bearbeitet |
|
Nach oben |
|
|
grindstone
Anmeldungsdatum: 03.10.2010 Beiträge: 1230 Wohnort: Ruhrpott
|
Verfasst am: 10.02.2019, 14:50 Titel: |
|
|
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 |
|
|
UEZ
Anmeldungsdatum: 24.06.2016 Beiträge: 130 Wohnort: Opel Stadt
|
Verfasst am: 10.02.2019, 15:53 Titel: |
|
|
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 |
|
|
grindstone
Anmeldungsdatum: 03.10.2010 Beiträge: 1230 Wohnort: Ruhrpott
|
Verfasst am: 10.02.2019, 16:38 Titel: |
|
|
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.
Gruß
grindstone _________________ For ein halbes Jahr wuste ich nich mahl wie man Proggramira schreibt. Jetzt bin ich einen! |
|
Nach oben |
|
|
UEZ
Anmeldungsdatum: 24.06.2016 Beiträge: 130 Wohnort: Opel Stadt
|
Verfasst am: 10.02.2019, 17:32 Titel: |
|
|
WinXP? -> Never change a running system...
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 |
|
|
grindstone
Anmeldungsdatum: 03.10.2010 Beiträge: 1230 Wohnort: Ruhrpott
|
Verfasst am: 11.02.2019, 11:14 Titel: |
|
|
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 |
|
|
nemored
Anmeldungsdatum: 22.02.2007 Beiträge: 4637 Wohnort: ~/
|
Verfasst am: 11.02.2019, 19:05 Titel: |
|
|
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 |
|
|
Sebastian Administrator
Anmeldungsdatum: 10.09.2004 Beiträge: 5969 Wohnort: Deutschland
|
Verfasst am: 11.02.2019, 20:18 Titel: wininet.dll vs. Internet Explorer auf Windows XP |
|
|
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 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.
Viele Grüße!
Sebastian _________________
Die gefährlichsten Familienclans | Opas Leistung muss sich wieder lohnen - für 6 bis 10 Generationen! |
|
Nach oben |
|
|
UEZ
Anmeldungsdatum: 24.06.2016 Beiträge: 130 Wohnort: Opel Stadt
|
Verfasst am: 11.02.2019, 20:40 Titel: Re: wininet.dll vs. Internet Explorer auf Windows XP |
|
|
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.
Viele Grüße!
Sebastian |
Oder "einfach" das Betriebssystem aktualisieren.
Meine Tests in der WinXP VM bestätigen Sebastian's Aussage. Manche HTTPS Seiten funktionieren, manche nicht. _________________ Gruß,
UEZ |
|
Nach oben |
|
|
grindstone
Anmeldungsdatum: 03.10.2010 Beiträge: 1230 Wohnort: Ruhrpott
|
Verfasst am: 12.02.2019, 00:53 Titel: Re: wininet.dll vs. Internet Explorer auf Windows XP |
|
|
UEZ hat Folgendes geschrieben: | Oder "einfach" das Betriebssystem aktualisieren. | 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.
Gruß
grindstone _________________ For ein halbes Jahr wuste ich nich mahl wie man Proggramira schreibt. Jetzt bin ich einen! |
|
Nach oben |
|
|
Sebastian Administrator
Anmeldungsdatum: 10.09.2004 Beiträge: 5969 Wohnort: Deutschland
|
|
Nach oben |
|
|
grindstone
Anmeldungsdatum: 03.10.2010 Beiträge: 1230 Wohnort: Ruhrpott
|
Verfasst am: 12.02.2019, 01:33 Titel: |
|
|
Ehrlich gesagt: NEIN!
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 |
|
|
|
|
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.
|
|