## Around the Sphere build 2020-09-22

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

### Around the Sphere build 2020-09-22

A 3D visualization of moving a text around a sphere.

Thanks to dodicat for some functions which I've used. ^^

Code: Select all

'Coded by UEZ build 2020-09-22
'Thanks to dodicat for some funtions I used from his code :-) and Martijn van Iersel for the CreateGradientSphere function. ^^

#include "file.bi"
#Include "fbgfx.bi"
Using FB

Declare Function LZW_Decode Alias "fb_hDecode" (Byval in_buffer As Any Ptr, Byval in_size As Integer, Byval out_buffer As Any Ptr, Byref out_size As Integer) As Integer

#Define Map(Val, source_start, source_stop, dest_start, dest_stop)   ((Val - source_start) * (dest_stop - dest_start) / (source_stop - source_start) + dest_start)
#Define Round(x)                                              ((x + 0.5) Shr 0)

Const w = 1200, h = 800, w2w = w Shl 1, w2 = w \ 2, h2 = h \ 2, pi = Acos(-1), pi2 = Acos(-1) / 2, radius = 350
Const phi0 = 0.0, phi1 = pi, theta0 = 0.0, theta1 = 2.0 * pi, radians = pi / 180, deg = 180 / pi, cc1 = -270 * radians, cc2 = 1025 * radians

Union _Color
As Ulong argb
Type
As Ubyte b, g, r, a
End Type
End Union

Type vec3
As Single x, y, z
End Type

Dim Shared As Const vec3 eyepoint = Type(w2, h2, h)

Type vec5
As Single x, y, z
As _Color col
End Type

'Taylor series
'Sum n = 0 to inf (-1)^n * x^(2n) / (2n)! = 1 - x^2 / 2! + x^4 / 4! -x^6 / 6! + ...
Function Cos_(x As Single) As Single
If x < 0 Then x = -x
While x >= 3.141592653589793 'pi
x -= 6.283185307179586 '2 * pi
Wend
Dim As Single xx = x * x
Return 1.0 - (xx / 2) * (1 - (xx / 12) * (1 - (xx / 30) * (1 - xx / 56))) 'approximation of Taylor serie
End Function

Function Sin_(x As Single) As Single
Return Cos_(x - 1.570796326794897) 'pi / 2
End Function

Sub Object3Dto2D(wa() As vec5, result() As vec5, angle As vec3, centre As vec3, rad As Single = 1.0, flag As Boolean = True) 'by dodicat
Dim As Single dx,dy,dz,ww
Dim As Single SinAX=Sin_(angle.x)
Dim As Single SinAY=Sin_(angle.y)
Dim As Single SinAZ=Sin_(angle.z)
Dim As Single CosAX=Cos_(angle.x)
Dim As Single CosAY=Cos_(angle.y)
Dim As Single CosAZ=Cos_(angle.z)

For z As Uinteger=Lbound(wa) To Ubound(wa)
dx=wa(z).x-centre.x
dy=wa(z).y-centre.y
dz=wa(z).z-centre.z

If flag Then
ww = 1 + (result(z).z/eyepoint.z)
result(z).x = (result(z).x-eyepoint.x)/ww+eyepoint.x
result(z).y = (result(z).y-eyepoint.y)/ww+eyepoint.y
result(z).z = (result(z).z-eyepoint.z)/ww+eyepoint.z
Endif
result(z).col=wa(z).col
Next z
result(Ubound(wa)).z = -radius 'center sphere, which is the last entry, always in the middle
End Sub

Sub QsortZ(array() As vec5, begin As Integer, Finish As Uinteger) 'by dodicat
Dim As Integer i = begin, j = finish
Dim As vec5 X = array(((I + J) \ 2))
While I <= J
While array(I).z > X .z : I += 1 : Wend
While array(J).z < X .z : J -= 1 : Wend
If I <= J Then Swap array(I), array(J) : I += 1 : J -= 1
Wend
If J > begin Then QsortZ(array(), begin, J)
If I < Finish Then QsortZ(array(), I, Finish)
End Sub

