Around the Sphere build 2020-09-22

Post your FreeBASIC tips and tricks here. Please don’t post your code without including an explanation.
UEZ
Posts: 635
Joined: May 05, 2017 19:59
Location: Germany

Around the Sphere build 2020-09-22

Postby UEZ » Sep 15, 2020 9:00

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

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

Image

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
      Result(z).x=rad*((Cosay*Cosaz)*dx+(-Cosax*Sinaz+Sinax*Sinay*Cosaz)*dy+(Sinax*Sinaz+Cosax*Sinay*Cosaz)*dz)+centre.x
      result(z).y=rad*((Cosay*Sinaz)*dx+(Cosax*Cosaz+Sinax*Sinay*Sinaz)*dy+(-Sinax*Cosaz+Cosax*Sinay*Sinaz)*dz)+centre.y
      result(z).z=rad*((-Sinay)*dx+(Sinax*Cosay)*dy+(Cosax*Cosay)*dz)+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
   sB128 = "!#$%()*,.0123456789:;=@ABCDEFGHIJKLMNOPQRSTUVWXYZ[]^_abcdefghijklmnopqrstuvwxyz{|}~¡¢£¤¥¦§¨©ª«¬®¯°±²³´µ¶·¸¹º»¼½¾¿ÀÁÂÃÄÅÆÇÈÉÊËÌÍÎ"
   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 Any Ptr pImageTxt = Imagecreate(500, 39), imgDataTxt, pImageSphere = CreateGradientSphere(radius, radius, radius, -pi / 8, -pi / 4)
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:
   Read iLines
   Read iCompression
   Read iFileSize
   Read iCompressedSize
   Read sBaseType

   For i As Ushort = 0 To iLines - 1
      Read aB128(0)
      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
   Bload(sFile, pImageTxt)
Else
   Bload(sFile, pImageTxt)
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)
         c1 = radius * Sin_(phi)
         px = c1 * Cos_(theta)
         py = c1 * Sin_(theta)
         pz = radius * Cos_(phi)
         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 "O(!t)|.!J2V8!¯@¿L!!X7r!!«!4#!hmE$!Ë$f(!!*É.!73!9!lBBN!l[¯t!!³J9#!v#P$!B%{(!d*N0!!4¢9!JDlO!!aZw!!ºlA#!¦mZ$!_%³(!¿*z0!¿4R:!!F·P!ld!z!!Á¯F#!µ#g$!|%È(!R,Ç0!¯5Ë:!¯G7R!!h||!!È!L#!Ãmq$!»%5)!¯,L1!|6|;!lIdS!lkJ¡!!!KQ#!$$|$!.(M)!B.x1!l7N=!JK¯T!!o¿£!!,mV#!7n¨$!N(d)!|.Å1!Z8Ç=!!M.V!lrl¦!!5°[#!H$´$!l(y)!.0J2!J9x@!¯NZW!!v7©!!=#c#!Vn¾$!ª(±)!l0v2!7:JA!lP¦X!ly¯«!!FKh#!f$É$!Ç(Æ)!Ç0Ã2!!;ÃA!JR!Z!!}Z¯!!Mmm#!tn(%!;)3*!Z1H3!¿;tB!!TR[!l¢!²!!T°r#!¤$6%!Z)K*!·1t3!¯=FC!¯U|]!!¦|´!![#x#!³nC%!x)b*!J2Á3!|@¿C!lWÇ^!l©J·!!dK}#!Á$N%!·)"
