## Rotating Earth build 2019-04-14

UEZ
Posts: 336
Joined: May 05, 2017 19:59
Location: Germany

### Rotating Earth build 2019-04-14

I've already coded this using GDI+ but now my try to code it without GDI+ using native FB code. That means it should run also on Linux (not tested by me).

Source code:

Code: Select all

`'Main code by UEZ'Image to sphere projection by andalmeida -> https://www.codeproject.com/Articles/19712/Mapping-Images-On-Spherical-Surfaces-Using-C'Image resize function by Saleth Prakash -> https://www.codeproject.com/Articles/33838/Image-Processing-Using-C'ASM sinus / cosinus functions code by eukalyptus'CreateGradientSphere function by Martijn van Iersel -> http://www.helixsoft.nl/articles/sphere/sphere.html'Thanks to dodicat for tweaking the code and the Regulate function!#include "vbcompat.bi"Declare Function _ASM_Cos6th(fX As Double) As DoubleDeclare Function _ASM_Sin6th(fX As Double) As DoubleType Ang 'FLOATS For angles    As Double sx,sy,sz    As Double cx,cy,czEnd TypeFunction Construct(x As Double,y As Double,z As Double) As Ang    Return Type (_ASM_Sin6th(x),_ASM_Sin6th(y),_ASM_Sin6th(z), _                 _ASM_Cos6th(x),_ASM_Cos6th(y),_ASM_Cos6th(z))End FunctionDeclare Sub CreateGlobe(radius As Single, rx As Single, ry As Single, dx As Ushort, dy As Ushort, w As Ushort, h As Ushort, destw As Ushort, desth As Ushort, fEclipticAngle As Single = 0)Declare Sub RotX(angle As ang, Byref y As Double, Byref z As Double)Declare Sub RotY(angle As ang, Byref x As Double, Byref z As Double)Declare Sub RotZ(angle As ang, Byref x As Double, Byref y As Double)Declare Sub AA2(x As Ushort, y As Ushort, w As Ushort, h As Ushort, iScale As Ubyte = 2)Declare Sub CreateSphere(imageS As Any Ptr, imageD As Any Ptr, w As Ushort, h As Ushort)Declare Function ResizeImage(pImage As Any Pointer, iW_new As Ushort, iH_new As Ushort) As Any PointerDeclare Function RandomRange(fStart As Single, fEnd As Single) As SingleDeclare Function CreateGradientSphere(cx As Single, cy As Single, radius As Ushort, lx As Single, ly As Single, zl As Single = 255) As Any PtrDeclare Function Ecliptic(iDayOfYear As Ushort) As DoubleDeclare Function Regulate(Byval MyFps As Long, Byref fps As Ushort) As Long#Define PixelGet(_x, _y)                      *Cptr(Ulong Ptr, imgDataS + (_y) * pitchS + (_x) Shl 2)#Define PixelGet2(_x, _y)                     *Cptr(Ulong Ptr, imgDataD + (_y) * pitch + (_x) Shl 2)#Define PixelGetM(_x, _y)                     *Cptr(Ulong Ptr, imgDataM + (_y) * pitchM + (_x) Shl 2)#Define PixelSet(_x, _y, colour)              *Cptr(Ulong Ptr, imgDataD + (_y) * pitch + (_x) Shl 2) = (colour)#Define PixelSetM(_x, _y, colour)             *Cptr(Ulong Ptr, imgDataM + (_y) * pitchM + (_x) Shl 2) = (colour)#Define Min(a, b)                            (Iif(a < b, a, b))#Define Max(a, b)                            (Iif(a > b, a, b))#Define MapCoordinate(i1, i2, w1, w2, p)    (((p - i1) / (i2 - i1)) * (w2 - w1) + w1)#Define Red(colors)                          ((colors Shr 16) And 255)#Define Green(colors)                        ((colors Shr 8) And 255)#Define Blue(colors)                         (colors And 255)#Define Alpha(colors)                        ((colors Shr 24) And 255)#Define Round(x)                            ((x + 0.5) Shr 0)#Define Floor(x)                            (((x) * 2.0 - 0.5) Shr 1)Const phi0 = 0.0, phi1 = Acos(-1), theta0 = 0.0, theta1 = 2.0 * Acos(-1), rad = Acos(-1) / 180, deg = 180 / Acos(-1)Const iW = 1000, iH = 500, iW2 = iW \ 2, iH2 = iH \ 2, srotx = 1.5 * deg, r = 125, dm = 2 * r, md = (iW - 200)  / 2Const iWe = 600, iHe = 300, iW2e = iWe \ 2, iH2e = iHe \ 2Dim As Double fEclipticAngle = Ecliptic(Int(Now() - DateSerial(Year(Now()),1,1)))'needed for Sub CreateGlobeConst iMin = Min(iWe, iHe), iMin2 = iMin * 0.33, deltac = 1 + (r \ iMin) Shl 1Screenres iW, iH, 32, 2Screenset 1, 0Windowtitle "FB Rotating Earth coded by UEZ build 2019-04-14"Dim Shared As Any Ptr pImageS, pImageD, pImageB, pImageG, pImageGM, pImageM, pImageMs, imgDataS, imgDataD, imgDataMpImageS = Imagecreate(iWe, iHe, 0, 32)pImageD = Imagecreate(iW, iH, 0, 32)pImageB = Imagecreate(iW, iH, 0, 32)pImageM = Imagecreate(200, 200, 0, 32)pImageGM = Imagecreate(200, 200, 0, 32)Bload("Earth4_600x300.bmp", pImageS)Bload("Galaxy_1000x500.bmp", pImageB)Bload("Moon_200x200.bmp", pImageM)Dim Shared As Integer pitch, pitchS, pitchG, pitchMImageinfo(pImageS, , , , pitchS, imgDataS)  'earth mapImageinfo(pImageD, , , , pitch, imgDataD)  'final image which will be drawn To ScreenImageinfo(pImageM, , , , pitchM, imgDataM) 'moon image'make moon transparentFor xx As Ushort = 0 To 199   For yy As Ushort = 0 To 199      If PixelGetM(xx, yy) = &hFFFF0000 Then PixelSetM(xx, yy, 0)   NextNext'blur moon To Get rid of sharp edgesDim As Ulong resultAlpha, resultRed, resultGreen, resultBlue, col, iScale = 2, gridSize = iScale * iScaleFor iY As Ushort = 0 To 199   For iX As Ushort = 0 To 199      resultRed = 0: resultGreen = 0: resultBlue = 0: resultAlpha = 0      For xx As Ubyte = 0 To iScale - 1         For yy As Ubyte = 0 To iScale - 1            col = PixelGetM(iX + xx, iY + yy)            resultRed += Red(col)            resultGreen += Green(col)            resultBlue += Blue(col)            resultAlpha += Alpha(col)         Next      Next      PixelSetM(iX, iY, Rgba(resultRed / gridSize, resultGreen / gridSize, resultBlue / gridSize, resultAlpha / gridSize))   NextNextpImageG = CreateGradientSphere(r, r, r, 80 * rad, 0)Dim As Single fDeg = -2 * deg, z = 90, z2 = 90, zz, zzz, fz, fs, fx, ca1, fy = iH2 - r / 2,  fSpeedMoon = 0.2Type tComet   As Single x, y, vx, vy, lenEnd TypeDim As tComet CometDim As Short iLife = 255Dim As Byte iDir = 1Randomize , 2Comet.x = RandomRange(-1, 1)If Comet.x < 0 Then    Comet.x = 0Else   Comet.x = iW   iDir *= -1End IfComet.y = 10 + Rnd() * (iH - 20)Comet.vx = RandomRange(1, 10) * iDirComet.vy = RandomRange(1, 10) * iDirComet.len = RandomRange(5, 10) * iDirDim As Ushort iFPS = 0, iFPS_currentDim As Single pdx, pdy, dt = 5 + Rnd() * 5Dim As Double fTimer1, fTimer2fTimer1 = TimerfTimer2 = TimerDo   Put pImageD, (0, 0), pImageB, Pset 'copy background (galaxy)   If Timer - fTimer1 > dt Then 'draw a simple meteor flying thru the screen      pdx = Comet.x + Comet.vx * Comet.len      pdy = Comet.y + Comet.vy * Comet.len      Line pImageD, (Comet.x, Comet.y)-(pdx, pdy), Rgb(iLife, iLife, iLife)      iLife -= Abs(Comet.len \ 2)      If iLife < 1 Or (Comet.x < 0 And pdx < 0) Or (Comet.x > iW And pdx > iW) Or (Comet.y < 0 And pdy < 0) Or (Comet.y > iH And pdy > iH) Then         iDir = 1         Comet.x = RandomRange(-1, 1)         If Comet.x < 0 Then             Comet.x = 0         Else            Comet.x = iW            iDir *= -1         End If         Comet.y = 20 + Rnd() * (iH - 40)         Comet.vx = 1 + Rnd() * 10 * iDir         Comet.vy = 1 + Rnd() * 10 * iDir         Comet.len = RandomRange(5, 10) * iDir         iLife = 255         dt = 5 + Rnd() * 5         fTimer1 = Timer      Else         Comet.x += Comet.vx         Comet.y += Comet.vy      End If   End If      zz = z * rad   fx = iW2 - _ASM_Cos6th(zz) * md   z -= fSpeedMoon   fz = _ASM_Sin6th(zz)   fy += _ASM_Sin6th(-zz) * fSpeedMoon * 2.25      fS = 100 - fz * 50   pImageMs = ResizeImage(pImageM, fS, fS) 'resize moon   ca1 = fs / 2   PImageGM = CreateGradientSphere(ca1, ca1, (fS + 2) / 2, iW, 0, 255 + fz)      If fz > 0 Then 'moon is in on back side of earth      Put pImageD, (fx - ca1, fy), pImageMs, Alpha      Put pImageD, (fx - ca1, fy), pImageGM, Alpha      CreateGlobe(r - 3, srotx, fDeg, iW2, iH2, iWe, iHe, iW, iH, fEclipticAngle)         Put pImageD, (iW2 - r, iH2 - r), pImageG, Alpha   Else      CreateGlobe(r - 3, srotx, fDeg, iW2, iH2, iWe, iHe, iW, iH, fEclipticAngle)      Put pImageD, (iW2 - r, iH2 - r), pImageG, Alpha      Put pImageD, (fx - ca1, fy), pImageMs, Alpha      Put pImageD, (fx - ca1, fy), pImageGM, Alpha   End If   fDeg -= 0.75   Put (0, 0), pImageD, Pset    Imagedestroy(pImageMs)   Imagedestroy(pImageGM)   Draw String(8, 8), iFPS_current & " fps", Rgb(&hF0, &hF0, &hF0)   If Timer - fTimer2 > 0.99 Then     iFPS_current = iFPS     iFPS = 0     fTimer2 = Timer   End If   Flip   Sleep Regulate(60, iFPS), 1Loop Until Inkey = Chr(27) 'press ESC To exitImagedestroy(pImageS)Imagedestroy(pImageD)Imagedestroy(pImageB)Imagedestroy(pImageG)Imagedestroy(pImageM)Function Regulate(Byval MyFps As Long, Byref fps As Ushort) As Long    'code by dodicat   Static As Double timervalue, _lastsleeptime, t3, frames   Var t = Timer   frames += 1   If (t - t3) >= 1 Then t3 = t : fps = frames : frames = 0   Var sleeptime = _lastsleeptime + ((1 / myfps) - T + timervalue) * 1000   If sleeptime < 1 Then sleeptime = 1   _lastsleeptime = sleeptime   timervalue = T   Return sleeptimeEnd Function'Obliquity of the ecliptic, only an approximation -> see https://en.wikipedia.org/wiki/Axial_tilt#EarthFunction Ecliptic(iDayOfYear As Ushort) As Double 'iDayOfYear -> 1 to 365   Return -Cos((iDayOfYear - 1) * 2 * ACos(-1) / 365.25 + 0.205) * 23.44End FunctionSub CreateGlobe(radius As Single, rx As Single, ry As Single, dx As Ushort, dy As Ushort, w As Ushort, h As Ushort, destw As Ushort, desth As Ushort, fEclipticAngle As Single = 0)   Dim As Double theta, phi, px, py, pz, c1   Dim As Short posx, posy   Dim As Ulong col   Dim As Single col2   Dim As Ang a = Construct(rx * rad, ry * rad, fEclipticAngle * rad)       For y As Ushort = 0 To h - 1      For x As Ushort = 0 To w - 1         theta = MapCoordinate(0, w - 1, theta1, theta0, x)         phi = MapCoordinate(0, h - 1, phi0, phi1, y)         c1 = radius * _ASM_Sin6th(phi)         px = c1 * _ASM_Cos6th(theta)         py = c1 * _ASM_Sin6th(theta)         pz = radius * _ASM_Cos6th(phi)         RotX(a, py, pz) 'rx         RotY(a, px, pz) 'ry         RotZ(a, px, py)         If pz > 0 Then            posx = (px + dx)            posy = (py + dy)            If posx >= 0 And posx < destw And posy >= 0 And posy < desth Then                col = PixelGet(x, y)                If radius < iMin2 Then                  PixelSet(posx, posy, col)               Else                  'Line pImageD, (posx, posy) - (posx + c, posy + c), col, BF 'too slow                  For yy As Ushort = posy To posy + deltac                     For xx As Ushort = posx To posx + deltac                        If xx < destw And yy < desth Then PixelSet(xx, yy, col)                     Next                  Next                  'PixelSet(posx, posy, col)               End If            End If         End If      Next   Next   End SubSub RotX(angle As ang, Byref y As Double, Byref z As Double)    Dim As Double y1 = y * angle.cx - z * angle.sx, _              z1 = y * angle.sx + z * angle.cx   y = y1   z = z1End SubSub RotY(angle As ang, Byref x As Double, Byref z As Double)     Dim As Double x1 = x * angle.cy - z * angle.sy, _              z1 = x * angle.sy + z * angle.cy                x = x1   z = z1End SubSub RotZ(angle As ang, Byref x As Double, Byref y As Double) 'not used yet   Dim As Double x1 = x * angle.cz - y * angle.sz, _              y1 = x * angle.sz + y * angle.cz   x = x1   y = y1End SubFunction RandomRange(fStart As Single, fEnd As Single) As Single   Return Rnd() * (fEnd - fStart) + fStartEnd FunctionFunction CreateGradientSphere(cx As Single, cy As Single, radius As Ushort, lx As Single, ly As Single, zl As Single = 255) As Any Ptr   Dim As Any Ptr pImageG, imgDataG   Dim As Integer pitchG   pImageG = Imagecreate(radius Shl 1, radius Shl 1, 0, 32)   Imageinfo(pImageG, , , , pitchG, imgDataG)   #Define PixelSetG(_x, _y, colour)              *Cptr(Ulong Ptr, imgDataG + (_y) * pitchG + (_x) Shl 2) = (colour)   Dim As Single x, y, z, lightx, lighty, lightz, q_cos, light, c, c1 = _ASM_Cos6th(ly)   lightx = _ASM_Sin6th(lx) * c1   lighty = _ASM_Sin6th(ly)   lightz = _ASM_Cos6th(lx) * c1   For y = -radius To radius      q_cos = _ASM_Cos6th(-Asin(y / radius)) * radius      For x = -q_cos To q_cos         z = Sqr(radius * radius - x * x - y * y)         c = (x / radius * lightx + y / radius * lighty + z / radius * lightz)         light = Iif(c < 0, 0, c) * 255         PixelSetG(Cshort(x + cx), Cshort(y + cy), Rgba(0, 0, 0, Max(Min(255, zl - light), 0)))      Next   Next   Return pImageGEnd FunctionFunction _ASM_Sin6th(fX As Double) As Double    'By Eukalyptus    Asm      jmp 0f      1: .Double 683565275.57643158       2: .Double -0.0000000061763971109087229       3: .Double 6755399441055744.0               0:          movq xmm0, [fX]          mulsd xmm0, [1b]          addsd xmm0, [3b]          movd ebx, xmm0          lea  eax, [ebx*2+0x80000000]          sar  eax, 2          imul eax          sar  ebx, 31          lea  eax, [edx*2-0x70000000]          lea  ecx, [edx*8+edx-0x24000000]          imul edx          Xor  ecx, ebx          lea  eax, [edx*8+edx+0x44A00000]         imul ecx          cvtsi2sd xmm0, edx          mulsd xmm0, [2b]          movq [Function], xmm0    End Asm End FunctionFunction _ASM_Cos6th(fX As Double) As Double    'By Eukalyptus    Asm       jmp 0f       1: .Double 683565275.57643158       2: .Double -0.0000000061763971109087229       3: .Double 6755399441055744.0       0:          movq xmm0, [fX]          mulsd xmm0, [1b]          addsd xmm0, [3b]          movd ebx, xmm0          Add ebx, 0x40000000 'SinToCos          lea  eax, [ebx*2+0x80000000]          sar  eax, 2          imul eax          sar  ebx, 31          lea  eax, [edx*2-0x70000000]          lea  ecx, [edx*8+edx-0x24000000]          imul edx          Xor  ecx, ebx          lea  eax, [edx*8+edx+0x44A00000]          imul ecx          cvtsi2sd xmm0, edx          mulsd xmm0, [2b]          movq [Function], xmm0    End Asm End Function'https://www.codeproject.com/Articles/33838/Image-Processing-Using-CPrivate Function ResizeImage(pImage As Any Pointer, iW_new As Ushort, iH_new As Ushort) As Any Pointer   #Define GetPixelRI(_x, _y)          *Cptr(Ulong Ptr, imgData + _y * pitch + _x Shl 2)   #Define SetPixelRI(_x, _y, _color)  *Cptr(Ulong Ptr, imgData_Resized + _y * pitch_Resized + _x Shl 2) = (_color)   Dim pImage_Resized As Any Ptr = Imagecreate(iW_new, iH_new, 0, 32)   Dim As Integer w, h, wr, hr, pitch, pitch_Resized   Dim As Any Pointer imgData, imgData_Resized   Imageinfo(pImage, w, h, , pitch, imgData)   Imageinfo(pImage_Resized, wr, hr, , pitch_Resized, imgData_Resized)   Dim As Single fWidthFactor = w / wr, fHeightFactor = h / hr, fx, fy, nx, ny   Dim As Ulong cx, cy, fr_x, fr_y, color1, color2, color3, color4   Dim As Ubyte nRed, nGreen, nBlue, nAlpha, bp1, bp2   For x As Ushort = 0 To wr - 1      For y As Ushort = 0 To hr - 1         fr_x = Floor(x * fWidthFactor)         fr_y = Floor(y * fHeightFactor)         cx = fr_x + 1         If cx >= w Then cx = fr_x         cy = fr_y + 1         If cy >= h Then cy = fr_y         fx = x * fWidthFactor - fr_x         fy = y * fHeightFactor - fr_y         nx = 1.0 - fx         ny = 1.0 - fy         color1 = GetPixelRI(fr_x, fr_y)         color2 = GetPixelRI(cx, fr_y)         color3 = GetPixelRI(fr_x, cy)         color4 = GetPixelRI(cx, cy)         'red         bp1 = nx * Red(color1) + fx * Red(color2)         bp2 = nx * Red(color3) + fx * Red(color4)                  nRed = ny * bp1 + fy * bp2                  'green         bp1 = nx * Green(color1) + fx * Green(color2)         bp2 = nx * Green(color3) + fx * Green(color4)                  nGreen = ny * bp1 + fy * bp2         'blue         bp1 = nx * Blue(color1) + fx * Blue(color2)         bp2 = nx * Blue(color3) + fx * Blue(color4)         nBlue = ny * bp1 + fy * bp2         'Alpha         bp1 = nx * Alpha(color1) + fx * Alpha(color2)         bp2 = nx * Alpha(color3) + fx * Alpha(color4)                  nAlpha = ny * bp1 + fy * bp2         SetPixelRI(x, y, Rgba(nRed, nGreen, nBlue, nAlpha))      Next   Next   Return pImage_ResizedEnd Function`