'CreateGradientSphere function by Martijn van Iersel -> http://www.helixsoft.nl/articles/sphere/sphere.html
Function CreateGradientSphere(centerX As Single, centerY As Single, r As Single, longitude As Single, latitude As Single) As Any Ptr
Dim As Any Ptr pImage, imgData
Dim As Integer pitch, iw, ih
pImage = Imagecreate(r Shl 1, r Shl 1, 0, 32)
Imageinfo(pImage, iw, ih, , pitch, imgData)
Dim As Single x, y, z, lightx, lighty, lightz, q_cos, light, c, lati1, lati2, longi1, longi2
lati1 = Cos_(latitude)
lati2 = Sin_(latitude)
longi1 = Cos_(longitude)
longi2 = Sin_(longitude)

'calculate the light vector
lightx = longi2 * lati1
lighty = Sin_(latitude)
lightz = longi1 * lati1

For y = -r To r
q_cos = Cos_(-Asin(y / r)) * r
For x = -q_cos + 1 To q_cos - 1
z = Sqr(r * r - x * x - y * y)
c = (x / r * lightx + y / r * lighty + z / r * lightz)
light = Iif(c < 0, 0, c) * 255
Pset pImage, (x + centerX, y + centerY), Rgba(light / 6, light / 4, light, 255 - light)
Next
Next

Return pImage
End Function

Function Base128Decode(sString As String, Byref iBase128Len as UInteger) As Ubyte Ptr
If sString = "" Then
Error 1
Return 0
EndIf
Dim As String sB128, sDecoded
Dim i As UInteger
Dim aChr(0 To Len(sString)) As String
For i = 0 To UBound(aChr)
aChr(i) = Mid(sString, i + 1, 1)
Next
Dim As Long r, rs = 8, ls = 7, nc, r1

For i = 0 To UBound(aChr) - 1
nc = InStr(sB128, aChr(i)) - 1
If rs > 7 Then
rs = 1
ls = 7
r = nc
Continue For
EndIf
r1 = nc
nc = ((nc Shl ls) And &hFF) or r
r = r1 Shr rs
rs += 1
ls -= 1
sDecoded &= Chr(nc)
Next
iBase128Len = Len(sDecoded)

'workaround For multiple embedded file other crash will occure
Static As Ubyte aReturn(0 To iBase128Len - 1)
Redim aReturn(0 To iBase128Len - 1) As Ubyte

For i = 0 to Len(sDecoded) - 1 'convert result string to ascii code values
aReturn(i) = Asc(sDecoded, i + 1)
Next
Return @aReturn(0) 'return pointer to the array
End Function

Screenres w, h, 32, 2, GFX_WINDOWED Or GFX_NO_SWITCH Or GFX_ALWAYS_ON_TOP Or GFX_ALPHA_PRIMITIVES
ScreenSet 1, 0

#Define PixelGet(_x, _y)                      *Cptr(Ulong Ptr, imgDataTxt + (_y) * pitchTxt + (_x) Shl 2)

Dim as string sFile = CurDir & "/Text_500x39.bmp"
If FileExists(sFile) = 0 Then
Dim As UInteger iLines, iCompression, iFileSize, iCompressedSize
Dim As String sBaseType, sBase128, aB128(1)
Restore __Label0:

For i As Ushort = 0 To iLines - 1
sBase128 &= aB128(0)
Next
Dim As UInteger l
Dim As Ubyte Ptr aBinary = Base128Decode(sBase128, l)

Dim As Boolean bError = False
If iCompression Then
If iCompressedSize <> l Then bError = TRUE
Else
If iFileSize <> l Then bError = TRUE
Endif
If bError <> False Then
'? "Something went wrong"
'Sleep
End -1
End If

Dim As Integer hFile
hFile = Freefile()
Open sFile For Binary Access Write As #hFile
If iCompression Then
Dim As Ubyte Ptr aBinaryC = Allocate(iFileSize)
LZW_Decode(aBinary, iCompressedSize, aBinaryC, iFileSize)
Put #hFile, 0, aBinaryC[0], iFileSize
Deallocate(aBinaryC)
Else
Put #hFile, 0, aBinary[0], iFileSize
Endif
Close #hFile
aBinary = 0
Else
end if

Dim As Integer pitchTxt, iw, ih
Imageinfo(pImageTxt, iw, ih, , pitchTxt, imgDataTxt)

Dim As Uinteger particles = 10000, i, ub
Dim As Single x, y, theta, rho, phi, f1, f2, ang, z1, z2, px, py, pz, c1, zoom = 1.0
Dim As Ulong iCol, iCounter = 0
Dim As vec5 aParticles(particles - 1), aResult(particles - 1)
Dim As Boolean b1 = False, b2 = False

Dim As Single dimx = 0, dimy = 0

