256 Color Star Field

[Rod]

Over on the Facebook page there has been a post about a 256 color starfield demo coded in QB. I think that's a challenge to us. This is a nice simple starfield posted by Stefan. It is in black and white and not a sprite in sight. The challenge would be to get it showing 256 color blobs that get brighter and larger as they near the centre.


Sprites are pixel perfect but you might experiment with shaded masks or mesh masks. Its an adventure, sprites are not a necessity, code what you think looks good.

' Starfield Simulation Demo
'
' You may use and abuse this code in any kind, without any warranty
'
' Revision History
' ----------------
'
' Date        | Name         | Reason
' ------------|--------------|--------------------------
' 06.Jan.2005 | Stefan Pendl | Initial

   nomainwin

   global xCenter, yCenter, velocity

   stars = 100
   velocity = 2
   turns = 100
   eraseStars = 1 ' set this to zero to get straight lines for the starpathes

   if not(eraseStars) then velocity = 1

   dim starPos(stars, 4) ' 1 ... xPos
                        ' 2 ... yPos
                        ' 3 ... xDelta
                        ' 4 ... yDelta

   WindowWidth = 800
   WindowHeight = 600
   UpperLeftX = int((DisplayWidth - WindowWidth) / 2)
   UpperLeftY = int((DisplayHeight - WindowHeight) / 2)

   open "Starfield Simulation Demo" for graphics_nf_nsb as #main
   #main "trapclose [quit]"
   #main "down;fill black;flush"
   #main "color white;backcolor black"
   #main "home;posxy xCenter yCenter"

' get the areas for the 3D effect
   xPos1 = xCenter / 3
   xPos2 = xPos1 * 2
   yPos1 = yCenter / 3
   yPos2 = yPos1 * 2

   xMin1 = xCenter - xPos1
   xMax1 = xCenter + xPos1
   xMin2 = xCenter - xPos2
   xMax2 = xCenter + xPos2

   yMin1 = yCenter - yPos1
   yMax1 = yCenter + yPos1
   yMin2 = yCenter - yPos2
   yMax2 = yCenter + yPos2

' create the initial starfield
   for num = 1 to stars
       call SetStar num
       #main "set "; starPos(num, 1); " "; starPos(num, 2)
   next

' simulate a starflight
   while count < turns
       for num = 1 to stars

' erase old stars, using the biggest pen size used
           #main "discard;color black;size 3"
           if eraseStars then #main "set "; starPos(num, 1); " "; starPos(num, 2)

' calculate the new position
           starPos(num, 1) = starPos(num, 1) + starPos(num, 3)
           starPos(num, 2) = starPos(num, 2) + starPos(num, 4)

' init a new star if one is leaving the screen
           if starPos(num, 1) < 0 or starPos(num, 1) > WindowWidth or _
               starPos(num, 2) < 0 or starPos(num, 2) > WindowHeight then
               call SetStar num
           end if

' select pen depending on distance from center
           pen = 1

           select case
               case starPos(num, 1) < xMin2 or _
                    starPos(num, 1) > xMax2 or _
                    starPos(num, 2) < yMin2 or _
                    starPos(num, 2) > yMax2
                       pen = 3
               case starPos(num, 1) < xMin1 or _
                    starPos(num, 1) > xMax1 or _
                    starPos(num, 2) < yMin1 or _
                    starPos(num, 2) > yMax1
                       pen = 2
           end select

           #main "color white;size "; pen
           #main "set "; starPos(num, 1); " "; starPos(num, 2)
       next
       count = count + 1
   wend

   wait

[quit]
   close #main
   end

sub SetStar num
' set x and y position
   starPos(num, 1) = int(rnd(0)*WindowWidth)
   starPos(num, 2) = int(rnd(0)*WindowHeight)

' calculate relation between x and y
   starPos(num, 3) = abs((starPos(num, 1) - xCenter) / (starPos(num, 2) - yCenter + .001)) * velocity
   starPos(num, 4) = abs((starPos(num, 2) - yCenter) / (starPos(num, 1) - xCenter + .001)) * velocity

   if starPos(num, 1) < xCenter then starPos(num, 3) = -1 * starPos(num, 3)
   if starPos(num, 2) < yCenter then starPos(num, 4) = -1 * starPos(num, 4)
