aurel
Full Member
Posts: 234
|
Post by aurel on Sept 2, 2023 16:27:04 GMT -5
by the way ron..nice try to get earth rotation but i don't see any sphere '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 Double
Declare Function _ASM_Sin6th(fX As Double) As Double
Type Ang 'FLOATS For angles
As Double sx,sy,sz
As Double cx,cy,cz
End Type
Function 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 Function
Declare 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 Pointer
Declare Function RandomRange(fStart As Single, fEnd As Single) As Single
Declare Function CreateGradientSphere(cx As Single, cy As Single, radius As Ushort, lx As Single, ly As Single, zl As Single = 255) As Any Ptr
Declare Function Ecliptic(iDayOfYear As Ushort) As Double
Declare 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) / 2
Const iWe = 600, iHe = 300, iW2e = iWe \ 2, iH2e = iHe \ 2
Dim As Double fEclipticAngle = Ecliptic(Int(Now() - DateSerial(Year(Now()),1,1)))
'needed for Sub CreateGlobe
Const iMin = Min(iWe, iHe), iMin2 = iMin * 0.33, deltac = 1 + (r \ iMin) Shl 1
Screenres iW, iH, 32, 2
Screenset 1, 0
Windowtitle "FB Rotating Earth coded by UEZ build 2019-04-14"
Dim Shared As Any Ptr pImageS, pImageD, pImageB, pImageG, pImageGM, pImageM, pImageMs, imgDataS, imgDataD, imgDataM
pImageS = 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 long pitch, pitchS, pitchG, pitchM
Imageinfo(pImageS, , , , pitchS, imgDataS) 'earth map
Imageinfo(pImageD, , , , pitch, imgDataD) 'final image which will be drawn To Screen
Imageinfo(pImageM, , , , pitchM, imgDataM) 'moon image
'make moon transparent
For xx As Ushort = 0 To 199
For yy As Ushort = 0 To 199
If PixelGetM(xx, yy) = &hFFFF0000 Then PixelSetM(xx, yy, 0)
Next
Next
'blur moon To Get rid of sharp edges
Dim As Ulong resultAlpha, resultRed, resultGreen, resultBlue, col, iScale = 2, gridSize = iScale * iScale
For 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))
Next
Next
pImageG = 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.2
Type tComet
As Single x, y, vx, vy, len
End Type
Dim As tComet Comet
Dim As Short iLife = 255
Dim As Byte iDir = 1
Randomize , 2
Comet.x = RandomRange(-1, 1)
If Comet.x < 0 Then
Comet.x = 0
Else
Comet.x = iW
iDir *= -1
End If
Comet.y = 10 + Rnd() * (iH - 20)
Comet.vx = RandomRange(1, 10) * iDir
Comet.vy = RandomRange(1, 10) * iDir
Comet.len = RandomRange(5, 10) * iDir
Dim As Ushort iFPS = 0, iFPS_current
Dim As Single pdx, pdy, dt = 5 + Rnd() * 5
Dim As Double fTimer1, fTimer2
fTimer1 = Timer
fTimer2 = Timer
Do
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), 1
Loop Until Inkey = Chr(27) 'press ESC To exit
Imagedestroy(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 sleeptime
End Function
'Obliquity of the ecliptic, only an approximation -> see https://en.wikipedia.org/wiki/Axial_tilt#Earth
Function Ecliptic(iDayOfYear As Ushort) As Double 'iDayOfYear -> 1 to 365
Return -Cos((iDayOfYear - 1) * 2 * ACos(-1) / 365.25 + 0.205) * 23.44
End Function
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)
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 Sub
Sub 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 = z1
End Sub
Sub 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 = z1
End Sub
Sub 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 = y1
End Sub
Function RandomRange(fStart As Single, fEnd As Single) As Single
Return Rnd() * (fEnd - fStart) + fStart
End Function
Function 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 long 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 pImageG
End Function
Function _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 Function
Function _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-C
Private 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_Resized
End Function
|
|