For xx As Short = 0 To iw - 1
For yy As Short = 0 To ih - 1
If PixelGet(xx, yy) <> &hFF000000 Then
If xx > dimx Then dimx = xx
If yy > dimy Then dimy = yy
End If
Next
Next

'Map string to sphere form
For xx As Short = dimx To 0 Step -1
theta = Map(-cc2 + xx / 4, 0, dimx, theta0, theta1)
For yy As Short = dimy To 0 Step -1
iCol = PixelGet(xx, yy)
If iCol <> &hFF000000 Then
phi = Map(cc2 + yy / 16, 0, dimy, phi0, phi1)
px = c1 * Cos_(theta)
py = c1 * Sin_(theta)
aParticles(iCounter).x = w2 + px
aParticles(iCounter).y = h2 + py
aParticles(iCounter).z = pz
aParticles(iCounter).col.argb = iCol
iCounter += 1
End If
Next
Next

'blue sphere coordinate
aParticles(iCounter).col.argb = 0

Redim Preserve aParticles(iCounter)
Redim Preserve aResult(iCounter)
ub = Ubound(aParticles)

Dim As String sWintitle = "Around the Sphere coded by UEZ"
Windowtitle(sWintitle & " / " & Str(ub) & " Pixel")

Imagedestroy(pImageTxt)

Dim As Ulong iFPS
Dim As Uinteger cfps = 0, s = 4
Dim As Single fTimer = Timer

Do
Line (0, 0) - (w, h * 0.75), &hFF404040, BF
Line (0, h * 0.75 + 1) - (w, h), &hFF808080, BF

ang += .0033
Object3Dto2D(aParticles(), aResult(), Type<vec3>(cc1, 2 * ang, 0), Type<vec3>(w2, h2, 0), zoom)
Qsortz(aResult(), 0, ub)

For i = 0 To ub
If aResult(i).col.argb <> 0 Then aResult(i).col.a = Map(aResult(i).z, -2500, 600, &hF0, &h02)
Line (aResult(i).x, aResult(i).y) - (aResult(i).x + s, aResult(i).y + s), aResult(i).col.argb, BF
'      aResult(i).col.a \= 2
'      aResult(i).col.r \= 1
'      aResult(i).col.g \= 1
'      aResult(i).col.b \= 1
'      Line (aResult(i).x, aResult(i).y) - (aResult(i).x + s, aResult(i).y + s), aResult(i).col.argb, B
'Pset (aResult(i).x, aResult(i).y), aResult(i).col.argb
'If aParticles(iCounter).col.r < &hC0 Andalso aParticles(iCounter).col.g < &hC0 Andalso aParticles(iCounter).col.b < &hC0 Then
'   Circle (aResult(i).x, aResult(i).y), 2.5, aResult(i).col.argb, , , , F
'Else
'   Circle (aResult(i).x, aResult(i).y), 5, aResult(i).col.argb, , , , F
'End If
'      If aResult(i).z < -radius Then Circle (aResult(i).x, aResult(i).y), s, Rgba(&h20, &h20, &h20, Map(aResult(i).z, -2500, -radius, &hF0, &h20))
If aResult(i).col.argb = 0 Then Put (w2 - radius, h2 - radius), pImageSphere, Alpha
Next

Draw String(1, 1), iFPS & " fps", Rgb(&hFF, &hFF, &hFF)

Flip
cfps += 1
If Timer - fTimer > 0.99 Then
iFPS = cfps
cfps = 0
fTimer = Timer
End If
Sleep(1)
Loop Until Len(Inkey())

Imagedestroy(pImageSphere)

'Code below was generated by: FB File2Bas Code Generator v1.05 build 2020-08-08 beta