To run the code properly you need the images which can be downloaded here: FB Rotating Earth build 2019-04-11.zip.

On my old notebook it runs best with -gen gcc -Wc -Ofast (x64) at ~68 fps.

Btw, it is not a realistic simulation. ^^
Last edited by UEZ on Apr 15, 2019 7:21, edited 9 times in total.
dodicat
Posts: 5937
Joined: Jan 10, 2006 20:30
Location: Scotland

### Re: Rotating Earth build 2019-04-08

Thanks UEZ.
Very nice.
If you don't mind, I have tweaked a bit to give shorter days (and nights)
I have left rotz alone, you do not use it.
Also I note there is no Mercator moon bitmap to spread out and see the far side, but I nit pick.

Code: Select all

`'Main code by UEZ'Image to sphere projection by andalmeida -> https://www.codeproject.com/Articles/19712/Mapping-Images-On-Spherical-Surfaces-Using-C'Image resize function by Saleth Prakash -> https://www.codeproject.com/Articles/33838/Image-Processing-Using-CType ang 'FLOATS for angles    As Single sx,sy,sz    As Single cx,cy,czEnd TypeFunction construct(x As Single,y As Single,z As Single) As Ang    Return   Type (Sin(x),Sin(y),Sin(z), _                   Cos(x),Cos(y),Cos(z))End FunctionDeclare Sub CreateGlobe(imageS As Any Ptr, imageD As Any Ptr, radius As Single, rx As Single, ry As Single, dx As Short, dy As Short, w As Ushort, h As Ushort)Declare Sub RotX(angle As ang, Byref y As Double, Byref z As Double)Declare Sub RotY(angle As ang, Byref x As Double, Byref z As Double)Declare Sub RotZ(angle As Single, Byref x As Double, Byref y As Double)Declare Sub AA2(x As Ushort, y As Ushort, w As Ushort, h As Ushort, iScale As Ubyte = 2)Declare Sub CreateSphere(imageS As Any Ptr, imageD As Any Ptr, w As Ushort, h As Ushort)Declare Function ResizeImage(pImage As Any Pointer, iW_new As Ushort, iH_new As Ushort) As Any PointerDeclare Function _ASM_Cos6th(fX As Double) As DoubleDeclare Function _ASM_Sin6th(fX As Double) As Double#Define PixelGet(_x, _y)                  *Cptr(Ulong Ptr, imgDataS + (_y) * pitch + (_x) Shl 2)#Define PixelGet2(_x, _y)                  *Cptr(Ulong Ptr, imgDataD + (_y) * pitch + (_x) Shl 2)#Define PixelGetM(_x, _y)                  *Cptr(Ulong Ptr, imgDataM + (_y) * pitchM + (_x) Shl 2)#Define PixelSet(_x, _y, colour)          *Cptr(Ulong Ptr, imgDataD + (_y) * pitch + (_x) Shl 2) = (colour)#Define PixelSetG(_x, _y, colour)          *Cptr(Ulong Ptr, imgDataG + (_y) * pitchG + (_x) Shl 2) = (colour)#Define PixelSetM(_x, _y, colour)          *Cptr(Ulong Ptr, imgDataM + (_y) * pitchM + (_x) Shl 2) = (colour)#Define Min(a, b)                      (Iif(a < b, a, b))#Define Max(a, b)                      (Iif(a > b, a, b))#Define MapCoordinate(i1, i2, w1, w2, p)    (((p - i1) / (i2 - i1)) * (w2 - w1) + w1)#Define Red(colors)                       ((colors Shr 16) And 255)#Define Green(colors)                     ((colors Shr 8) And 255)#Define Blue(colors)                      (colors And 255)#Define Alpha(colors)                      ((colors Shr 24) And 255)#Define Round(x)                      ((x + 0.5) Shr 0)#Define Floor(x)                      (((x) * 2.0 - 0.5) Shr 1)Const phi0 = 0.0, phi1 = Acos(-1), theta0 = 0.0, theta1 = 2.0 * Acos(-1), rad = Acos(-1) / 180, deg = 180 / Acos(-1)Const iW = 600, iH = 300, iW2 = iW \ 2, iH2 = iH \ 2, srotx = 1.5 * deg, r = 135, dm = 2 * rScreenres iW, iH, 32, 2Screenset 1, 0Windowtitle "FB Rotating Earth coded by UEZ build 2019-04-08"Dim Shared As Any Ptr pImageS, pImageD, pImageB, pImageG, pImageM, pImageMs, imgDataS, imgDataD, imgDataG, imgDataMpImageS = Imagecreate(iW, iH, 0, 32)pImageD = Imagecreate(iW, iH, 0, 32)pImageB = Imagecreate(iW, iH, 0, 32)pImageM = Imagecreate(200, 200, 0, 32)pImageG = Imagecreate(dm + 2, dm + 2, 0, 32)Bload("Earth4_600x300.bmp", pImageS)Bload("Galaxy_MilkyWay.bmp", pImageB)Bload("Moon_200x200.bmp", pImageM)Dim Shared As Integer pitch, pitchG, pitchMImageinfo(pImageS, , , , pitch, imgDataS) 'earth mapImageinfo(pImageD, , , , pitch, imgDataD) 'final image which will be drawn to screenImageinfo(pImageG, , , , pitchG, imgDataG) 'final image of transformation of earth mapImageinfo(pImageM, , , , pitchM, imgDataM) 'moon image'make moon transparentFor xx As Ushort = 0 To 199   For yy As Ushort = 0 To 199      If PixelGetM(xx, yy) = &hFFFF0000 Then PixelSetM(xx, yy, 0)   NextNext'blur moon to get rid of sharp edgesDim As Ulong resultAlpha, resultRed, resultGreen, resultBlue, col, iScale = 2, gridSize = iScale * iScaleFor iY As Ushort = 0 To 199   For iX As Ushort = 0 To 199      resultRed = 0: resultGreen = 0: resultBlue = 0: resultAlpha = 0      For xx As Ubyte = 0 To iScale - 1         For yy As Ubyte = 0 To iScale - 1            col = PixelGetM(iX + xx, iY + yy)            resultRed += Red(col)            resultGreen += Green(col)            resultBlue += Blue(col)            resultAlpha += Alpha(col)         Next      Next      PixelSetM(iX, iY, Rgba(resultRed / gridSize, resultGreen / gridSize, resultBlue / gridSize, resultAlpha / gridSize))   NextNext'create gradient ellipseDim As Single r2 = (r + 3) * (r + 3), X0 = r, Y0 = rDim As Long X, Y, D2Dim As Ulong iColFor y = -r To r   For x = -r To r      D2 = x * x + y * y      If D2 <= r2 Then                                       iCol = Max(0, 320 - Sqr(r2 - D2) * 3.5)         PixelSetG(Cushort(x + X0), Cushort(y + Y0), iCol Shl 24)      End If   Next Next Dim As Ushort iFPS = 0, iFPS_currentDim As Single fDeg = -2 * deg, z = 90, zz, fz, fs, fx, fy = 30Dim As Double fTimer2fTimer2 = TimerDo   Put pImageD, (0, 0), pImageB, Pset 'copy background (galaxy)      zz = z * rad   fx = iW2 - _ASM_Cos6th(zz) * iW2   z += 0.5   fz = _ASM_Sin6th(zz)   fS = 100 - fz * 50   pImageMs = ResizeImage(pImageM, fs, fs) 'resize moon      If fz > 0 Then 'moon is in the back of earth      Put pImageD, (fx - fs \ 2, fy), pImageMs, Alpha      CreateGlobe(pImageS, pImageD, r - 1, srotx, fDeg, iW2, iH2, iW, iH)         Put pImageD, (iW2 - r, iH2 - r), pImageG, Alpha   Else      CreateGlobe(pImageS, pImageD, r - 1, srotx, fDeg, iW2, iH2, iW, iH)      Put pImageD, (iW2 - r, iH2 - r), pImageG, Alpha      Put pImageD, (fx - fs \ 2, fy), pImageMs, Alpha   End If   fDeg -= 0.1      Put (0, 0), pImageD, Pset    Imagedestroy(pImageMs)      Draw String(8, 8), iFPS_current & " fps", Rgb(&hF0, &hF0, &hF0)   If Timer - fTimer2 > 0.99 Then      iFPS_current = iFPS      iFPS = 0      fTimer2 = Timer   End If   iFPS += 1      Flip   Sleep(1, 1)Loop Until Inkey = Chr(27) 'press ESC to exitImagedestroy(pImageS)Imagedestroy(pImageD)Imagedestroy(pImageB)Imagedestroy(pImageG)Imagedestroy(pImageM)Sub CreateGlobe(imageS As Any Ptr, imageD As Any Ptr, radius As Single, rx As Single, ry As Single, dx As Short, dy As Short, w As Ushort, h As Ushort)   Dim As Double theta, phi, px, py, pz, c1   Dim As Short posx, posy, iMin = Min(w, h), iMin2 = iMin * 0.33, c = 1 + (radius \ iMin) Shl 1   Dim As Ulong col   Dim As Single col2    dim as ang a=construct(rx*rad,ry*rad,0)       For y As Ushort = 0 To h - 1      For x As Ushort = 0 To w - 1         theta = MapCoordinate(0, w - 1, theta1, theta0, x)         phi = MapCoordinate(0, h - 1, phi0, phi1, y)         c1 = radius * _ASM_Sin6th(phi)         px = c1 * _ASM_Cos6th(theta)         py = c1 * _ASM_Sin6th(theta)         pz = radius * _ASM_Cos6th(phi)         RotX(a, py, pz)'rx         RotY(a, px, pz)'ry         If pz > 0 Then            posx = (px + dx)            posy = (py + dy)            If posx >= 0 And posx < w And posy >= 0 And posy < h Then                col = PixelGet(x, y)                If radius < iMin2 Then                  PixelSet(posx, posy, col)               Else                  'Line pImageD, (posx, posy) - (posx + c, posy + c), col, BF 'too slow                  For yy As Ushort = posy To posy + c                     For xx As Ushort = posx To posx + c                        If xx < w And yy < h Then PixelSet(xx, yy, col)                     Next                  Next                  'PixelSet(posx, posy, col)               End If            End If         End If      Next   Next   End SubSub RotX(angle As ang, Byref y As Double, Byref z As Double)   'Dim As Single y1 = y * Cos(angle) - z * Sin(angle), _              'z1 = y * Sin(angle) + z * Cos(angle)                  Dim As Single y1 = y *angle.cx - z * angle.sx, _              z1 = y * angle.sx + z * angle.cx   y = y1   z = z1End SubSub RotY(angle As ang, Byref x As Double, Byref z As Double)   'Dim As Single x1 = x * Cos(angle) - z * Sin(angle), _              'z1 = x * Sin(angle) + z * Cos(angle)                       Dim As Single x1 = x * angle.cy - z * angle.sy, _              z1 = x * angle.sy + z * angle.cy                x = x1   z = z1End SubSub RotZ(angle As Single, Byref x As Double, Byref y As Double)   Dim As Single x1 = x * Cos(angle) - y * Sin(angle), _              y1 = x * Sin(angle) + y * Cos(angle)   x = x1   y = y1End SubFunction _ASM_Sin6th(fX As Double) As Double    'By Eukalyptus    Asm      jmp 0f      1: .Double 683565275.57643158       2: .Double -0.0000000061763971109087229       3: .Double 6755399441055744.0                 0:          movq xmm0, [fX]          mulsd xmm0, [1b]          addsd xmm0, [3b]          movd ebx, xmm0          lea  eax, [ebx*2+0x80000000]          sar  eax, 2          imul eax          sar  ebx, 31          lea  eax, [edx*2-0x70000000]          lea  ecx, [edx*8+edx-0x24000000]          imul edx          Xor  ecx, ebx          lea  eax, [edx*8+edx+0x44A00000]         imul ecx          cvtsi2sd xmm0, edx          mulsd xmm0, [2b]          movq [Function], xmm0    End Asm End FunctionFunction _ASM_Cos6th(fX As Double) As Double    'By Eukalyptus    Asm       jmp 0f          1: .Double 683565275.57643158          2: .Double -0.0000000061763971109087229          3: .Double 6755399441055744.0              0:          movq xmm0, [fX]          mulsd xmm0, [1b]          addsd xmm0, [3b]          movd ebx, xmm0                    Add ebx, 0x40000000 'SinToCos              lea  eax, [ebx*2+0x80000000]          sar  eax, 2          imul eax          sar  ebx, 31          lea  eax, [edx*2-0x70000000]          lea  ecx, [edx*8+edx-0x24000000]          imul edx          Xor  ecx, ebx          lea  eax, [edx*8+edx+0x44A00000]          imul ecx                    cvtsi2sd xmm0, edx          mulsd xmm0, [2b]          movq [Function], xmm0    End Asm End Function'https://www.codeproject.com/Articles/33838/Image-Processing-Using-CPrivate Function ResizeImage(pImage As Any Pointer, iW_new As Ushort, iH_new As Ushort) As Any Pointer   #Define GetPixelRI(_x, _y)          *Cptr(Ulong Ptr, imgData + _y * pitch + _x Shl 2)   #Define SetPixelRI(_x, _y, _color)  *Cptr(Ulong Ptr, imgData_Resized + _y * pitch_Resized + _x Shl 2) = (_color)   Dim pImage_Resized As Any Ptr = Imagecreate(iW_new, iH_new, 0, 32)   Dim As Integer w, h, wr, hr, pitch, pitch_Resized   Dim As Any Pointer imgData, imgData_Resized   Imageinfo(pImage, w, h, , pitch, imgData)   Imageinfo(pImage_Resized, wr, hr, , pitch_Resized, imgData_Resized)   Dim As Single fWidthFactor = w / wr, fHeightFactor = h / hr, fx, fy, nx, ny   Dim As Ulong cx, cy, fr_x, fr_y, color1, color2, color3, color4   Dim As Ubyte nRed, nGreen, nBlue, nAlpha, bp1, bp2   For x As Ushort = 0 To wr - 1      For y As Ushort = 0 To hr - 1         fr_x = Floor(x * fWidthFactor)         fr_y = Floor(y * fHeightFactor)         cx = fr_x + 1         If cx >= w Then cx = fr_x         cy = fr_y + 1         If cy >= h Then cy = fr_y         fx = x * fWidthFactor - fr_x         fy = y * fHeightFactor - fr_y         nx = 1.0 - fx         ny = 1.0 - fy         color1 = GetPixelRI(fr_x, fr_y)         color2 = GetPixelRI(cx, fr_y)         color3 = GetPixelRI(fr_x, cy)         color4 = GetPixelRI(cx, cy)         'red         bp1 = nx * Red(color1) + fx * Red(color2)         bp2 = nx * Red(color3) + fx * Red(color4)                  nRed = ny * bp1 + fy * bp2                  'green         bp1 = nx * Green(color1) + fx * Green(color2)         bp2 = nx * Green(color3) + fx * Green(color4)                  nGreen = ny * bp1 + fy * bp2         'blue         bp1 = nx * Blue(color1) + fx * Blue(color2)         bp2 = nx * Blue(color3) + fx * Blue(color4)         nBlue = ny * bp1 + fy * bp2         'Alpha         bp1 = nx * Alpha(color1) + fx * Alpha(color2)         bp2 = nx * Alpha(color3) + fx * Alpha(color4)                  nAlpha = ny * bp1 + fy * bp2         SetPixelRI(x, y, Rgba(nRed, nGreen, nBlue, nAlpha))      Next   Next   Return pImage_ResizedEnd Function `
UEZ
Posts: 336
Joined: May 05, 2017 19:59
Location: Germany