Data "w*!¦2F4!lApD!JYJa!!®¿¹!!km¤#!!oX%!(*¯*!73r4!ZBBE!![tb!l±l¼!!r°©#!5%e%!J*Ä*!t3¿4!JC»E!¯]¿c!!µ7¿!!y#°#!Foo%!h*1,!!4D5!7DlF!l_Be!l¸¯Á!!¢Kµ#!T%z%!¦*I,!d4p5!!E;G!Jblf!!¼ZÄ!!©mº#!do¦%!Ã*_,!¿4½5!¿E·G!!d·g!l¿!Ç!!±°¿#!r%²%!7,u,!R5B6!¯FhH!¯e7i!!Ã|É!!¸#Å#!¢o¼%!V,¬,!¯5n6!|G7I!lgdj!lÆJÌ!!¿KÊ#!±%Ç%!t,Â,!B6»6!lH³I!Ji¯k!!Ê¿Î!!Æm!$!¿o$(!³,..!|6@7!ZIdJ!!k.m!lÍl$#!Í°)$!Í%4³M¿JGt,Éml|7N(4KNR0]nz7;;)SK1l8J)L!=(*qK]·3Lo¹7E;*À#1°C¯!½|H³,ÌKlR79p*}H;!l#oKcB)7(Lp0aLz·:nn1nͯF3$|t=fqZ}VN2SK(¯9¦4¯%fl,¼L².CTrt78ZHË,l°9]r¨8cÃ4mM"
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 "il4¿#*!3¯*Ã#@º¶f¢½l@!%F*¬mDJn(l;J=B*wl!l%»n±J.;K@lGB2D%¿lF·*R°:t!h7B¯8;*ªmbZ37nAZ!R$kKT¿!ªpnZC¯$,¹p.!¤#»!9ZMfn@!1;%½!E7*Hm;¯$X$z!*7K*¯:R3lnH¯fO1!°_d,J¡0=2d*XK3Z¡9lZ¿=³*xQe.4n$UJi0K$!,Z,t$ª¿CË*²K_R1nm]£J;!{!cZ6¨nm7A|*,xad1!mlqJR#Zm[R(Ë¢0m$V(¥#JǬ1(7|7(*°#Â05$%r|)!N(JZJ4h#:_#¿$Vma¯ht%·7;ª$*w.Á#±m«7F3,©°]R1h#0ZSG!v!Qd3_oÀ7F;*#mr±m1!K79B*¨#cl3¨$a!(Ç%X°8¿8*!:l7B*UVe!5Ç$k¿)¦SLL,l*±$·lEt*j#Nd%.m¢¯6Ë!62mÇ#7nW!$t#*°V.4d%·¯@Z(R!FE81l¥¿I¢,§¯r$%*n¬¿DÇ*~#Yl0@#U¤x´#NKa75Ã¥~¤¢8,©#P.$($»lFBaY¼5²4H%¨JAÇ,¤K©1n5!alGp,"
Data "¼!#R)noÆZ33K(¯7.3Ë%4;§Ì,À°K!#hp(¯2(,vy*n5¨m~|!¼!rneÇ6¨$4¤J7!¦mk!5$@$!,N*¡y*±6¨%ÊZG!%N.$7*ªoÂ|4t.:n*t2Ç%¤!(ÃJ2¯JZ6½%i|¬=!q¯Z·6|©Î¯IV*u!X%n$!:|9l,,½k·6BoQ|WyM¬mpÊ6¬%s¯%7.$J:¿4³%b!t¼Zf°kl4$m$K$l%·mpg6l$v;PÇ,ÊmKǽÍlª!§KcÌ#]Z)T¡7¢!Ã#£°mº6;%S!H£1Bmil½Ëo®¿yy.E!Vd¿Ë%ǯG»,3#pB#Å#AƯy,=#0·z5!]lEFdÆKf¯6JoF¯}y.Ê!j¿4Án_(«i,Ä![±m*!uJ%8*NJ1±!xmÄ¿¯¸,b#5!¶R!tlHÃ,Ã#h.6µ%É|Hª,ÇKj¦6Ç%1;Hx)[!L76Í%Í|¹GIG¾ÈÈ5³%sQIÃ,ÀmGÇ6»%EZ(W!2°jd5Zm7]F.bM·172Á%ÍlEV).°MÇ2@«ÄJ3lQ$J7¦3ÉoÌZCd(F°_¦6ÍoÂ|E¿,Æ#iÉ!ªoÎJA¢c6¼bw5$¤;¿@¿,Ími¯3Vnw¯B³h"
Data "D·eB)¬©ZJ¬}cH$,73Ë%¨Z(ÃJ,JI¦Ã]nÆq.p*Ë°¸U4±n¢7C·,u4b¿(p|!!%J)Èm*¹6~%®7=¦)©#jÇ6Å%²l*7.*l@!59©ÂJBR)b#c|ˬohZU4!¥JdJ6¹m´q%=#a°kJ6R¨Bm7R,t¼fR3¢n¦¯E·eË°VJ{D!D¶µ4ljl]tν%ºZ@V)u#il![%W¿kÈ.V¯Vl»Ão¹Z@;*Â#]Â6hoZ|c¸0ÆJh¦$¼nt|7V)µmk|6|n»ÅL¢(,Zkd4h$slAV,fXj·,1p,¿6NMÍ#fJ3¤n¨¯EBdU¿Qd$$l#¯,»*D·f·2Pn}JDª,uy]!²l|qJ¶Kd¥#UÇ05o,ÇId,̯{Â8Nl¼PCe%35¡f(Z%(QGª)QmYZ5$°¨¯8@.B!Rd6¦ou73!%±!Cd*~#b¯4l%Â!IÈ)¯l%J,|*Ì#g¯.h#A$Cf8ªJBZ*¤#d¯5Ë$i¯f¯6@nk¤J¿!U°k¿3Él@±FtilzI.6É%§7.|!*J$¿#N$Æ|¸aq7¯QR6Ço©¿*J!5¯.70LF³rH;U}¾k¯2T®*¤FRPiU#Ç,Á%ÎlER%"
Data "LJ|!$N#¯JÈ4,r!0f!jmÅZ¬Ìs¿±Z¿6É$:|%)!¿JiÇ6±n6|W¿)ª{eR,~l2Z$!#¢JX.67©·JJ´!@°#¢6Fogl*»!:!*!%Ëm¿I¯,B°Áf!lmÀ¯Ip,WK6·#Rl3l,J)È6^.%vp8¦HÃ%z4,¨#]Mο43!#!;d5Ë%Í|B_$I¯(Z#¨lf¯D7VÌ#G7=ǯ8_%|)ÌmkR5Ím=¿$|!JJ=¿1ªouAA¿tI·%¦,¿~ÃZ7B#A¯,.)»$É!§À*wl#.!Íl·JªW%El$R!R!T¿DFi¦!T9!TmÅZ§8(R¯%t!b!QÈ!¬,¼!md!]mÀ¿I·,p#8¿#R!3¿)¿%§#°v5½m#!(()°~]t(Vµ.|(R%ª°ª;3!µ6¢8·e¼#N.%Tl,7(¿$q°Îº59#·£J(%D·)v3hF:;(F)É°j¯3L#3J$»!clJ75ËoË7:¿!ża:5V#7*(W!ÇJg|6pn8e(´!^°kZ3p!8¢*_*ÎmUJ{d#ÿE$Kd!aÇ6RoE¯MÇ!Q#j¿5Ã#[;.³d¨m6¯rF!l7_Í,¿°j;ÌËM5p!·*U7*7!¨lÄÇFJ$"
Data "#T!Ç#¢nοE»#99AR8£®0m%³tomn·mnmkQBJ#1JK!9s%L7gL0d!RZ3Dn7;#¢%ÁKkÇ4Çm:Ç}«$K:ed)(!(¿3B,Á°Id=2p5!@³,É°I7#p¯¿¯H3(P»p¿!f$4p7J!LJZ|m¬n4¯O[!°!WB3L³1¿W*K3¯FÇ!u%RJiG!aJO.3.n«Ã%Ä#|mk|5¯#o£#B%¡°·¡1Tl.|:ª,ÁKGt)2(ZZ¸S*Y.*¦3¤Jc|jL!ÌRi.*.(AJBË,Æ#TÇGKp2¿2|)Z#:¯!¤#ÄJI¿)aJCE(3%Ì7AlkJ.Ml»¹%g¿v9.=JP¦.8%ifLt!q°¸E3¯µ£eRS%¼mkl3!m»e!¦$©mk¯5¦#Ç;%3)Ç°ËVIm|1¿93{6#~Êm.!k7IN,¢l.Á(¬oUQFÄ$1ÃZ%n(!TZH¯,G°QM71!Y!Vv)$ÃK°)Wn{¢JB#hm*É5r·ÍÇL@0v°¸g$7!q¿I³,Em9£:x¬½Z*7Y©J5i8§I¿T)ÇJ~l_²3¨!C¿BÃ,ÉmKRY2p(!(¿¦H±0Ç2Í%į5;e(n*R1F®qZ$N!¾JfÇ5¤#}vMx$"
Data "¨mkJ3¨!$¯1Z¡,°MWµJ$³*9d!µ!gÇ6t%L!Y)!;!,·7V!mÉ%)!S!Z¿6·ox!·¬0F¯}G8|m¼¤AZ#XT[^1L%[J#»!xKkl4¯!dÅ#x*ÌKiB((lV7Î0*Çts¦(ÃoÈl~=!¹!²N45maA!x!C!#J$³nS¢3x¨($.d1½o¦7((Kw£k·1_lOO(!*Ë#g|(QpR7GÇ,j#8lw@%YU(£!Q°]M,~½NK6xrÍbm¦X©Uɸ([#§Kk!6Tmƨ%£#s¡RÇPe|(l77¨}!m.ZAR6¢#x%ÈmdB*F¨8J¹e*hlz|1rKR¯}¸$CYry;tR5g!RmÆK6.#ZºÄ7ÄÀJ4!Ç£4±VeÃ@§tH±*Ç21«=¯%#$5¢_J%z#XRA;#¤[Xw,·Ft7;z.(¯@!5Å%©ltµ%¼mg|*d»4J;¯,«°:l!Rm¿¿HRNHtHd!Y$;Jh¬,ͯP(nª¼DA(C!±!f¯6.%.F*[(wXIRek7BJ¨Ä(yÇs2,¿%Ìl53!H#]Ê)fNTJCi$©nW7¸ÅmO·M;$~°kZ27[6m(x)ÆKTdUi|p|Id,µY,D!|#ʯI»("
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 "Ht1lWO%HJ9ËIA#8t(hm[J1!$Ul(·!;!tC(0![JN.,d]t)0¢*Ë°X|$B!qlHd,·!s)#n²¹r#p$®°i¿.FÃ0À2pd@#5BËj%b7.l$²lA¦(¿l7¿#Z!0!Ef|i7$l%_V)°jd6h$M!0¿$²¯;.(¦!2JbI!yDpl0ÍI_7ÈÁJ{lww,j^H|Æ])9¯CÅ6H(gc4(}89.75Í%À¿2($}lŤ(¹l7!$!¾w.EÇ5Í%u¿e¾Zo#j71¯Q7³7»,e¨,T(foÎ|@¿{L))~,|~)!9·,À°CR|0(0Z87¨º!.n$½Áº¯r92H£Ojnj!QdI¯(É@pl#bdzµIt,¨°Y.19nj!7Ë(É#h·,5¢!gHJ%GR$.,|o¬l,¦%ÈKc·Cº¡n¿u¥[{¯)h2Xb6KA»,je·(xQp#7F¶,¤!3R4Ë%ÀJTv»°§a¦t^9yWsÁ»f#k!55mOÇ(·¤x°4B.5K0sIV,}mP|%½ÇÆb5Z,È#R·#D!u|n@%¬4mJ#B$ÉlEd$,¯:Ç4Ç%¦!=ÂJ©lÃÊ.±!®7ÎudÇKdÇ2Ë#4lJ!±5mtb(¤oÁl,¯%"
Data "J9O¶5H%z¿.·¼(±I¦°8$6z%}#~4NÇ!f7F¯Rj)0lsÌ6(J:¹4»dT5,drOFοHÇ*kKG!IomIu=texZ[l6j$^Ç%4(PhG½mÅÃÎl=ZZ6!eÇ6|o{;!ª#±KkZ3ËÉ7;%J)ÎKc!(l|$|6«,³!Tf#_$ÊltIKc¯cl½omgÊPa)D½_^5;m58¯¹,Ëlu¼#ªnͯC!$°¯id5ª#s*#h(ÎKd·(ttI¸=¢¸GRW|6¿Y,¿Q¨Â)±!t4À%QZ%ǦÁmjI8P!{¿I¦*jHµj)JÂozJ»!0«h..Zg5p)B*!©2Zmsh½¸=xÅQtºvT²%elH¹(ÉKg.*¬U67=³,z°3B!¨fS6gÅJ±!A_.r!À§»oyµ!TÁbÈ%¥|%[!4#}=)pmÃZ¿Â,dmiÆmfm2.AR#DÇ,.½¤n̪J($¿#kR01l¤!§0(G.#!,rgZh¿:¨³JÈv4Ío´JAÎÉ@}QJÈg|l7IFÀ.Ë~º0p}W7Î}(:L$BM¶oÌD(È!kmk!4DÂ5_¥Ì,(#bc#;G4¾(0!ʯwË3Å!Ê4!(!{!²»4¢$«JBJ*yK_J4]%ÁZh±)"
Data "8gTÅ6(%½¾M!$RfZ!%9#Ä|H_(I¦1l2Í%´lFÊ$νSJ{f|§7·AU5!ÊVÃA»²¿Ãa#bH(;2vfV#;tÉMFµb·YNWIÎi*]2,~%Jo7È%³#9=hl*;!4!*B$¥!D¦,Ç$̯I¢(vË.9!b!aJ¨iÄMÁ%ÇE§oWJi4!¹Je¯6n$yO¾¾,L#%Â8µmhË4B!¿!A³3¬l*J(³#xlAÇ*7$]sH¢´¬$]Ê5Ë!AÄ$Z*wY6!%h»ÅZ5J!b^8d)z#k¯@.JL°¿¼mZ!~¿H¦,E°.ÎmX!ª¯PÉ^.¹I!Ȩm#¿2³k©mn,n¸m4ANA!į·Ê2±l*l(³#zJB!,Ln3QFl$#J0Çu«og7M64u#nqÊe7ËvÆÊ.Ƽj.6¢#(#%·¤©m¯5!·!r§BÇÉ[v1Z4Å%¬l¹ÊJr!v52;p1|9¢,¤®01#FnM·R©rSl[¿6$o9J!Z!@¯,Z$¦!E!6J,yÊB4Z{¬{lHy.¦!³¾1nl87¶¼)WËn£)t%ίÄ19~YUB±e7^1Îb!Gj_¿ÈMr|eG_!$J6tΨ%Q¯O}!L°kR4;ËTι®t¨jÍw6_$Sh!3%"
Data "¹°kZ0J!0J:Flwm0.|R!~!QÂ$DB¥1(¦n4¬I¢*xu(Z1Í%Å|2RYH!X|½b#(7¾Î*DRfZ)nLR{ë$j²^BÀD$1«,7q:¸Ys»É%¬¿lÎdTJed7ql.¯8»,Ìm_B¬Pp37:¯,·°CR¹e|1¦m:,ºlc:¡¬lVB#³Í·°PÅ8Bl·¯À*$$¯,7¼½oj¿L9!P¾g¯4%!0VCK({a!d(t«©¿Kd!ÎJ·c3Ã!5³)V*Ç°P|¿k|j!It,«¯¨2*]H½!*!0¥¯§:0!§0¿kH,%±,D!¹!¼!I_)jD.v$*¼¶lF¥!:#iZÌ{7A¿BÇ,Ì°LR¹gÁu|~¥$X1$l,»%Å|3_R#¤*$6Z$yqJZ!$Kɤ,1l#J6¢f¯¯kx$xSů5¢P²¯*c2±f6m=³,Çc%Z%¼%i!¸=!ͯ·Â2N;*¿=Ç,;½n²8B!S!q¤*Ã0¡]ÄcÅVI}²¦¯¯^«#jnË|§µPmJPµ6vn5¿J4!À¼k!§I_$¿(B(s:(»3Tml´$x}¹E.·8(!9¯9¦,ÌKTJ{Á̾7§4*d!X2!*mkyD(¸*lkÊ6¦o^|#Ã.@¯RBHAnl´¼¹J"
Data "Æ°VÇ$@8Ç@Hle4¯!J%t«Ì¯;F#,T#B*noÍ|B¢#Dd©d0µOÁl4¢!RS!R#j$¸71J.#¯5·3Ã%~!5A!À¯L_3@A%!®XjµlRa!¨lÂÅGl®x±bXv~m%|K(!:;kl6($0O!¦#¦=jJ2D¨6s$¿%·#u£¿k|i¿HÃ,}#9lÃ9!V¯¹Å,1K¾¹SÈ%ÁZ0!ª³!cj0Hº]b,lZJ#¨Y7Vl@IFJ©;¯MJ6r%Y7$Ç0jn{¦!;lÉ«b²$8XfB(x»$K!Z$·°j|0hizirb*³em¯)ÍNu¥Ih*ÅJ7l%¬#Á¯IZ*Tź.|m%dl(Z!9l3Ç1½%Î!Bdp°J·_¢i7~!It,´T%tuÎoÈ¿ef!,¯*·*JÍÉZ4_Q_l]BAqoi7.¦#~lR.ÀHRÉpS§ÉEg¤{·¾%%SG»%M!#.!Nlk!Au*k¯mÉ*¯J1Æ3¦#_JE¯)¾%XJ%ÆJ*l1Z,Ddy,Fl(ua¤6¸¤J¥J0x#gJD·2¿oÍ!DB¸OLUsÇPH´l1t!M$3Ç1¿%Í!;|QrnU¦.ºo~l0p#j¯¡Ë6Bo;|J|!AtmÃ6~oi¿.|#¯l[55@m*m°Íu"
Data "·zE7Fªm¥uGN%Êg,T$ËnÎ¥Hp)®l5B(¦½ÍZ5³nq¢i|6vnAJ$R!N!GÇ:¾oX|G¼!QmÁw6@$Nl*N$)KlªÀ¯Y¾k%N)*Xh·0@#CZ0.{ÊKZd¯«pPZ©mθJ6¦%jm©¿Î´,DmnÎm¿mqÇI_,D°=t%¹lQJ:tjÌ°YJ{5,A,@|·¬k1t8Yo7yh2$¬Ki|0*¾5N$¿(Ç°eZ)1l0Z8x,É°dR4]zx:Â|*}#Vd)hÌ6Ã!RfÍ#YB$ͧ2|CÇ,§#FYEL~¦¿y¬$r9[¦3ÁIͯF¿NÍ°gd.bp(¯3(,Ìmf.3v$¤7Dhl½KC7r]mI§8ÉJ~aiR¤D!ÂT%¼,}°S¿0¿$A,ÍUz*J9l~QªÃJEpgD.a¿¡k70¿0drÂ!RJ6³o¤l5l%¶¯7¿»_iÍZCx)C6g·2L$o!=ˤÉK,Y7JllJG·JÇmbt4@«Íl;!ÈIt$l*1oqt¤z){!7UPGeÅ¿D(,v¾k!5|#[;¾Î*Å#V·3PH¾7=J(4°Z¦.woV7G)!YlC£m¨%¹lF³kÄK=!tB!Î|Il*g#]º6¨o»¿OÉÃøq.,$NJuE»*"
Data "¸.jR1V!:Ã.t¸D.j!5x%´QE¿r)±0Z3ÇoÌJC_)K#[ÇWÈo¥Zp¾Zo@n%6Z%¸A§e,mhu·$¿©0sGª*µ°j¿6foX7g9¢4F»;´X±8E:|QJ·G¦Ã9EË¿E.Pt4{:X0pi¿Î£$Ç1$d.ÁoÉZ6¿³%½cR6Tn½w%i!4°h¦5zm(J$N(²¾t¾3Él½{a;*Ì°hd,Åc¤S¹i,_Is7(¦%Í|:¦X|Jc¦6X$r¿¾SbÍ#aJ)@8Mp@Fl¡4kl3·A$}yÎ,y°2¿mDnÉ!Îb!µah¦Ã|EÉ!8Çɬ®(!0±«%sDǸ[T2R1@o·JD(,ËmjJ5N%·|Bª(k!$|ÄÈ%¨l5ÃÂDthB4a7Æ!2n.dJXd!=©Í¯Eª$DB,]!½l90°y,sKBÇV0p]f±Äov4i|1H«9}£{,*#O.À_¬Äl2¹Jrm±W77l]¯*zbÇ#[JÈ6!ËlI¦)½lB¢»P¹a!¥4![lUd!=EÍ7EN%D¦sB#¬m·JÈSbÈ°TtVK@r!AKc¹#EÇ6%lflºGd½K7Q79lb7FÃou¼h¦1(b$K*_)tGfÂH¸:7¢5VfÁ#°n½¢om¯º5)"
Data "Ë#id¯y·X!H³,Nm¬G¿j%ÉZ9t±Ft%J.¯oÅ|~v!,°ÇEÁI%K|Êw1=°L»¡k|#lN¶,(°pZ!¬m´Å_y.[JZ¿5@¦aJDËkM¤[¯)hÌ)Ê)Ë(ic]M6·nKl4m#t°kÇ25d5_3F,x#_¨!Ë$Ìl;!(µ£]%6.$**Lp!ÊJÁ²Gy%«J¨}*@¯,]!r#ªz~©)Nl¤¶6zn=Z1Nj¡¼hÇ.hÍ!!)»(¯~*¨6¿$M|¢2K1J=Ç3~EµJ5F¿FR)J1Çoµ!:!*ÁKjp3Ë#7|K´Ê®mhl*zlo!GppD.dB)XN%!1.*:Ìk¦5N$:7Ju[É#K·!V#®¿Î¸h¥mF7q,!8|97,Ì7jd2LmÌW.²#L°d·,«%{¯*R~@!F!4ÉK(ÆEJ%~dx¯)!oÎQ%u,mK#Ä5tÂ0}#|$k°LFÀx%rl(³ºSJLZ5É°©AA_,È#PJ{l7f!N¤)3#Äy»·%±J3h!!uO¦6l$:wM³!r#k!3r¸8O.JN9m;5{¿#¬@7l!8JK!k¤$j||;;))H¦,9nY¯ÂÊJ]¯_¿6¿%_¯³Á.J!ft¿j¨.J³6,²ºpl!ÉlW¿)G!"
Data "QJ=·,Í#VJ(h¥¹b8l.±$§|9d$FJÅh!r#|¿1|·)$(|%±!(K!3#rJ.t!·lel:ª)O°G·%jÂE°(t$ÊJJ·)¯lA¯AË,¡#¨Y9*m¬lCª*³#=p½¶{ȯG!)Fl¤¶6dn4l!¦_£mhB6±%±Z3_SGR(J%lmlZ5($DJƾm3!Z¿Exw¾°Ql$Ãb$Z*V%cl%¯#·!QJ1ª#JJ¹yÆk%Ç¿2N!6J9Z1~%Ê%G3)o¯,X9f!L757(¯J3BPKpC!3¢¸%J,¯(Ámn¿2Z#lb!Ç!³!Y!7x%o¯*Çmw|0J*Ç$!°E¿%B¢5(#;#ÆlSl2p$c!*¿³)J,R(¹mo|3³#LJOl0M·8´%J$ÁlJ|)¯!Y®Mb!]lAÇ,ÁmRZ)V$¥#jZ0Ë_7N5FnIm*¦$P#i¯7h%m!©±lam%½W}#¾l4Z]0($¯,¿N;KÆ´m@ldJGÃN:!(¯zw%Z!·*!ÄE¹f*l³º7%ÊJ2!´¤5pY¾6)B,ÊKYÇy¸94¿±z*ocpc)¦%Á¿3t!=¯,¿#N(W{Ip(33vd#l!0|Ê{K*l:¯)4ÀQ|¢wKÈÍcÇ5P#Ia#Ã!"
Data "HJ$|m4¡;Ã!¯g¼°(VpÍ!ae9ǸJ.Fd(k$SV.4!blZv0*¾5N#Z%·KiJ0LQk!H;,¯!tc²xnÀ¸9h¤%g@.6Á%sZUytðhJ.Fg£N%¿)xkÆyuV#ÅlF7Ä3dL{.hjLN!d#s4kB4»l½I)´Ê®Kg¦(_f²¢*G!ÇXgB¬1}IJWr(3»,É*~}{J12L$l2l4»oz¯Âʬµ¯eZ6]n2¯#»%¾#e¿)lh:;]rN®K8ǦllFÆCNi=JU·6loI¯B=.D!Y¿6B%SF:§$»#eJ¹C¿p¬73¬xR%|.F7¬JZ©KÈÍc·57#:ºB#L,!¬²5¦!I;]¨*ÆKMZ#n7b7ÂÌ(~Ç79$LoÊl;¦!tfBR5¿%|!%_!ǯgB5dm~5*)!·Jp23ËÃÇc7ª,aª#|%L%9»ÌEPE¯_z3NÀx³1Z,³#S¶l:ÉnZÇ]LHl¢w5r#yH)´Ê®Kgl(xV²(.G!:°k¯5~!I;]¨*Æ°LlÅ2(al2Í(~Ç7É#µÊ£¯Q%K.JBR5Á%¡J%_!ÄlgB5_m~H*y!a4kB*¿=#¿,B,³Z)ZmÀoplLÊOF¯¼O3rSJ¶1Z,"
Data "³#S¶l:ÉnZÇ]LR¯GÌ3Ã!YybQKÈÍc·57#:ºB#L.!´¬5FkDN!.$¥mil.hj5;4¿nIm;Hpd!©7It)1jnP*x%Ì7=»!3lF·5poU¯§MKvJDÁ3B¦Ç_AVjoJR7z©J²pJÃ!r#k.3rSJ¶1Z,³#S¶lQÂnZÇ]LLJS¬4xÃ5(#d$8°6|¸¼À´«GJ$P¤[$p7lRYG»cit!l(]%ʯ}*Kµ!AË0NÀK(%B)ÉmXB±k|(!4_ºS°*¦!¯mÅ!Ft$Id3¹!dnÌ|Hª%IÇv!¤º%{Z^b*Vl[D8jl¶ZIÃ)¬Hµb)¦%Ál¢Ê.K¯[¿6.n½w.q!A°}¢0y·GJCt,5m9,n.!YlF_,sluax!}(¯ÇP,dI4vÆeoÉ|p)K´¯*Î0NÀK¢$¯(ËKZJ·g]b!G³,Pm*¦!ªmÅ¿Ed$Id31!.#=jBpÆHn.·4Ë%%QIÃ(«ÎV9$d%Ì¿@ÇÉB©=¯5t%~½M³#¶ÇI7q0}#¿.J}½°HR#fp!|#³$Ǿ»¥my=hZGZ,pJÆcx½|)|;6ÇjR.*5¹oiZxÉJ³¯*Î0NÀK;$tLv°j%n;!dJGª,"
Data "I#*|!¦#ÅlEB$P¤3D!$$n=6ÇJ7Jdr[U#²³M;#²Kj72HºÁ31N,±mARIE#nt63¡zt%Ç,;IÈl;Ë$dJ2R(9n¥SGp%{£0v!DnÇZG!$D¦[]oBl©ËFh¤aR#7*p%ɯ5ÇÉI·B¦°i$Sh.a!Ålk¿3±f6_#|%ºmid0V!)Z4Z,¨#7B9@l37(33%²¯7$ll.!=£!xJAd)LmO|.7$rl;.*B0]Z2p%8XaJ¬ÌÌ0,D|Qr0pt$x%cFMÆÀO°R¦$ª¢Z7¯s%®È71!Vlx76Â,¾#d¦4t%nOG(({Ä0±!p$CY,BPzR%l3ÍoÁ¿%{K)¯CJ5µobJu:.§J§O0HULN#J%ÍK_!¶ÈEglGx,0m(t!ŨʿDR*wm^J4p5}MÃ.G¤°TB%.!WJEd,»mfd5B6ÂJGl,Âsh·5¢oË¥IpSPlXZ¦mJ²;fO#²KhB.lh:_5V,Äm;Z]E},¯3¦pzªgR2T#7k(a!^#k¿M4:Q¢#7*Ê#Y|m¡|$|37,·°:d²¼!¾7Ix%OiKÁ(³o¸7§ÍJ1!F|5v%V¦¦y)±°°UÅÌ%µ!._!"
Data "$KªºÉa|Î6l"

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

