An Infinite zoom-in through the world of Arkadia flight.
Code: Select all
'coded by UEZ build 2018-01-09
'inspired by http://arkadia.xyz - thanks to by Nikolaus Baumgarten and Sophia Schomberg
'thanks to spudw2k for the mouse calculation
#define WIN_INCLUDEALL
#Include "fbgfx.bi"
#include "file.bi"
#Include "windows.bi"
#Include "win/gdiplus.bi"
Using GDIPLUS
Using FB
#Ifndef Floor
#Define Floor(x) (((x) * 2.0 - 0.5) Shr 1) '' http://www.freebasic.net/forum/viewtopic.php?p=118633
#Define Ceiling(x) (-((-(x) * 2.0 - 0.5) Shr 1))
#EndIf
declare function RemoteGetFile(url as string, filePath as string) as HRESULT
declare Sub DownloadImages()
DownloadImages() 'download images if not exist, code will end if download fails
Dim GDIPlusStartupInput As GDIPLUSSTARTUPINPUT
Dim As ULONG_PTR GDIPlusToken
GDIPlusStartupInput.GdiplusVersion = 1
If (GdiplusStartup(@GDIPlusToken, @GDIPlusStartupInput, NULL) <> 0) Then
End 'FAILED TO INIT GDI+!
EndIf
Dim as any Ptr aImages(0 to 49), hImage
Dim as UByte i
'load local images with GDIPlus and convert it to GDI
For i = 0 to 48
GdipLoadImageFromFile(CurDir & "\Images\Arkadia" & i & ".jpg", @hImage)
GdipCreateHBITMAPFromBitmap(hImage, @aImages(i), &hFF000000)
GdipDisposeImage(hImage)
Next
Dim As String sTitle = "GDI Infinite Image Zoom Flight v1.2"
'get desktop dimension
Dim As Integer iW_Dt, iH_Dt
ScreenInfo iW_Dt, iH_Dt
'image dimension
Const As Integer iW = 1200, iH = 900
ScreenControl FB.SET_DRIVER_NAME, "GDI"
ScreenRes iW_Dt, iH_Dt, 32, 1, GFX_HIGH_PRIORITY or GFX_FULLSCREEN or GFX_ALWAYS_ON_TOP
WindowTitle sTitle
Dim as HWND hHWND
ScreenControl(FB.GET_WINDOW_HANDLE, Cast(Integer, hHWND))
Dim As Any Ptr hDC = GetDC(hHWND), _
hHBitmap = CreateCompatibleBitmap(hDC, iW_Dt, iH_Dt), _
hDC_backbuffer = CreateCompatibleDC(hDC), _
hMemDC = CreateCompatibleDC(hDC), hFont, DC_obj, hObjOld, hObjOld2
DC_obj = SelectObject(hDC_backbuffer, hHBitmap)
SetStretchBltMode(hDC_backbuffer, STRETCH_DELETESCANS)
hFont = CreateFontW(12, 0, 0, 0, FW_NORMAL, 0, 0, 0, DEFAULT_CHARSET, OUT_DEFAULT_PRECIS, CLIP_DEFAULT_PRECIS, _
ANTIALIASED_QUALITY, DEFAULT_PITCH, "Arial")
hObjOld2 = SelectObject(hDC_backbuffer, hFont)
SetTextColor(hDC_backbuffer, &hFFFFFF)
SetBkMode(hDC_backbuffer, TRANSPARENT)
Dim evt As EVENT
Dim As ULong iFPS = 0
Dim as String sFPS = "0"
Dim As Double fTimer = Timer
'position FPS text
Dim tRECT as tagRECT
tRECT.Left = 4
tRECT.top = 4
tRECT.Right = 100
tRECT.Bottom = 20
Dim as any Ptr a(0 to 2)
Dim as Single b = 1.0, c, x, y, w, h, q, r, w2, h2
Dim as UByte e
w2 = iW_Dt / 2
h2 = iH_Dt / 2
If iW_Dt > 1.5 * iH_Dt Then
q = iW_Dt
r = 0.75 * iW_Dt
Else
q = 1.5 * iH_Dt
r = 0.75 * iH_Dt
EndIf
Dim as Single iStep = 0.025, iOutMin = 1, iOutMax = -1
Dim as UShort iInMin = 0, iInMax = iH_Dt
Dim As Integer iMPosX, iMPosY, iMPos
Do
For e = 0 to 2
a(e) = aImages((Floor(b) + e) Mod Ubound(aImages))
Next
c = 2^(Frac(b))
For e = 0 to 2
x = w2 - q / 2 * c
y = h2 - r / 2 * c
w = q * c
h = r * c
hObjOld = SelectObject(hMemDC, a(e))
StretchBlt(hDC_backbuffer, Floor(x), Floor(y), Floor(w), Floor(h), hMemDC, 0, 0, iW, iH, SRCCOPY)
c *= 0.5
Next
iMPos = GetMouse (iMPosx, iMPosY)
b += ((iMPosY - iInMin) * (iOutMax - iOutMin) / (iInMax - iInMin) + iOutMin) * iStep
IF b < 0 Then b = UBound(aImages) - b
DrawTextW(hDC_backbuffer, "FPS: " & sFPS, -1, @tRECT, 0)
BitBlt(hDC, 0, 0, iW_Dt, iH_Dt, hDC_backbuffer, 0, 0, SRCCOPY)
If Timer - fTimer > 0.99 Then
sFPS = str(iFPS)
iFPS = 0
fTimer = Timer
Else
iFPS += 1
EndIf
'Sleep(1, 1)
Loop Until ((InKey = Chr(27)) Or (evt.Type = EVENT_WINDOW_CLOSE))
'Release resources
For i = 0 to 48
DeleteObject(aImages(i))
Next
SelectObject(hDC_backbuffer, hObjOld2)
DeleteObject(hFont)
SelectObject(hMemDC, hObjOld)
DeleteDC(hMemDC)
SelectObject(hDC_backbuffer, DC_obj)
DeleteDC(hDC_backbuffer)
ReleaseDC(hHWND, hDC)
GdiplusShutdown(GDIPlusToken)
Sub DownloadImages()
If FileExists(CurDir & "\Images") = 0 Then
MkDir(CurDir & "\Images")
End If
Dim as UByte i
For i = 0 to 48
If FileExists(CurDir & "\Images\Arkadia" & i & ".jpg") = 0 Then
? "Downloading " & i + 1 & " / 49"
If RemoteGetFile("http://arkadia.xyz/images/arkadia" & i & ".jpg", CurDir & "\Images\Arkadia" & i & ".jpg") < 0 Then End
End If
Next
End Sub
'https://www.freebasic.net/forum/viewtopic.php?f=6&t=24197&p=214027&hilit=URLDownloadToFile#p214324
function RemoteGetFile(url as string, filePath as string) as HRESULT '0 = success
var hLib = Dylibload("urlmon.dll")
if hLib = null then
return -1
end if
dim pURLDownloadToFile as function _
( _
byval as LPUNKNOWN, _
byval as LPCSTR, _
byval as LPCSTR, _
byval as DWORD, _
byval as LPBINDSTATUSCALLBACK _
) as HRESULT
pURLDownloadToFile = Dylibsymbol( hLib, "URLDownloadToFileA" )
if pURLDownloadToFile = null then
dylibfree(hLib)
return -2
end if
var result = pURLDownloadToFile(0, url, filePath, 0, 0)
Dylibfree(hLib)
return result
end function
I used GDI because I don't know whether an equivalent FB function to StretchBlt is available - thus windows only.
The original web version is much smoother in zooming animation. GDI is unfortunately not.
Maybe someone has an idea...