### Re: Rotating Earth build 2019-04-08

Thanks for your feedback dodicat. :-)

No, I don't mind of course and I also wanted to ask how to tweak the code that it runs faster. That's a nice idea to use the construct which give a great performance boost to fps - now at ~ 77 fps (doubled+). I need to analyse and check it to understand the idea of that coding technique.

I will update the code soon.

Now I can add some more elements...
Last edited by UEZ on Apr 08, 2019 20:34, edited 1 time in total.
Tourist Trap
Posts: 2762
Joined: Jun 02, 2015 16:24

### Re: Rotating Earth build 2019-04-08

dodicat wrote:Thanks UEZ.
Very nice.
If you don't mind, I have tweaked a bit to give shorter days (and nights)

Hi all,

@dodicat, your snippet doesn't use GDI+ it seems? If so, I'll try to learn from it because I was looking for a planet for my game !
UEZ
Posts: 336
Joined: May 05, 2017 19:59
Location: Germany

### Re: Rotating Earth build 2019-04-08

Tourist Trap wrote:
dodicat wrote:Thanks UEZ.
Very nice.
If you don't mind, I have tweaked a bit to give shorter days (and nights)

Hi all,

@dodicat, your snippet doesn't use GDI+ it seems? If so, I'll try to learn from it because I was looking for a planet for my game !

Neither the code I posted nor the tweaked version from dodicat uses GDI+. I only mentioned that my previous version was based on GDI+.
Tourist Trap
Posts: 2762
Joined: Jun 02, 2015 16:24

### Re: Rotating Earth build 2019-04-08

UEZ wrote:Neither the code I posted nor the tweaked version from dodicat uses GDI+. I only mentioned that my previous version was based on GDI+.

Hi UEZ,

thanks, my fear was to use a system specific tool for a game I would I would rather keep portable. Otherwise, I like learning gdi+, it's very useful on windows and I think it should be used for professional projects.
UEZ
Posts: 336
Joined: May 05, 2017 19:59
Location: Germany

### Re: Rotating Earth build 2019-04-11

Little update on 2019-04-11: