Eye Candy #9

[tenochtitlanuk]

Positively hypnotic. I keep coming back to LB graphics..

[tsh73]

I dig up my old palette code and made real-time rotating spiral
If you feel it rotates too slow try up/down buttons ;)


'palette-rotated Triskelion
'based on
'JB plasma demo
'by tsh73, March 2022
'nomainwin

dim PAL$(512)    'colors as text, like "255 100 23"

global MaxX, MaxY, rough, MaxColor
global PAL2BMPstr$

   UpperLeftX = 1
   UpperLeftY = 1
   ' WindowWidth = 512
   ' WindowHeight = 512
   WindowWidth = 256
   WindowHeight = 256

'increase window size so we get our requested size
print "Adjusting window for borders..."
  call adjustWindowSize WindowWidth, WindowHeight
'   print WindowWidth, WindowHeight

  open "Triskelion" for graphics_nsb_nf as #gr
  #gr, "trapclose quit"
  #gr, "home ; down ; posxy cx cy"
  width = 2*cx : height = 2*cy
  'for bitmap width be better dividable by 4
  if width mod 4<>0 then width = width + (4 - width mod 4)
  print "Bitmap ";width;"x";height

   MaxX = width
   MaxY = height    'array size - from screen size
   MaxColor = 255  'number of colors to use
   dim screenBuf(MaxX, MaxY)

   startTime = time$("ms")
   print "Making smooth palette..."
   call Makepalette

print "Drawing..."
pi = ACS(-1)
for x = 0 to MaxX-1
scan 'for being breakable
for y = 0 to MaxY-1
r = sqr((x-cx)^2+(y-cy)^2)
phi = atan2(y-cy,x-cx)+2*pi

Colr=int(1+MaxColor*((phi/2/pi*3-2*r/cx+2) mod 1)) '0..MaxColor, 1+
'print x, y , r, phi, Colr
screenBuf(x, y)=Colr
#gr, "color ";Colr;" " ;Colr;" " ;Colr
#gr, "set ";x;" ";y
next
#gr, "discard"
next

'#gr, "flush"

   print "Time taken 2 : ";time$("ms") - startTime

   startTime = time$("ms")
   call tryToKill "just4header.bmp"
'    easiest way to get right BMP header is to actually save BMP and look header (just change BPP and some other things after)
    #gr, "getbmp drawing 0 0 ";width;" "; height
    bmpsave "drawing", "just4header.bmp"
    unloadbmp("drawing")
'    get header
   open "just4header.bmp" for binary as #1
       size = lof(#1)
       header$ = input$(#1, 53)
   close #1
'    modify header
   'numbers stored hi lo
   '2  4 fileSize                                    = imagebytes + offset
   '10 4 offset                                      1078
   '28 2 BitsPerPixel (bpp)                          8
   '30 4 CompressMethod                              0
   '34 4 imagebytes                                  width*height
   '46 4 ColorsUsed                                  256
   '50 4 ImportantColors                             256
   'all goes +1 because bytes numbered from zero by loc()
   call putNumber header$, 2+1, 4, width*height + 1078
   call putNumber header$, 10+1, 4, 1078
   call putNumber header$, 28+1, 2, 8
   call putNumber header$, 30+1, 4, 0
   call putNumber header$, 34+1, 4, width*height
   call putNumber header$, 46+1, 4, 256
   call putNumber header$, 50+1, 4, 256

'    write image data
   call tryToKill "frame.bmp"  'because JB does not overwrite if BMP is smaller.
   ', and it siglifically slows things down
   open "frame.bmp" for binary as #1
   '    write modif. header
       print  #1, header$; 'Here LBB needs (;)
   '    write palette
       print  #1, mid$(PAL2BMPstr$, 1, 256*4); 'Here LBB needs (;)
   '    write image data
       FOR y = MaxY-1 TO 0 step -1
           aLine$ = ""
           FOR x = 0 TO MaxX-1
aLine$ =  aLine$ + chr$(screenBuf(x,y))
           next
           aLine$ = aLine$ + space$(width-len(aLine$))   'filler by x
print #1, aLine$;   'Here LBB needs (;)
       next

   close #1
   print "Time taken 3 : ";time$("ms") - startTime

#gr, "cls"

   'MAIN LOOP
   tOld = time$("seconds")
   iterOld = 0
dk=1
print "Press Up to increase speed, Down to decrease"
#gr, "when characterInput [key]"
#gr, "setfocus"     'for characterInput to work

   do while 1
       iter=iter+1
       open "frame.bmp" for binary as #1
           seek #1, 54 'palette data
           print  #1, mid$(PAL2BMPstr$, 1+k*4, 256*4);
       close #1
       loadbmp "copyimage", "frame.bmp"
       #gr, "drawbmp copyimage 0 0"
       unloadbmp("copyimage")
       #gr, "discard"
       scan
[loop]
       k = (k+dk+MaxColor) mod MaxColor

       'fps code
       t = time$("seconds")
       if t<>tOld then
           fps = (iter - iterOld)
           locate 1, 11 + aLine mod 10
           print n,d,"Time taken: ";tt ;" fps: "; fps
           locate 1, 11 + aLine mod 10 + 1
           print space$(80)
           aLine=aLine+1
           tOld = t
           iterOld = iter
       end if
loop
wait

[key]
keyValue = asc(right$(Inkey$, 1))
if keyValue=_VK_UP then dk=dk+1
if keyValue=_VK_Down then dk=dk-1
if keyValue=_VK_UP or keyValue=_VK_Down  then
locate 1, 11 + aLine mod 10
print "speed now : ";dk
locate 1, 11 + aLine mod 10 + 1
print space$(80)
aLine=aLine+1
end if
goto [loop] 'no wait - no, it stops here

'===========================================
sub quit handle$
  timer 0
  close #handle$
  'clean-up
  call tryClose1
  call tryToKill "frame.bmp"
  call tryToKill "just4header.bmp"
  end
END SUB

'------------------------------------------------------
SUB Makepalette
   PAL2BMPstr$ = ""
   PAL$(0) = "0 0 0"
   FOR c = 1 TO 512
       PAL$(c) = rainbow$(c/MaxColor)
   NEXT
   for i = 0 to 512
       PAL2BMP$ = chr$(val(word$(PAL$(i),3))) _
           + chr$(val(word$(PAL$(i),2))) _
           + chr$(val(word$(PAL$(i),1))) _
           + chr$(0)
       'print i,  PAL2BMP$(i)
       PAL2BMPstr$ = PAL2BMPstr$ + PAL2BMP$
   next
END SUB

'----------------------------------------------------------------
sub adjustWindowSize byref desiredWidth,  byref desiredHeight
' adjust graphics size
   UpperLeftX = 1
   UpperLeftY = 1
   WindowWidth = 200   '100 seems to be too small - works different
   WindowHeight = 100
   open "Ajusting..." for graphics_nsb_nf as #gr
   #gr, "home ; down ; posxy x y"
   'x, y give us width, height
   width = 2*x : height = 2*y
   close #gr

   slackX = 200-width
   slackY = 100-height

   desiredWidth = desiredWidth + slackX
   desiredHeight = desiredHeight + slackY
end sub
'------------------------------------------
sub putNumber byref aStr$, aPos, aLen, value
   tmp$=""
   for i = 1 to aLen
       'tmp$=chr$(value mod 256)+tmp$   'numbers stored hi lo
       tmp$=tmp$+chr$(value mod 256)   'numbers stored lo hi
       value = int(value/256)
   next
   aStr$ = left$(aStr$, aPos-1)+tmp$+mid$(aStr$, aPos+aLen)
end sub
'------------------------------------------
sub tryToKill bmp$
   on error goto [skip]
   kill bmp$
[skip]
end sub

sub tryClose1
   on error goto [skip]
   close #1
[skip]
end sub
'---------------------------
function atan2(y,x)
   pi = acs(-1)    'could be made global to save some ticks
   if x <> 0 then arctan = atn(y/x)

   select case
       case x > 0
       atan2 = arctan

       case y>=0 and x<0
       atan2 = pi + arctan

       case y<0 and x<0
       atan2 = arctan - pi

       case y>0 and x=0
       atan2 = pi / 2

       case y<0 and x=0
       atan2 = pi / -2
   end select
end function
'---------------------------------------------
' 0..1 into red-green-blue-red continuous colors
function rainbow$(x)
   hi = int((x*6) mod 6)+ 5*(x<0)  'fixed to 0..5
   f = (x*6) mod 1 + (x<0)         'frac, 0..1
   q = (1-f)
   select case hi
   case 0
       r = 1: g = f: b = 0
   case 1
       r = q: g = 1: b = 0
   case 2
       r = 0: g = 1: b = f
   case 3
       r = 0: g = q: b = 1
   case 4
       r = f: g = 0: b = 1
   case 5
       r = 1: g = 0: b = q
   end select
   R = int(r*255)
   G = int(g*255)
   B = int(b*255)
   rainbow$= R;" ";G;" ";B
end function


[plus]

Wow, smooth! and I can see the code with no dll's, ;-))

[marshawn]

By JustBasic language philosophy, does a program lower itself an order of magnitude in superiority the second it invokes the atan2 function?

[tsh73]

By JustBasic language philosophy, does a program lower itself an order of magnitude in superiority the second it invokes the atan2 function?

JustBasic language philosophy
You just make it up, do you?

I don't feel bad after using a function I can understand
(and sometimes even if I cannot ;) )

I tried drawing color spiral with polar coords (r,phi), and it was 2x slower and still has a few missing points.
Or I loop exactly at x, y and use atan2.
(of cource it would be even better if atan2 was build-in and work as fast as sin() )

[tsh73]

Just tried to apply same palette thing to "rotated plasma color stick".
It kind of worked.
You can press space to change palette (with graphic window in focus)
Or it will change after circling up and down 3 times.
'palette-rotated Triskelion
'based on
'JB plasma demo
'by tsh73, March 2022
'nomainwin

dim PAL$(512)    'colors as text, like "255 100 23"
global CN, PR, PG, PB 'for BPlus colors

global MaxX, MaxY, rough, MaxColor
global PAL2BMPstr$

   UpperLeftX = 1
   UpperLeftY = 1
   ' WindowWidth = 512
   ' WindowHeight = 512
   ' WindowWidth = 256
   ' WindowHeight = 256
   WindowWidth = 400
   WindowHeight = 400

'increase window size so we get our requested size
print "Adjusting window for borders..."
  call adjustWindowSize WindowWidth, WindowHeight
'   print WindowWidth, WindowHeight

  open "Triskelion" for graphics_nsb_nf as #gr
  #gr, "trapclose quit"
  #gr, "home ; down ; posxy cx cy"
  width = 2*cx : height = 2*cy
  'for bitmap width be better dividable by 4
  if width mod 4<>0 then width = width + (4 - width mod 4)
  print "Bitmap ";width;"x";height

   MaxX = width
   MaxY = height    'array size - from screen size
   MaxColor = 255  'number of colors to use
   dim screenBuf(MaxX, MaxY)

   startTime = time$("ms")
   print "Making smooth palette..."
   call resetPlasma
   call Makepalette

print "Drawing..."
pi = ACS(-1)
for x = 0 to MaxX-1
scan 'for being breakable
for y = 0 to MaxY-1
r = sqr((x-cx)^2+(y-cy)^2)
phi = atan2(y-cy,x-cx)+2*pi

'Colr=int(1+MaxColor*((phi/2/pi*3-2*r/cx+2) mod 1)) '0..MaxColor, 1+
Colr=int(1+MaxColor*((0.5+r/cx+0.5*sin(phi*32)) mod 1)/2) '0..MaxColor, 1+
'print x, y , r, phi, Colr
screenBuf(x, y)=Colr
#gr, "color ";Colr;" " ;Colr;" " ;Colr
#gr, "set ";x;" ";y
next
#gr, "discard"
next

'#gr, "flush"

   print "Time taken 2 : ";time$("ms") - startTime
'wait

   startTime = time$("ms")
   call tryToKill "just4header.bmp"
'    easiest way to get right BMP header is to actually save BMP and look header (just change BPP and some other things after)
    #gr, "getbmp drawing 0 0 ";width;" "; height
    bmpsave "drawing", "just4header.bmp"
    unloadbmp("drawing")
'    get header
   open "just4header.bmp" for binary as #1
       size = lof(#1)
       header$ = input$(#1, 53)
   close #1
'    modify header
   'numbers stored hi lo
   '2  4 fileSize                                    = imagebytes + offset
   '10 4 offset                                      1078
   '28 2 BitsPerPixel (bpp)                          8
   '30 4 CompressMethod                              0
   '34 4 imagebytes                                  width*height
   '46 4 ColorsUsed                                  256
   '50 4 ImportantColors                             256
   'all goes +1 because bytes numbered from zero by loc()
   call putNumber header$, 2+1, 4, width*height + 1078
   call putNumber header$, 10+1, 4, 1078
   call putNumber header$, 28+1, 2, 8
   call putNumber header$, 30+1, 4, 0
   call putNumber header$, 34+1, 4, width*height
   call putNumber header$, 46+1, 4, 256
   call putNumber header$, 50+1, 4, 256

'    write image data
   call tryToKill "frame.bmp"  'because JB does not overwrite if BMP is smaller.
   ', and it siglifically slows things down
   open "frame.bmp" for binary as #1
   '    write modif. header
       print  #1, header$; 'Here LBB needs (;)
   '    write palette
       print  #1, mid$(PAL2BMPstr$, 1, 256*4); 'Here LBB needs (;)
   '    write image data
       FOR y = MaxY-1 TO 0 step -1
           aLine$ = ""
           FOR x = 0 TO MaxX-1
aLine$ =  aLine$ + chr$(screenBuf(x,y))
           next
           aLine$ = aLine$ + space$(width-len(aLine$))   'filler by x
print #1, aLine$;   'Here LBB needs (;)
       next

   close #1
   print "Time taken 3 : ";time$("ms") - startTime

#gr, "cls"

   'MAIN LOOP
   tOld = time$("seconds")
   iterOld = 0
dk=1
print "Press Up to increase speed, Down to decrease"
print "  SPACE to change palette"
#gr, "when characterInput [key]"
#gr, "setfocus"     'for characterInput to work

   do while 1
       iter=iter+1
       open "frame.bmp" for binary as #1
           seek #1, 54 'palette data
           print  #1, mid$(PAL2BMPstr$, 1+k*4, 256*4);
       close #1
       loadbmp "copyimage", "frame.bmp"
       #gr, "drawbmp copyimage 0 0"
       unloadbmp("copyimage")
       #gr, "discard"
       scan
[loop]
       'k = (k+dk+MaxColor) mod MaxColor
k = k+dk
if k+dk >=MaxColor or k+dk <1 then n=n+1: dk=0-dk

if n=6 then
n=0
   call resetPlasma
call Makepalette
end if

       'fps code
       t = time$("seconds")
       if t<>tOld then
           fps = (iter - iterOld)
           locate 1, 11 + aLine mod 10
           print n,d,"Time taken: ";tt ;" fps: "; fps
           locate 1, 11 + aLine mod 10 + 1
           print space$(80)
           aLine=aLine+1
           tOld = t
           iterOld = iter
       end if
loop
wait

[key]
keyValue = asc(right$(Inkey$, 1))
if keyValue=_VK_UP then dk=dk+(dk>=0)
if keyValue=_VK_Down then dk=dk-(dk>=0)
if keyValue=_VK_UP or keyValue=_VK_Down  then
locate 1, 11 + aLine mod 10
print "speed now : ";dk
locate 1, 11 + aLine mod 10 + 1
print space$(80)
aLine=aLine+1
end if
if keyValue=32 then 'space
n=0
dk=1 'reset speed
call resetPlasma
call Makepalette
end if
goto [loop] 'no wait - no, it stops here

'===========================================
sub quit handle$
  timer 0
  close #handle$
  'clean-up
  call tryClose1
  call tryToKill "frame.bmp"
  call tryToKill "just4header.bmp"
  end
END SUB

'------------------------------------------------------
function Plasma$() ' just to put something in as parameter
   CN = CN + .2
   Plasma$ = str$(127 + 127 * Sin(PR * CN)) + " " + str$(127 + 127 * Sin(PG * CN)) + " " + str$(127 + 127 * Sin(PB * CN))
End Function

Sub resetPlasma
   PR = Rnd(0) ^ 2: PG = Rnd(0) ^ 2: PB = Rnd(0) ^ 2
End Sub
'------------------------------------------------------
SUB Makepalette
   PAL2BMPstr$ = ""
   PAL$(0) = "0 0 0"
   FOR c = 1 TO 512
       'PAL$(c) = rainbow$(c/MaxColor)
PAL$(c) = Plasma$()
   NEXT
   for i = 0 to 512
       PAL2BMP$ = chr$(val(word$(PAL$(i),3))) _
           + chr$(val(word$(PAL$(i),2))) _
           + chr$(val(word$(PAL$(i),1))) _
           + chr$(0)
       'print i,  PAL2BMP$(i)
       PAL2BMPstr$ = PAL2BMPstr$ + PAL2BMP$
   next
END SUB

'----------------------------------------------------------------
sub adjustWindowSize byref desiredWidth,  byref desiredHeight
' adjust graphics size
   UpperLeftX = 1
   UpperLeftY = 1
   WindowWidth = 200   '100 seems to be too small - works different
   WindowHeight = 100
   open "Ajusting..." for graphics_nsb_nf as #gr
   #gr, "home ; down ; posxy x y"
   'x, y give us width, height
   width = 2*x : height = 2*y
   close #gr

   slackX = 200-width
   slackY = 100-height

   desiredWidth = desiredWidth + slackX
   desiredHeight = desiredHeight + slackY
end sub
'------------------------------------------
sub putNumber byref aStr$, aPos, aLen, value
   tmp$=""
   for i = 1 to aLen
       'tmp$=chr$(value mod 256)+tmp$   'numbers stored hi lo
       tmp$=tmp$+chr$(value mod 256)   'numbers stored lo hi
       value = int(value/256)
   next
   aStr$ = left$(aStr$, aPos-1)+tmp$+mid$(aStr$, aPos+aLen)
end sub
'------------------------------------------
sub tryToKill bmp$
   on error goto [skip]
   kill bmp$
[skip]
end sub

sub tryClose1
   on error goto [skip]
   close #1
[skip]
end sub
'---------------------------
function atan2(y,x)
   pi = acs(-1)    'could be made global to save some ticks
   if x <> 0 then arctan = atn(y/x)

   select case
       case x > 0
       atan2 = arctan

       case y>=0 and x<0
       atan2 = pi + arctan

       case y<0 and x<0
       atan2 = arctan - pi

       case y>0 and x=0
       atan2 = pi / 2

       case y<0 and x=0
       atan2 = pi / -2
   end select
end function
'---------------------------------------------
' 0..1 into red-green-blue-red continuous colors
function rainbow$(x)
   hi = int((x*6) mod 6)+ 5*(x<0)  'fixed to 0..5
   f = (x*6) mod 1 + (x<0)         'frac, 0..1
   q = (1-f)
   select case hi
   case 0
       r = 1: g = f: b = 0
   case 1
       r = q: g = 1: b = 0
   case 2
       r = 0: g = 1: b = f
   case 3
       r = 0: g = q: b = 1
   case 4
       r = f: g = 0: b = 1
   case 5
       r = 1: g = 0: b = q
   end select
   R = int(r*255)
   G = int(g*255)
   B = int(b*255)
   rainbow$= R;" ";G;" ";B
end function

[tenochtitlanuk]

Very neat way to cycle colours! I'd thought of something similar but not tried it...
Cool...

[plus]

Wow tsh73, nice work! Wow