'Text_500x39.bmp
__Label0:
Data 24,8,20578,10151,"Base128"
Data "nJ:7*J#!lJ;.b!#J7|l\$mH(!(±0R7D((|J7.V!:J7Pl)¿L³.(LoB8hp!!N!!\$¯t!!*!:#!7!S\$!R!¦(!¯!h0!¯#7:!!(|P!!0!z!!;lG#!V!j\$!¯!\$)!|#71!l%d;!l,JS!!7J¡!!L!R#!t!¡\$!B#V)!l\$³1!J)¯=!!2¿U!!Al¦!!Zl]#!³!·\$!|#¤)!Z%d2!!,.A!l5lX!!H¯«!!j!i#!!#Ì\$!.\$!*!J(33!¯.ZB!!97[!!O!²!!xls#!F#9%!l\$T*!7)¯3!l1¦C!l=¯^!!VJ·!!¨!~#!d#Q%!Ç\$¢*!!*_4!J3!E!!CZb!!^l¼!!·lª#!¢#h%!Z%Í*!¿*.5!!5RF!lF!e!!f¯Á!!Å!¶#!¿#}%!·%R,!¯,ª5!¯6|G!!J|g!!m!Ç!!(mÀ#!3\$µ%!J(~,!|.Z6!l8ÇH!lMJj!!tJÌ!!9#Ë#!R\$Ê%!¦(Ë,!l0(7!J:JJ!!Q¿l!!{l\$#!Jm*\$!p\$7(!7)P.!Z1¦7!!=tK!lTlo!!¤¯,#!X#8\$!¯\$"
Data "Mt#R)joÈZ7hKÀRH~sD}p7\$C%G±H1t(~m_.=!¢lcJ6;\$1l7[N4011%V%Î¯B;#5SO]uX~6¢!t\$«#i·.@9x(;§NBlU¿6toQJ!(OSuT¨s.!PZE¢,6K)¦vµ~i;!·\$»mkl1P!¨pAÄO¦.#t(_%¦N@ÈOq0CÉ!ÁnÎJH¦.iS2t%Nl9p!3#Vl\$|:¤!@¯!BK)¯)¦\$ÁlH|*¦!%!.±!xlE|*B#§SxZ\$d!¢NTV#E\$,±!·l3l%)!5J1d%µ!9!\$.!%!).#!~7;!p!VJ)7zh(#!%x#;Jg±mJlBl(;!Ft!d#·lº°,d#4!39!@l4l)ÇPX!lÁ8f}¼|:°!GJ3t%Ç!Cl\$(R¹0aÁm\$l5Z*ª!4Tmd!r!G¿f»#KJf\$8¢!CJ3=K%J)7%XsH¯)l!X¹.T!j!G|,ª#Slt1¡Dl:|*¿#gJ0d!l|%|(¢#c!1Z|\$!.¿\$ÇJ,l0¦%X,G¿%tRH.qÁ\$½lA!(³.,¯)|!@=5(#_Q)!*!¥ª!4ZU#Kg!j7u(==Ã!!#]!5Ç\$hl)!Y8.%¯)7%~£2£]«R"
Data "n1)t1n·X¯!Ã%ÊmiÇ,tÀ6#,h,90FH8h!}lIR,h:mt#nnÊ¯«HKt!c7½L#»ºMR!bmkÇ47Z6¢\$ª)Î#cÇf¶.#E(£!1mj|4LmO´#¦(_Ã9¿B!oÎ¯E³#Gt,.7ÀYÍ¦p@^O°t´(¤!¸¯IF¯G·%¿.|F´0·°\$»°\$*ÄÉ\$1Q4Ê._JTW4ÇlnlH·,8#{a²bnÎ¯F¯#J·!R(DX°¯)V!\$Kh¿5~#5g\$N(Âmel*@!S!Fª,3#qÄ8d½ÎJ:|#k#k75N#ohL!±i¿,n!ÃmÎÅ9¢gSR!!17Ea¯,ÊJx¯b^.;»\$K0ls6°#dQÎ%I|%0!®¯]¡(µq¸¿I3,t¯.±)¬µÌ§%G#f#jZ1fl7Ã7¿,ÃÇ,D)ÍG¥!%;.cJl_3r³E79)*k_.n!t_Ë¯:VgU\$=·5Ço¤!6°!IKO5iy7,J7l,¥bUËm(l_!b1(Q!)¿!Dl)7#F!)JvZ\$zo²DZ8®%b¬¹#Z!4|8lnr¯~D!9\$xd2l5}°kJ3pÁ0K!d*ÌmY¤k¼«xZ³¨\$h¯b·69ois%u!A°kd4JV8¢!hµ}em¦#Å\$Í¿C_#"
Data "\$KªºÉa|Î6l"

Please use ISO-8859-1 or try UTF-8 format in the code editor otherwise base128 decode will probably fail.

2020-09-17: added blurry pixels and fixed issue with depth of sphere (text flew partly thru the sphere on the right side)
2020-09-22: changed from system font to bitmap for cooler look
Last edited by UEZ on Sep 23, 2020 6:51, edited 7 times in total.
dafhi
Posts: 1357
Joined: Jun 04, 2005 9:51