end sub


[Rod]

Well first effort, its actually 24bit color but there are some artefacts, its not really gaseous blobs. The screen should say "press any key to quit"

   nomainwin
   WindowWidth=DisplayWidth
   WindowHeight=DisplayHeight
   graphicbox #1.g 0,0,DisplayWidth,DisplayHeight
   open "" for window_popup as #1
   #1.g "when characterInput [key] ; setfocus"

   ' make sprites
   #1.g "down ; backcolor white ; color white"
   #1.g "place 0 0 ; boxfilled 64 64"
   #1.g "place 32 32 ; size 2"

   #1.g "backcolor black ; circlefilled 32"

   'for n= 0 to 255
   '#1.g "color ";n;" ";n;" ";n
   '#1.g "circle ";n/8
   'next n

   for m= 1 to 100
       r=int(rnd(0)*256)
       g=int(rnd(0)*256)
       b=int(rnd(0)*256)
       rr=r/256
       gg=g/256
       bb=b/256
       #1.g "size 1"
       #1.g "backcolor black ; color black"
       #1.g "place 0 64 ; boxfilled 64 128"
       #1.g "place 32 96 ; size 2"
       for n= 0 to 255
           #1.g "color ";r;" ";g;" ";b
           #1.g "circle ";n/8
           r=r-rr
           g=g-gg
           b=b-bb
       next n
       #1.g "getbmp b";m;" 0 0 64 128"
       #1.g "addsprite s";m;" b";m
   next

   #1.g "fill black"
   #1.g "getbmp bg 0 0 600 600"
   #1.g "background bg"
   dim starPos(100, 5) 'x,y,dx,dy,dz
   x=1
   y=2
   dx=3
   dy=4
   dz=5
   #1.g "home ; posxy midX midY"
   for n = 1 to 100
       starPos(n,x)=midX
       starPos(n,y)=midY
       starPos(n,z)=0
       starPos(n,dx)=20-rnd(0)*80+20
       starPos(n,dy)=10-rnd(0)*40+10
       starPos(n,dz)=rnd(0)*20+2
   next

   [draw]
   timer 0

   ' draw the sprite
   #1.g "drawsprites"

   for n=1 to 100
       starPos(n,x)=starPos(n,x)+starPos(n,dx)
       starPos(n,y)=starPos(n,y)+starPos(n,dy)
       starPos(n,z)=starPos(n,z)+starPos(n,dz)
       if starPos(n,z)>400 then
           starPos(n,x)=midX
           starPos(n,y)=midY
           starPos(n,z)=20
           starPos(n,dx)=20-rnd(0)*80+20
           starPos(n,dy)=10-rnd(0)*40+10
           starPos(n,dz)=rnd(0)*20+2
       end if
       #1.g "spritescale s";n;" ";starPos(n,z)
       #1.g "spritexy s";n;" ";starPos(n,x);" ";starPos(n,y)
   next
   timer 50,[draw]
   wait


   [key]
   'drop to quit

   [quit]
   timer 0
   close #1
   end


[Carl Gundel]

Feb 13, 2020 11:01:02 GMT -5 Rod said:

Well first effort, its actually 24bit color but there are some artefacts, its not really gaseous blobs. The screen should say "press any key to quit"

Cool.

[tsh73]

I've seen some youtube video where pal is coding in what seems QBASIC then runs that.

www.youtube.com/watch?v=VL0oGct1S4Q

Is there QBASIC code available somewhere?
Because it's, well, really different.

---

EDIT from Youtube comment:

[SPOILERS BELOW]
Disclaimer: The story behind this video is a fabrication to justify the fact that the code is too complex for QuickBASIC to run, and too heavy for today's computers even if translated to C, unless run on a multicore CPU. All the technical details are absolutely correct. I did indeed write the first revisions of this program in QB, but I then translated it to C++, with which I created the actual animations after refining the code a bit, and I backported the changes to QB to show how it _would_ be done, did QB not have those limits. The reason why it is slow is not because of dithering, but because of the really ineffective algorithm for rendering stars, dithering or not; what with doing some 25000 distance calculations tests _per pixel_.
[END SPOILERS]

...