Download source code + compiled exe: Around the Sphere build 2020-09-22.zip


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: 1361
Joined: Jun 04, 2005 9:51

Re: Around the Sphere build 2020-09-15

Postby dafhi » Sep 15, 2020 23:51

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
 
  'sq=1/p->rad                   '' clamp prevents artifact
  'slope=iif(slope<sq,sq,slope)  ''
 
  cone_h=slope*(p->rad+.5)     'pre-inverted aadot imagined as cone \/
  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.rad = .rad + r_expan
    q.slope = .slope / q.rad
    q.col = .col
    q.a = -.5 + 256 * .rad * .rad / (q.rad * q.rad)
    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
      Result(z).x=rad*((Cosay*Cosaz)*dx+(-Cosax*Sinaz+Sinax*Sinay*Cosaz)*dy+(Sinax*Sinaz+Cosax*Sinay*Cosaz)*dz)+centre.x
      result(z).y=rad*((Cosay*Sinaz)*dx+(Cosax*Cosaz+Sinax*Sinay*Sinaz)*dy+(-Sinax*Cosaz+Cosax*Sinay*Sinaz)*dz)+centre.y
      result(z).z=rad*((-Sinay)*dx+(Sinax*Cosay)*dy+(Cosax*Cosay)*dz)+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
  aadot.render_target @buf


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 Any Ptr pImageTxt = Imagecreate(320, 20, 0, 32), imgDataTxt, pImageSphere = CreateGradientSphere(radius, radius, radius, -pi / 8, -pi / 4)
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
  aadot.vie.iris = .002 * eyepoint.z / radius


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).z = 0 '-radius
'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
      aResult(i).z += aadot.vie.iris_z
      aadot.defocus_draw @aResult(i)
      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: 635