### Re: Around the Sphere build 2020-09-15

we like dots

Code: Select all

'Coded by UEZ build 2020-09-15
'Thanks to dodicat for some funtions I used from his code :-) and Martijn van Iersel for the CreateGradientSphere function. ^^

/' --  modified by dafhi (2020 Sep 16)

vec5 -> dotvars
col.argb -> col

after  screenres ..  windowtitle ..  particles
you can adjust:  focal length, iris, iris z

'/

type imagevars '2017 Oct 10 - by dafhi
as integer            w,h,bpp,bypp,pitch,rate,  wm, hm, pitchBy 'helpers
as any ptr            im, pixels
as ulong ptr          p32
as string             driver_name
declare sub           get_info(im as any ptr=0)
declare               destructor
as single             midx, midy, diagonal '2017 Oct 10
end type

Destructor.imagevars
If ImageInfo(im) = 0 Then ImageDestroy im:  im=0
End Destructor

sub imagevars.get_info(im as any ptr)
if im=0 then
ScreenInfo w,h, bpp, bypp, pitch, rate, driver_name
pixels=screenptr
elseif Imageinfo(im)=0 then
ImageInfo im, w, h, bypp, pitch, pixels
this.im = im:  bpp = bypp * 8
endif: wm=w-1: hm=h-1:  pitchBy=pitch\bypp:  p32=pixels
midx=w/2: midy=h/2:  diagonal = sqr(w*w+h*h)
end sub

#Macro Alpha256(ret,back, fore, a256) '2017 Mar 26
ret=((_
(fore And &Hff00ff) * a256 + _
(back And &Hff00ff) * (256-a256) + &H800080) And &Hff00ff00 Or (_
(fore And &H00ff00) * a256 + _
(back And &H00ff00) * (256-a256) + &H008000) And &H00ff0000) Shr 8
#EndMacro

#define flr(x)        (((x)*2.0-0.5)shr 1)

type DotVars          '2017 Nov 15 - by dafhi
union
Type:  As UByte   b,g,r,a
End Type
As ULong          col
end union
as single           x,y,z
as single           rad = 1, slope = 2
as boolean          flag
End Type

type tView3D
as single           iris
as single           iris_z '' point z tweak prior to calling defocus_draw
End Type

namespace AaDot            '2020 Sep 17 - by dafhi

dim as tView3D        vie
dim as dotvars ptr    p
dim as imagevars ptr  im

sub render_target(byref buf as imagevars ptr):  im = buf
end sub

#define sng as single

dim sng               dy,dxLeft,salpha,cone_h,coneSq,sq,salpha0,slope
dim as long           x0,y0,x1,y1,alph,alpha_max

sub draw(x as single, y as single, col as ulong)

dim as long y0=(y-p->rad):  if y0<0 then y0=0
dim as long y1=(y+p->rad):  if y1>im->hm then y1=im->hm

if y1<y0 then exit sub '2017 Nov 10

salpha0=(col shr 24)/255:  alpha_max=salpha0*256
slope = p->slope

'' slope = 1 .. 1 pixel aa edge
'' slope = 2 .. 1/2 pixel (sharp)
'' slope = 1/p->rad .. max blur
'' slope < 1/p->rad .. rendering artifact

'slope=iif(slope<sq,sq,slope)  ''

coneSq=cone_h*cone_h    'avoid sqr() at blit corners
sq=(cone_h-1)*(cone_h-1)'avoid sqr() in dot center at max brightness
dim as long x0=(x-p->rad):  if x0<0 then x0=0
dim as long x1=(x+p->rad):  if x1>im->wm then x1=im->wm

dy=(y0-y)*slope: dxLeft=(x0-x)*slope
for py as long ptr = @im->p32[ y0*im->pitchBy ] to @im->p32[ y1*im->pitchBy ] step im->pitchBy
dim as single dx=dxleft, dySq=dy*dy
for px as ulong ptr = @py[x0] to @py[x1]
salpha = dx*dx+dySq
if salpha<sq then
Alpha256(*px,*px,col,alpha_max)
elseif salpha<=coneSq then
alph=(cone_h-sqr(salpha))*alpha_max
Alpha256(*px,*px,col,alph)
endif:  dx+=slope
next: dy+=slope
next

end sub

dim sng               r_expan
dim as dotvars        q

sub defocus_draw(byref pdv as dotvars ptr)
p = @q '' result -> q