Note: In this video, I used a copy of actual QuickBASIC 4.5 by Microsoft... well, Megasoft Corp. However, after creating and publishing this video, I discovered QB64, a modern free port of QB. I ported this program to QB64! It works, though minor changes. Here is a link to the QB64 version's source code: bisqwit.iki.fi/jutut/kuvat/programming_examples/sfield_qb64.bas
Note that it still requires computers from a parallel universe to run smoothly...

So it seems it can't actually run in QBasic
so I suppose it couldn't run in LB as is (on same math), because QB was faster last time I tried it.

Or is it some other version and there is indeed native QBASIC code which actually runs?

[Rod]

I’m not done yet. I have some ideas about dithering sprites. But of course it is never going to be pixel level dithering. I have no real interest in the QB Code, it always amazes me that so many folks spend so much time on ancient systems. I understand the nostalgia bit but they all have so many restrictions.

[Rod]

This version has nicer orb sprites. I knew the spritescale command was taking up most of the processing time but I did not realise just how much! This version is free running and has no scaling, just to let you see the difference. Unrem the spritescale command line to get the old display back.

Now I am thinking that I should have pre sized sprites instead of scaling on the fly. But I also intend to try dithered cloud sprites that may or may not rotate. Programming is such a joy!


   nomainwin
   WindowWidth=DisplayWidth
   WindowHeight=DisplayHeight
   graphicbox #1.g 0,0,DisplayWidth,DisplayHeight
   open "" for window_popup as #1
   #1.g "when characterInput [key] ; setfocus"


   ' make sprites
   #1.g "down ; backcolor white ; color white"
   #1.g "place 0 0 ; boxfilled 64 64"
   #1.g "place 32 32 ; size 2"

   #1.g "backcolor black ; circlefilled 32"

   'the real challenge, how to make dithered
   'nebulous cloud like sprites instead of orbs
   'also plan to rotate the clouds


   for m= 1 to 100
       'random 24 bit color choice
       r=int(rnd(0)*256)
       g=int(rnd(0)*256)
       b=int(rnd(0)*256)
       'color fades from centre but not to 0
       rr=r/300
       gg=g/300
       bb=b/300

       #1.g "size 1"
       #1.g "backcolor black ; color black"
       #1.g "place 0 64 ; boxfilled 64 128"
       #1.g "place 32 96 ; size 2"
       'draw an ever increasing circle with decreasing color
       for n= 8 to 255
           #1.g "color ";r;" ";g;" ";b
           #1.g "circle ";n/8
           r=r-rr
           g=g-gg
           b=b-bb
       next n
       #1.g "getbmp b";m;" 0 0 64 128"
       #1.g "addsprite s";m;" b";m
   next

   #1.g "fill black"
   #1.g "getbmp bg 0 0 600 600"
   #1.g "background bg"

   'position 100 sprites
   dim starPos(100, 5) 'x,y,dx,dy,dz
   x=1
   y=2
   dx=3
   dy=4
   dz=5
   #1.g "home ; posxy midX midY"
   midX=midX-32
   midY=midY-32
   for n = 1 to 100
       starPos(n,x)=midX
       starPos(n,y)=midY
       starPos(n,z)=100
       starPos(n,dx)=20-rnd(0)*80+20
       starPos(n,dy)=10-rnd(0)*40+10
       starPos(n,dz)=rnd(0)*10+2
   next

   while 1
       scan
       #1.g "drawsprites"

       'move the sprites
       for n=1 to 100
           starPos(n,x)=starPos(n,x)+starPos(n,dx)
           starPos(n,y)=starPos(n,y)+starPos(n,dy)
           starPos(n,z)=starPos(n,z)+starPos(n,dz)
           'start the sprite again if it is over the limit
           if starPos(n,z)>200 then
               starPos(n,x)=midX
               starPos(n,y)=midY
               starPos(n,z)=100
               starPos(n,dx)=20-rnd(0)*80+20
               starPos(n,dy)=10-rnd(0)*40+10
               starPos(n,dz)=rnd(0)*10+2
           end if

           'scale the sprites, takes time!
           '#1.g "spritescale s";n;" ";starPos(n,z)
           #1.g "spritexy s";n;" ";starPos(n,x);" ";starPos(n,y)
       next
   wend




   [key]
   'drop to quit

   [quit]
   timer 0
   close #1
   end