Joined: May 05, 2017 19:59
Location: Germany

Re: Around the Sphere build 2020-09-15

Postby UEZ » Sep 16, 2020 6:51

@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: 1361
Joined: Jun 04, 2005 9:51

Re: Around the Sphere build 2020-09-15

Postby dafhi » Sep 17, 2020 4:21

updates: removed FL (focal length)
aadot namespace
UEZ
Posts: 635
Joined: May 05, 2017 19:59
Location: Germany

Re: Around the Sphere build 2020-09-17

Postby UEZ » Sep 17, 2020 12:35

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: 1361
Joined: Jun 04, 2005 9:51

Re: Around the Sphere build 2020-09-17

Postby dafhi » Sep 19, 2020 7:32

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: 635
Joined: May 05, 2017 19:59
Location: Germany

Re: Around the Sphere build 2020-09-22

Postby UEZ » Sep 22, 2020 11: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: 948
Joined: Nov 24, 2011 19:49
Location: France
Contact:

Re: Around the Sphere build 2020-09-22

Postby Roland Chastain » Sep 22, 2020 12:09

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: 635
Joined: May 05, 2017 19:59
Location: Germany

Re: Around the Sphere build 2020-09-22

Postby UEZ » Sep 22, 2020 12:26

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: 6726
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: Around the Sphere build 2020-09-22

Postby dodicat » Sep 22, 2020 13:28

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

Re: Around the Sphere build 2020-09-22

Postby UEZ » Sep 22, 2020 13:36

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

Thanks dodicat for your feedback.

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: 948
Joined: Nov 24, 2011 19:49
Location: France
Contact:

Re: Around the Sphere build 2020-09-22

Postby Roland Chastain » Sep 22, 2020 14:29

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: 635
Joined: May 05, 2017 19:59
Location: Germany

Re: Around the Sphere build 2020-09-22

Postby UEZ » Sep 22, 2020 15:26

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


then please download and try again.

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

Re: Around the Sphere build 2020-09-22

Postby Roland Chastain » Sep 22, 2020 16:02

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: 635
Joined: May 05, 2017 19:59
Location: Germany

Re: Around the Sphere build 2020-09-22

Postby UEZ » Sep 22, 2020 19:26

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.

Return to “Tips and Tricks”

Who is online

Users browsing this forum: No registered users and 5 guests