with *pdv
r_expan = vie.iris * abs(.z)
q.col = .col
draw .x, .y, q.col
End With

End Sub

end namespace
'
' --------------------------------

#Include "fbgfx.bi"
Using FB

#Define Map(Val, source_start, source_stop, dest_start, dest_stop)   ((Val - source_start) * (dest_stop - dest_start) / (source_stop - source_start) + dest_start)
#Define Max(a, b)   (Iif(a > b, a, b))

Const w = 1200, h = 800, w2w = w Shl 1, w2 = w \ 2, h2 = h \ 2, pi = Acos(-1), pi2 = Acos(-1) / 2, radius = 350
Const phi0 = 0.0, phi1 = pi, theta0 = 0.0, theta1 = 2.0 * pi, radians = pi / 180, deg = 180 / pi, cc1 = -270 * radians

/'
Union _Color
As Ulong argb
Type
As Ubyte b, g, r, a
End Type
End Union
'/

Type vec3
As Single x, y, z
End Type

Dim Shared As Const vec3 eyepoint = Type(w2, h2, h)

/'
Type vec5
As Boolean flag
As Single x, y, z
As _Color col
End Type
'/

'Taylor series
'Sum n = 0 to inf (-1)^n * x^(2n) / (2n)! = 1 - x^2 / 2! + x^4 / 4! -x^6 / 6! + ...
Function Cos_(x As Single) As Single
If x < 0 Then x = -x
While x >= 3.141592653589793 'pi
x -= 6.283185307179586 '2 * pi
Wend
Dim As Single xx = x * x
Return 1.0 - (xx / 2) * (1 - (xx / 12) * (1 - (xx / 30) * (1 - xx / 56))) 'approximation of Taylor serie
End Function

Function Sin_(x As Single) As Single
Return Cos_(x - 1.570796326794897) 'pi / 2
End Function

Sub Object3Dto2D(wa() As dotvars, result() As dotvars, angle As vec3, centre As vec3, rad As Single = 1.0, flag As Boolean = True) 'by dodicat
Dim As Single dx,dy,dz,ww
Dim As Single SinAX=Sin_(angle.x)
Dim As Single SinAY=Sin_(angle.y)
Dim As Single SinAZ=Sin_(angle.z)
Dim As Single CosAX=Cos_(angle.x)
Dim As Single CosAY=Cos_(angle.y)
Dim As Single CosAZ=Cos_(angle.z)

For z As Uinteger=Lbound(wa) To Ubound(wa)
dx=wa(z).x-centre.x
dy=wa(z).y-centre.y
dz=wa(z).z-centre.z

If flag Then
ww = 1 + (result(z).z/eyepoint.z)
result(z).x = (result(z).x-eyepoint.x)/ww+eyepoint.x
result(z).y = (result(z).y-eyepoint.y)/ww+eyepoint.y
result(z).z = (result(z).z-eyepoint.z)/ww+eyepoint.z
Endif

result(z).col=wa(z).col
result(z).col=wa(z).col
Next z
End Sub

Sub QsortZ(array() As dotvars, begin As Integer, Finish As Uinteger) 'by dodicat
Dim As Integer i = begin, j = finish
Dim As dotvars X = array(((I + J) \ 2))
While I <= J
While array(I).z > X .z : I += 1 : Wend
While array(J).z < X .z : J -= 1 : Wend
If I <= J Then Swap array(I), array(J) : I += 1 : J -= 1
Wend
If J > begin Then QsortZ(array(), begin, J)
If I < Finish Then QsortZ(array(), I, Finish)
End Sub

'CreateGradientSphere function by Martijn van Iersel -> http://www.helixsoft.nl/articles/sphere/sphere.html
Function CreateGradientSphere(cx As Ushort, cy As Ushort, r As Ushort, lx As Single, ly As Single) As Any Ptr
Dim As Any Ptr pImage, imgData
Dim As Integer pitch
pImage = Imagecreate(r Shl 1, r Shl 1, 0, 32)
Imageinfo(pImage, , , , pitch, imgData)
#Define PixelSet(_x, _y, colour)              *Cptr(Ulong Ptr, imgData + (_y) * pitch + (_x) Shl 2) = (colour)
Dim As Single x, y, z, lightx, lighty, lightz, q_cos, light, c, c1 = Cos(ly)
lightx = Sin(lx) * c1
lighty = Sin(ly)
lightz = Cos(lx) * c1
For y = -r To r
q_cos = Cos(-Asin(y / r)) * r
For x = -q_cos To q_cos
z = Sqr(r * r - x * x - y * y)
c = (x / r * lightx + y / r * lighty + z / r * lightz)
light = Iif(c < 0, 0, c) * 255
Pset pImage, (Cshort(x) + cx, Cshort(y) + cy), Rgba(light / 3, light / 2, light, 255 - light)
Next
Next
Return pImage
End Function