[tsh73]

semitransparent sprites make some weird mixups
   nomainwin
   WindowWidth=DisplayWidth
   WindowHeight=DisplayHeight
   graphicbox #1.g 0,0,DisplayWidth,DisplayHeight
   open "" for window_popup as #1
   #1.g "when characterInput [key] ; setfocus"


   ' make sprites
   #1.g "down ; backcolor white ; color white"
   #1.g "place 0 0 ; boxfilled 64 64"
   #1.g "place 32 32 ; size 2"

   #1.g "backcolor black ; circlefilled 32"

   'the real challenge, how to make dithered
   'nebulous cloud like sprites instead of orbs
   'also plan to rotate the clouds

N=30
'N=100

   for m= 1 to N
       'random 24 bit color choice
       r=int(rnd(0)*256)
       g=int(rnd(0)*256)
       b=int(rnd(0)*256)
       'color fades from centre but not to 0
       rr=r/300
       gg=g/300
       bb=b/300

       #1.g "size 1"
       #1.g "backcolor black ; color black"
       #1.g "place 0 64 ; boxfilled 64 128"
       #1.g "size 2"
       'draw an ever increasing circle with decreasing color
       for n= 8 to 255
           #1.g "place 32 96"
           #1.g "color ";r;" ";g;" ";b
           #1.g "circle ";n/8

          #1.g "place 32 32"
          #1.g "color ";n;" ";n;" ";n
          #1.g "circle ";n/8

           r=r-rr
           g=g-gg
           b=b-bb
       next n

       #1.g "getbmp b";m;" 0 0 64 128"
       #1.g "addsprite s";m;" b";m
   next

   #1.g "fill black"
   #1.g "getbmp bg 0 0 600 600"
   #1.g "background bg"

   'position 100 sprites
   dim starPos(100, 7) 'x,y,dx,dy,dz, a, da
   x=1
   y=2
   dx=3
   dy=4
   dz=5
   a=6
   da=7
   #1.g "home ; posxy midX midY"
   midX=midX-32
   midY=midY-32
   for n = 1 to N
       starPos(n,x)=0'midX
'        starPos(n,y)=midY
       starPos(n,z)=66
       starPos(n,dx)=20-rnd(0)*80+20
       starPos(n,dy)=10-rnd(0)*40+10
       starPos(n,dz)=rnd(0)*10+2
       starPos(n,a)=rnd(0)*2*acs(-1)
       starPos(n,da)=(rnd(0)*10-5)/60
   next

   timer 30, [nxt]

   'while 1
   [nxt]
       scan
       #1.g "drawsprites"

       'move the sprites
       for n=1 to N
           starPos(n,x)=starPos(n,x)+starPos(n,dx)
           'starPos(n,y)=starPos(n,y)+starPos(n,dy)
           starPos(n,z)=starPos(n,z)+starPos(n,dz)
           starPos(n,a)=starPos(n,a)+starPos(n,da)
           'start the sprite again if it is over the limit
           if starPos(n,z)>200 then
               starPos(n,x)=0'midX
               'starPos(n,y)=midY
               starPos(n,z)=66
               starPos(n,dx)=20-rnd(0)*80+20
               'starPos(n,dy)=10-rnd(0)*40+10
               starPos(n,dz)=rnd(0)*10+2
               starPos(n,a)=rnd(0)*2*acs(-1)
               starPos(n,da)=(rnd(0)*10-5)/60
           end if

           'scale the sprites, takes time!
           #1.g "spritescale s";n;" ";int(starPos(n,z))
           #1.g "spritexy s";n;" ";midX+cos(starPos(n,a))*starPos(n,x);" ";midY+sin(starPos(n,a))*starPos(n,x)
'            print "spritexy s";n;" ";midX+cos(starPos(n,a))*starPos(n,x);" ";midY+sin(starPos(n,a))*starPos(n,x)
       next
'    wend

wait


   [key]
   'drop to quit

   [quit]
   timer 0
   close #1
   end



[Rod]

Yes, really ugly overlapping but ok on their own. I was thinking that the mask needs to be black and white and that the mix produced by less than black is not useful. I was thinking it needs to be pixel by pixel mapping. Any color needs a black mask.