Screenres w, h, 32, 2, GFX_WINDOWED Or GFX_NO_SWITCH Or GFX_ALWAYS_ON_TOP Or GFX_ALPHA_PRIMITIVES
ScreenSet 1, 0

''
dim as imagevars  buf:  buf.get_info

Dim As String sWintitle = "Around the Sphere coded by UEZ"
Windowtitle(sWintitle)

#Define PixelGet(_x, _y)                      *Cptr(Ulong Ptr, imgDataTxt + (_y) * pitchTxt + (_x) Shl 2)

Dim As Integer pitchTxt
Imageinfo(pImageTxt, , , , pitchTxt, imgDataTxt)  'earth map

Draw String pImageTxt, (0, 0), sWintitle, &hFFFFFFFF

Dim As Uinteger particles = 5000, i, ub
Dim As Single x, y, theta, rho, phi, f1, f2, CamRotX, CamRotY, CamRotZ, ang, z1, z2, px, py, pz, c1, zoom = 1
Dim As Ulong iCol, iCounter = 0
Dim As dotvars aParticles(particles - 1), aResult(particles - 1)
Dim As Boolean b1 = False, b2 = False

''
aadot.vie.iris_z = eyepoint.z * .99 '' added to z prior to defocus_draw

Dim As Ushort dimx = 0, dimy = 0
For xx As Short = 0 To 319
For yy As Short = 0 To 19
If PixelGet(xx, yy) > 0 Then
If xx > dimx Then dimx = xx
If yy > dimy Then dimy = yy
End If
Next
Next

'Map string to sphere form
For xx As Short = dimx To 0 Step -1
For yy As Short = dimy To 0 Step -1
iCol = PixelGet(xx, yy)
If iCol > 0 Then
theta = Map(dimx - xx / 4, 0, dimx, theta1, theta0)
phi = Map(dimy / 2 + yy / 30, 0, dimy, phi0, phi1)
c1 = (radius + 1) * Sin_(phi)
px = c1 * Cos_(theta)
py = c1 * Sin_(theta)
pz = (radius + 1) * Cos_(phi)
aParticles(iCounter).x = w2 + px
aParticles(iCounter).y = h2 + py
aParticles(iCounter).z = pz
aParticles(iCounter).col = &hE0FFFFFF
iCounter += 1
End If
Next
Next
'blue sphere coordinate
aParticles(iCounter).x = w2
aParticles(iCounter).y = h2
'aParticles(iCounter).col = 0

Redim Preserve aParticles(iCounter)
Redim Preserve aResult(iCounter)
ub = Ubound(aParticles)

Imagedestroy(pImageTxt)

Dim As Ulong iFPS
Dim As Uinteger cfps = 0
Dim As Single fTimer = Timer

Do
'Cls
Line (0, 0) - (w, h * 0.75), &hFF404040, BF
Line (0, h * 0.75 + 1) - (w, h), &hFF808080, BF
ang += .0033
Object3Dto2D(aParticles(), aResult(), Type<vec3>(cc1, 2 * ang, 0), Type<vec3>(w2, h2, 0), zoom)
Qsortz(aResult(), 0, ub)

For i = 0 To ub
'Pset (aResult(i).x, aResult(i).y), aResult(i).col.argb
'Circle (aResult(i).x, aResult(i).y), 1 - aResult(i).z / 800, aResult(i).col, , , , F
If aResult(i).col = 0 Then Put (w2 - radius, h2 - radius), pImageSphere, Alpha 'Circle (w2, h2), radius, &hA04040A0, , , , F
Next
Draw String(1, 1), iFPS & " fps", Rgb(&hFF, &hFF, &hFF)

Flip
cfps += 1
If Timer - fTimer > 0.99 Then
iFPS = cfps
cfps = 0
fTimer = Timer
End If
Sleep(10)
Loop Until Len(Inkey())

Imagedestroy(pImageSphere)
Last edited by dafhi on Sep 17, 2020 4:19, edited 1 time in total.
UEZ
Posts: 618
Joined: May 05, 2017 19:59
Location: Germany