I have tried rnd() to form clouds, unrealistic. I have tried Brownian motion to form clouds, slow and painful. I am now going to try sinusoidal x,y,z to decide color and brightness.

If anyone has any ideas now is the time to speak. We need puffy cloud like color blobs.

[Rod]

Now the bubbles come to life. The source moves and the bubbles are mouse aware. Just move the mouse, they will home in on you, the source follows a sinusoidal path but the bubbles follow you!

   nomainwin
   WindowWidth=DisplayWidth
   WindowHeight=DisplayHeight
   graphicbox #1.g 0,0,DisplayWidth,DisplayHeight
   open "" for window_popup as #1
   #1.g "when characterInput [key] ; setfocus"
   #1.g "when mouseMove [mouse]"


   ' make sprites
   #1.g "down ; backcolor white ; color white"
   #1.g "place 0 0 ; boxfilled 64 64"
   #1.g "place 32 32 ; size 2"

   #1.g "backcolor black ; circlefilled 32"

   'the real challenge, how to make dithered
   'nebulous cloud like sprites instead of orbs
   'also plan to rotate the clouds


   for m= 1 to 100
       'random 24 bit color choice
       r=int(rnd(0)*256)
       g=int(rnd(0)*256)
       b=int(rnd(0)*256)
       'color fades from centre but not to 0
       rr=r/300
       gg=g/300
       bb=b/300

       #1.g "size 1"
       #1.g "backcolor black ; color black"
       #1.g "place 0 64 ; boxfilled 64 128"
       #1.g "place 32 96 ; size 2"
       'draw an ever increasing circle with decreasing color
       for n= 8 to 255
           #1.g "color ";r;" ";g;" ";b
           #1.g "circle ";n/8
           r=r-rr
           g=g-gg
           b=b-bb
       next n
       #1.g "getbmp b";m;" 0 0 64 128"
       #1.g "addsprite s";m;" b";m
   next

   #1.g "fill black"
   #1.g "getbmp bg 0 0 600 600"
   #1.g "background bg"

   'position 100 sprites
   dim starPos(100, 5) 'x,y,dx,dy,dz
   x=1
   y=2
   dx=3
   dy=4
   dz=5
   #1.g "home ; posxy midX midY"
   midX=midX-32
   midY=midY-32
   for n = 1 to 100
       starPos(n,x)=midX
       starPos(n,y)=midY
       starPos(n,z)=100
       starPos(n,dx)=20-rnd(0)*80+20
       starPos(n,dy)=10-rnd(0)*40+10
       starPos(n,dz)=rnd(0)*10+2
   next




   xdelta=rnd(0)*4
   ydelta=rnd(0)*4

   degreex=180
   degreey=270

   d=DisplayHeight/3

   [draw]
       scan
       #1.g "drawsprites"

       xx=Int((sin(degreex/57.29577951)*d)+midX)
       degreex=degreex+xdelta
       if degreex>359 then degreex=0 : xdelta=rnd(0)*4

       yy=Int((sin(degreey/57.29577951)*d)+midY)
       degreey=degreey+ydelta
       if degreey>359 then degreey=0 : ydelta=rnd(0)*4

       'move the sprites
       for n=1 to 100
           starPos(n,x)=starPos(n,x)+starPos(n,dx)+(XX-starPos(n,x))/10
           starPos(n,y)=starPos(n,y)+starPos(n,dy)+(YY-starPos(n,y))/10
           starPos(n,z)=starPos(n,z)+starPos(n,dz)
           'start the sprite again if it is over the limit
           if starPos(n,z)>200 then
               starPos(n,x)=xx
               starPos(n,y)=yy
               starPos(n,z)=100
               starPos(n,dx)=20-rnd(0)*80+20
               starPos(n,dy)=10-rnd(0)*40+10
               starPos(n,dz)=rnd(0)*10+2
           end if

           'scale the sprites, takes time!
           #1.g "spritescale s";n;" ";starPos(n,z)
           #1.g "spritexy s";n;" ";starPos(n,x);" ";starPos(n,y)
       next
   goto [draw]

   [mouse]
   XX=MouseX
   YY=MouseY
   goto [draw]


   [key]
   'drop to quit

   [quit]
   timer 0
   close #1
   end


[tsh73]

Cool
My kid (age 9) loves it.