### Re: Around the Sphere build 2020-09-15

@dafhi: I had the same idea after I finished this part to make the circles blurry according to their z value. ^^ Anyhow, thanks for your version - very smooth movement. :-)
dafhi
Posts: 1357
Joined: Jun 04, 2005 9:51

### Re: Around the Sphere build 2020-09-15

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

### Re: Around the Sphere build 2020-09-17

Thanks you again dafhi for your contribution.

Meanwhile I finished also my depth of field simulation of the text pixels. imho, it's very simple but it looks nice, too (see 1st post).
dafhi
Posts: 1357
Joined: Jun 04, 2005 9:51

### Re: Around the Sphere build 2020-09-17

thanks for the inspiration!

didn't know my depth-of-field dots wanted to be worked on. also been overhauling my 3d system
UEZ
Posts: 618
Joined: May 05, 2017 19:59
Location: Germany

### Re: Around the Sphere build 2020-09-22

Small update: added now a bitmap font with anti aliasing for a better look. If you are interested have a look to the first post.

The bitmap is integrated into the code which should be unpacked and saved to the disk.
Last edited by UEZ on Sep 22, 2020 12:27, edited 1 time in total.
Roland Chastain
Posts: 936
Joined: Nov 24, 2011 19:49
Location: France
Contact:

### Re: Around the Sphere build 2020-09-22

Hello! Unfortunately for me the program stops here:

Code: Select all

If FileExists(sFile) = 0 Then
' ...
If bError <> False Then
'? "Something went wrong"
'Sleep
End -1 ' <---
End If
UEZ
Posts: 618
Joined: May 05, 2017 19:59
Location: Germany

### Re: Around the Sphere build 2020-09-22

Roland Chastain wrote:Hello! Unfortunately for me the program stops here:

Code: Select all

If FileExists(sFile) = 0 Then
' ...
If bError <> False Then
'? "Something went wrong"
'Sleep
End -1 ' <---
End If

The code editor must support UTF-8 format otherwise it will not decompress the base128 string properly.
dodicat
Posts: 6687
Joined: Jan 10, 2006 20:30
Location: Scotland

### Re: Around the Sphere build 2020-09-22

Hi UEZ.
Works great here and I use fbide.
UEZ
Posts: 618
Joined: May 05, 2017 19:59
Location: Germany

### Re: Around the Sphere build 2020-09-22

dodicat wrote:Hi UEZ.
Works great here and I use fbide.

I'm not 100% sure if you must save the source code in UTF-8 format because it seems to run properly also with ANSI saved source code. Anyhow, I added a download link to the first post.

Btw, thank you for the functions I used in this code. :-)
Roland Chastain
Posts: 936
Joined: Nov 24, 2011 19:49
Location: France
Contact:

### Re: Around the Sphere build 2020-09-22

I use Geany and the encoding is UTF-8. Even with the file from the ZIP, it doesn't work for me. The program exits as soon as I start it. I am on Linux 64.
UEZ
Posts: 618
Joined: May 05, 2017 19:59
Location: Germany

### Re: Around the Sphere build 2020-09-22

Roland Chastain wrote:I use Geany and the encoding is UTF-8. Even with the file from the ZIP, it doesn't work for me. The program exits as soon as I start it. I am on Linux 64.

What is the timestamp of the both files within the zip? I had accidentally uploaded a not working version first.

If it is not

Code: Select all

22.09.2020  15:41            25.317 Around the Sphere.bas
22.09.2020  15:42           186.368 Around the Sphere.exe

I'm not on Linux, thus I cannot test.
Roland Chastain
Posts: 936
Joined: Nov 24, 2011 19:49
Location: France
Contact:

### Re: Around the Sphere build 2020-09-22

Thank you for your answer. I have the good file. When I have time, I will try to understand what happens. For the moment, I am on another project that I would like to finish.

By the way (I know this isn't my onions, as we say in french), but why don't you upload your files on FB Portal? Just a question. Feel free to ignore it. :)
UEZ
Posts: 618
Joined: May 05, 2017 19:59
Location: Germany

### Re: Around the Sphere build 2020-09-22

Roland Chastain wrote:By the way (I know this isn't my onions, as we say in french), but why don't you upload your files on FB Portal? Just a question. Feel free to ignore it. :)

I'm not aware that I can upload files to the (German?) FB Portal. All the better if I could.