Easter eggs anybody?

[Carl Gundel]

Mar 30, 2022 16:34:08 GMT -5 tsh73 said:

EDIT fixed upside down thing, moved tile for better view

Interesting color fringing on the letters.  Why do you think that happens?

[tsh73]

It is (whole thing) based on paletted version
as for now, it has lower 16 Qb colors, and upper part provides sky gradient.
Checkered bottom (with shades too) are Qb colors.

Now. I need some tile to test
I did it in Paint (should install something more suited, really)
Colors are picked from default ones - but Paint could likely could change them if I took wrong brush thing.
Letters are drawn in Paint too.
Black letters, They got antialiased (that is, black line - grayish line)

To put that tile into this I need to convert it to QBColors
so I read RGB
(I read from bitmap and I do not see 255 0 0 , so I had to adapt)

and run select case along (approximately)

select case
case R<20 and G<20 and B<20: c=0 'black
case R/2>G and R/2>B: c=4  'if most color is red, I use red QBColor
... (same for green and blue)
case else: c = 6  'because I _know_ there are no more colors but yellow on my picture
end select

Now, obviously some grayish lines dropped till "case else".

[tsh73]

a tile

I found very old PSP (PaintShopPro) salvaged from old computer (folder was named progs.311, go figure)
made 16-color image
created palette from QBcolors (it's just a text file)
loaded that palette
then pasted googled sunflower to that image.
PSP did all the dithering - much better then I could.

Now, I changed checkered BG to this tile and got - this


Up and down of the picture does not fit much.
Probably time to change from paletted image to full color

'https://retrobasic.allbasic.info/index.php?topic=721.0
'converting to JB. Tsh73 Feb 2022

desiredWidth = 320
desiredHeight = 200
'desiredWidth = 640
'desiredHeight = 480
desiredWidth = 400
desiredHeight = 300
gosub [ajustWindow]
UpperLeftX = 1
UpperLeftY = 1

open "rayTrace" for graphics_nsb as #gr
#gr, "trapclose [quit]"
#gr, "home ; down ; posxy x y"
#gr, "fill white"
'x, y give us width, height
scrw = 2*x : scrh = 2*y

' 10 PAPER 0: INK 15: CLS:
dim palette$(255)
gosub [initQBcolors]
for i = 0 to 15: palette$(i)=qb$(i):next
' palette 16,255,255,255:
palette$(16)="255 255 255"
' palette 32,0,192,255:
palette$(32)="0 192 255"
' palette 255,0,0,192:
palette$(255)="0 0 192"
' rainbow 16 to 32:
call rainbow 16, 32
' rainbow 32 to 255
call rainbow 32, 255

dim a(1,1) 'to be redimmed
gosub [readTile]
x0=-0.25:z0=1.6 'tile origin

read spheres
DIM c(spheres,3),r(spheres),q(spheres),cl(4)
w=scrw/2:h=scrh/2:s=0
cl(1)=6:cl(2)=1 'dark yellow, dark blue
'cl(3)=cl(1)+8:cl(4)=cl(2)+8
FOR k=1 TO spheres
READ c1,c2,c3,r
c(k,1)=c1:c(k,2)=c2:c(k,3)=c3
r(k)=r:q(k)=r*r
NEXT k

data 1
DATA 0.3,-0.8,3,0.7

data 6
DATA -0.3,-0.8,3,0.6
DATA 0.9,-1.4,3.5,0.35
data 0.7,-0.45,2.5,0.4
data -0.5,-0.3,1.5,0.15
DATA 1.0,-0.2,1.5,0.1
DATA -0.1,-0.2,1.25,0.2

t0=time$("ms") 'main loop start
FOR i=1 TO scrh
print , i
FOR j=0 TO scrw-1
SCAN 'so we could break it
x=0.3:y=-0.5:z=0:ba=1 'ba=1 is light (+8), 0 is shadow
dx=j-w:dy=h-i:dz=(scrh/480)*600
dd=dx*dx+dy*dy+dz*dz
[recurs]  n=0-(y>=0 OR dy<=0)
IF n=0 THEN s=0-y/dy
FOR k=1 TO spheres
px=c(k,1)-x:py=c(k,2)-y:pz=c(k,3)-z
pp=px*px+py*py+pz*pz
sc=px*dx+py*dy+pz*dz
IF sc<=0 THEN GOTO [continueK]
bb=sc*sc/dd
aa=q(k)-pp+bb
IF aa<=0 THEN GOTO [continueK]
sc=(SQR (bb)-SQR (aa))/SQR (dd)
IF sc<s OR n<0 THEN n=k:s=sc
[continueK]
NEXT k

IF n<0 THEN
'plot ink 16+(dy*dy/dd)*240;j,scrh-i
c = int(16+(dy*dy/dd)*240)
'#gr "color ";c;" ";c;" ";c
if lastCol<>c then 'prevent extra color switching - JB speed-up
#gr "color ";palette$(c)
lastCol=c
end if
#gr "set ";j;" ";scrh-i
goto [continueJ]
end if
dx=dx*s:dy=dy*s:dz=dz*s:dd=dd*s*s
x=x+dx:y=y+dy:z=z+dz
IF n<>0 THEN
nx=x-c(n,1):ny=y-c(n,2):nz=z-c(n,3)
nn=nx*nx+ny*ny+nz*nz
l=2*(dx*nx+dy*ny+dz*nz)/nn
dx=dx-nx*l:dy=dy-ny*l:dz=dz-nz*l
GOTO [recurs] 'really only GOTO
end if
FOR k=1 TO spheres
u=c(k,1)-x
v=c(k,3)-z
IF u*u+v*v<=q(k) THEN
ba=0 'shadow
exit for
end if
NEXT k

ik=a((x mod 1 +(x<0))*100, (z mod 1 +(z<0))*100) '1x1
if ba=0 and ik>8 then ik=ik-8
'plot ink ik;j,scrh-i
'#gr "color ";ik;" ";ik;" ";ik
if lastCol<>ik then 'prevent extra color switching
#gr "color ";palette$(ik)
lastCol=ik
end if
#gr "set ";j;" ";scrh-i
[continueJ]
NEXT j
NEXT i
' 210 print at 0,0;transparent 1;ink 0;"Time: ";(msecs-t)/1000;" secs":
' pause 0:

#gr, "flush"
print "Time: ";(time$("ms")-t0)/1000;" secs"
wait

'====================
[quit]
   close #gr
   end

[ajustWindow]
' this code demonstrates ajusting window height, width to get desired drawing space (like, 400x300)
   WindowWidth = 200   '100 seems to be too much - works different
   WindowHeight = 100
   open "Ajusting..." for graphics_nsb as #gr
'   graphics
'   graphics_nsb
'   graphics_nsb_nf
   #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
   WindowWidth = desiredWidth + slackX
   WindowHeight = desiredHeight + slackY
return

[initQBcolors]
dim qb$(15) 'thanks Andy Amaya
qb$( 0) = "  0   0   0" 'black
qb$( 1) = "  0   0 128" 'blue
qb$( 2) = "  8 128   8" 'green
qb$( 3) = "  0 128 128" 'cyan
qb$( 4) = "128   0   0" 'red
qb$( 5) = "128   0 128" 'magenta
qb$( 6) = "128  64  32" 'brown
qb$( 7) = "168 168 168" 'white
qb$( 8) = "128 128 128" 'grey
qb$( 9) = " 84  84 252" 'light blue
qb$(10) = " 42 252  42" 'light green
qb$(11) = "  0 220 220" 'light cyan
qb$(12) = "255   0   0" 'light red
qb$(13) = "255  84 255" 'light magenta
qb$(14) = "255 255   0" 'yellow
qb$(15) = "255 255 255" 'bright white
return

sub rainbow startIdx, stopIdx
r0=val(word$(palette$(startIdx),1))
r1=val(word$(palette$(stopIdx),1))
g0=val(word$(palette$(startIdx),2))
g1=val(word$(palette$(stopIdx),2))
b0=val(word$(palette$(startIdx),3))
b1=val(word$(palette$(stopIdx),3))
for i = startIdx+1 to stopIdx-1
a=1-(stopIdx-i)/(stopIdx-startIdx)   'startIdx..stopIdx -> 0..1
R=int(r0*(1-a) + r1*a)
G=int(g0*(1-a) + g1*a)
B=int(b0*(1-a) + b1*a)
palette$(i)=R;" ";G;" ";B
next
end sub

[readTile]
fname$="tile0.bmp"
fname$="tile1.bmp"

call GetBmpDimensions fname$,  width,  height
print width,  height
redim a(width,  height)

dim qbR(15), qbG(15), qbB(15)
for i = 0 to 15
qbR(i)=val(word$(qb$(i),1))
qbG(i)=val(word$(qb$(i),2))
qbB(i)=val(word$(qb$(i),3))
next

print "reading tile..."
open fname$ for input as #1
ll=lof(#1)
seek #1, 54
'for j = height-1 to 0 step -1 'as bitmap stored
for j = 0 to height-1 'but I happen to need it upside down
for i = 0 to width-1
a$=input$(#1, 3)

R=asc(mid$(a$,3,1))
G=asc(mid$(a$,2,1))
B=asc(mid$(a$,1,1))
for c = 0 to 15
if max(max(abs(qbR(c)-R), abs(qbG(c)-G)), abs(qbB(c)-B))<10 then a(i,j)=c: exit for
next
next
next
close #1

print " tile read!"

return

sub GetBmpDimensions fileName$, byref width, byref height
   open fileName$ for input as #gbd
   temp$ = input$(#gbd, 24)
   close #gbd
   width = asc(mid$(temp$, 19, 1))+asc(mid$(temp$, 20, 1))*256
   height = asc(mid$(temp$, 23, 1))+asc(mid$(temp$, 24, 1))*256
end sub

[bplus]

Wow very impressive! Nice work tsh73

[tsh73]

Ok I spent some more time and put it all together.
Sunflower tile - -
but of course you can use any 100x100 bitmap!
(I saved it via Paint to made it 24bpp, BGR bytes from position 54, program just reads it in)
and now - done that uses full color tiles (well, I omit shadow under spheres)
and B+ egg shape.


BTW in the code there are DATA segments for 1 big sphere or 6 smaller ones. If you comment previous segment out next segment will work!
'https://retrobasic.allbasic.info/index.php?topic=721.0
'converting to JB. Tsh73 Feb/Mar/Apr 2022

'full color bg (+ some shading)
'+egg shape by B+

desiredWidth = 320
desiredHeight = 200
'desiredWidth = 640
'desiredHeight = 480
' desiredWidth = 400
' desiredHeight = 300
gosub [ajustWindow]
UpperLeftX = 1
UpperLeftY = 1

open "rayTrace" for graphics_nsb as #gr
#gr, "trapclose [quit]"
#gr, "home ; down ; posxy x y"
#gr, "fill white"
'x, y give us width, height
scrw = 2*x : scrh = 2*y

' 10 PAPER 0: INK 15: CLS:
dim palette$(255)
gosub [initQBcolors]
for i = 0 to 15: palette$(i)=qb$(i):next
' palette 16,255,255,255:
palette$(16)="255 255 255"
' palette 32,0,192,255:
palette$(32)="0 192 255"
' palette 255,0,0,192:
palette$(255)="0 0 192"
' rainbow 16 to 32:
call rainbow 16, 32
' rainbow 32 to 255
call rainbow 32, 255

dim a$(1,1) 'to be redimmed
gosub [readTile]
'x0=-0.25:z0=1.6 'tile origin

read spheres
DIM c(spheres,3),r(spheres),q(spheres),cl(4)
w=scrw/2:h=scrh/2:s=0
FOR k=1 TO spheres
READ c1,c2,c3,r
c(k,1)=c1:c(k,2)=c2:c(k,3)=c3
r(k)=r:q(k)=r*r
NEXT k

'''49 spheres making a smooth egg shape
data 49
data -0.15,-0.6,1.5,0.1838116
data -0.13732143,-0.6,1.5,0.19432986
data -0.12464286,-0.6,1.5,0.20467506
data -0.11196429,-0.6,1.5,0.21483802
data -0.99285714e-1,-0.6,1.5,0.22480967
data -0.86607143e-1,-0.6,1.5,0.23458114
data -0.73928571e-1,-0.6,1.5,0.24414373
data -0.06125,-0.6,1.5,0.25348892
data -0.48571429e-1,-0.6,1.5,0.26260839
data -0.35892857e-1,-0.6,1.5,0.27149402
data -0.23214286e-1,-0.6,1.5,0.2801379
data -0.10535714e-1,-0.6,1.5,0.28853232
data 0.21428571e-2,-0.6,1.5,0.29666983
data 0.14821429e-1,-0.6,1.5,0.30454316
data 0.0275,-0.6,1.5,0.31214531
data 0.40178571e-1,-0.6,1.5,0.31946951
data 0.52857143e-1,-0.6,1.5,0.32650924
data 0.65535714e-1,-0.6,1.5,0.33325823
data 0.78214286e-1,-0.6,1.5,0.33971047
data 0.90892857e-1,-0.6,1.5,0.34586021
data 0.10357143,-0.6,1.5,0.35170198
data 0.11625,-0.6,1.5,0.35723058
data 0.12892857,-0.6,1.5,0.36244108
data 0.14160714,-0.6,1.5,0.36732884
data 0.15428571,-0.6,1.5,0.37188951
data 0.16696429,-0.6,1.5,0.37611904
data 0.17964286,-0.6,1.5,0.38001365
data 0.19232143,-0.6,1.5,0.38356987
data 0.205,-0.6,1.5,0.38678454
data 0.21767857,-0.6,1.5,0.38965481
data 0.23035714,-0.6,1.5,0.3921781
data 0.24303571,-0.6,1.5,0.39435217
data 0.25571429,-0.6,1.5,0.3961751
data 0.26839286,-0.6,1.5,0.39764525
data 0.28107143,-0.6,1.5,0.39876131
data 0.29375,-0.6,1.5,0.3995223
data 0.30642857,-0.6,1.5,0.39992753
data 0.31910714,-0.6,1.5,0.39997665
data 0.33178571,-0.6,1.5,0.3996696
data 0.34446429,-0.6,1.5,0.39900667
data 0.35714286,-0.6,1.5,0.39798844
data 0.36982143,-0.6,1.5,0.39661583
data 0.3825,-0.6,1.5,0.39489004
data 0.39517857,-0.6,1.5,0.39281263
data 0.40785714,-0.6,1.5,0.39038543
data 0.42053571,-0.6,1.5,0.38761061
data 0.43321429,-0.6,1.5,0.38449065
data 0.44589286,-0.6,1.5,0.38102832
data 0.45857143,-0.6,1.5,0.37722669

'''single big sphere
data 1
DATA 0.3,-0.8,3,0.7

'''src 6 spheres
data 6
DATA -0.3,-0.8,3,0.6
DATA 0.9,-1.4,3.5,0.35
data 0.7,-0.45,2.5,0.4
data -0.5,-0.3,1.5,0.15
DATA 1.0,-0.2,1.5,0.1
DATA -0.1,-0.2,1.25,0.2

shadeFactor = .5 'actually feels ok

t0=time$("ms") 'main loop start
FOR i=1 TO scrh
print , i
FOR j=0 TO scrw-1
SCAN 'so we could break it
x=0.3:y=-0.5:z=0:ba=1 'ba=1 is light, 0 is shadow
'- not used with fullColor BG (unless you write color darker procedure)
dx=j-w:dy=h-i:dz=(scrh/480)*600
dd=dx*dx+dy*dy+dz*dz
[recurs]  n=0-(y>=0 OR dy<=0)
IF n=0 THEN s=0-y/dy
FOR k=1 TO spheres
px=c(k,1)-x:py=c(k,2)-y:pz=c(k,3)-z
pp=px*px+py*py+pz*pz
sc=px*dx+py*dy+pz*dz
IF sc<=0 THEN GOTO [continueK]
bb=sc*sc/dd
aa=q(k)-pp+bb
IF aa<=0 THEN GOTO [continueK]
sc=(SQR (bb)-SQR (aa))/SQR (dd)
IF sc<s OR n<0 THEN n=k:s=sc
[continueK]
NEXT k

IF n<0 THEN
c = int(16+(dy*dy/dd)*240)
color$=palette$(c)
if lastCol$<>color$ then 'prevent extra color switching
#gr "color ";color$
lastCol$=color$
end if

#gr "set ";j;" ";scrh-i
goto [continueJ]
end if
dx=dx*s:dy=dy*s:dz=dz*s:dd=dd*s*s
x=x+dx:y=y+dy:z=z+dz
IF n<>0 THEN
nx=x-c(n,1):ny=y-c(n,2):nz=z-c(n,3)
nn=nx*nx+ny*ny+nz*nz
l=2*(dx*nx+dy*ny+dz*nz)/nn
dx=dx-nx*l:dy=dy-ny*l:dz=dz-nz*l
GOTO [recurs] 'really only GOTO
end if
''shading
FOR k=1 TO spheres
u=c(k,1)-x
v=c(k,3)-z
IF u*u+v*v<=q(k) THEN
ba=0 'shadow
exit for
end if
NEXT k

xt=(x mod 1 +(x<0))*99.99
yt=(z mod 1 +(z<0))*99.99 '100 out of tile pixels
color$=a$(xt, yt) '1x1
if ba=0 then
R=val(word$(color$,1))
G=val(word$(color$,2))
B=val(word$(color$,3))
color$ = int(R*shadeFactor);" ";int(G*shadeFactor);" ";int(B*shadeFactor)
end if
if lastCol$<>color$ then 'prevent extra color switching
#gr "color ";color$
lastCol$=color$
end if
#gr "set ";j;" ";scrh-i
[continueJ]
NEXT j
#gr,  "discard"
NEXT i

#gr, "getbmp  bmp 0 0 ";desiredWidth;" ";desiredHeight
#gr, "drawbmp bmp 0 0"
#gr, "flush"
print "Time: ";(time$("ms")-t0)/1000;" secs"
wait

'====================
[quit]
   close #gr
   end

[ajustWindow]
' this code demonstrates ajusting window height, width to get desired drawing space (like, 400x300)
   WindowWidth = 200   '100 seems to be too much - works different
   WindowHeight = 100
   open "Ajusting..." for graphics_nsb as #gr
'   graphics
'   graphics_nsb
'   graphics_nsb_nf
   #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
   WindowWidth = desiredWidth + slackX
   WindowHeight = desiredHeight + slackY
return

[initQBcolors]
dim qb$(15) 'thanks Andy Amaya
qb$( 0) = "  0   0   0" 'black
qb$( 1) = "  0   0 128" 'blue
qb$( 2) = "  8 128   8" 'green
qb$( 3) = "  0 128 128" 'cyan
qb$( 4) = "128   0   0" 'red
qb$( 5) = "128   0 128" 'magenta
qb$( 6) = "128  64  32" 'brown
qb$( 7) = "168 168 168" 'white
qb$( 8) = "128 128 128" 'grey
qb$( 9) = " 84  84 252" 'light blue
qb$(10) = " 42 252  42" 'light green
qb$(11) = "  0 220 220" 'light cyan
qb$(12) = "255   0   0" 'light red
qb$(13) = "255  84 255" 'light magenta
qb$(14) = "255 255   0" 'yellow
qb$(15) = "255 255 255" 'bright white
return

sub rainbow startIdx, stopIdx
r0=val(word$(palette$(startIdx),1))
r1=val(word$(palette$(stopIdx),1))
g0=val(word$(palette$(startIdx),2))
g1=val(word$(palette$(stopIdx),2))
b0=val(word$(palette$(startIdx),3))
b1=val(word$(palette$(stopIdx),3))
for i = startIdx+1 to stopIdx-1
a=1-(stopIdx-i)/(stopIdx-startIdx)   'startIdx..stopIdx -> 0..1
R=int(r0*(1-a) + r1*a)
G=int(g0*(1-a) + g1*a)
B=int(b0*(1-a) + b1*a)
palette$(i)=R;" ";G;" ";B
next
end sub

[readTile]
' fname$="tile0.bmp"
' fname$="tile1.bmp"
fname$="tile2.bmp"

er$=ckhTile$(fname$)
   if er$<>"" then
print tab(3);er$
print
print "Program needs 100x100 BMP file 24 bit per pixel"
print "Open your picture in Paint and Save As 24 bit BMP file"
print
input "-=* press Enter to quit *=-"; dummy$
goto [quit]
else
call GetBmpDimensions fname$, width, height
if width<>100 or height<>100 then print "supposed to get 100x100, got ";width;"x";height;" instead"
end if

redim a$(width,  height)

print "reading tile..."
open fname$ for input as #1
ll=lof(#1)
seek #1, 54
'for j = height-1 to 0 step -1 'as bitmap stored
for j = 0 to height-1 'but I happen to need it upside down
for i = 0 to width-1
a$=input$(#1, 3)
R=asc(mid$(a$,3,1))
G=asc(mid$(a$,2,1))
B=asc(mid$(a$,1,1))
a$(i,j)=R;" ";G;" ";B
next
next
close #1

print " tile read!"

return

sub GetBmpDimensions fileName$, byref width, byref height
   open fileName$ for input as #gbd
   temp$ = input$(#gbd, 24)
   close #gbd
   width = asc(mid$(temp$, 19, 1))+asc(mid$(temp$, 20, 1))*256
   height = asc(mid$(temp$, 23, 1))+asc(mid$(temp$, 24, 1))*256
end sub

function toReadable$(a$)
   b$=""
   for i = 1 to len(a$)
       c=asc(mid$(a$,i,1))
       if c>32 and c <128 then b$=b$+mid$(a$,i,1) else b$=b$+"."
   next
   toReadable$=b$
end function

function ckhTile$(fileName$)
   'returns error message
   open fileName$ for input as #gbd
   temp$ = input$(#gbd, 54)
   close #gbd
   if left$(temp$,2)<>"BM" then
ckhTile$="Not a valid BMP file, check first 10 bytes: " _
+toReadable$(left$(temp$,10))
exit function
end if
   bpp = asc(mid$(temp$, 29, 1))+asc(mid$(temp$, 30, 1))*256
   if bpp<>24 then ckhTile$="Expected 24 bpp BMP, got ";bpp
end function


[bplus]

Well that's even better! Never would have guessed you could get so far.

[Carl Gundel]

Apr 1, 2022 12:24:36 GMT -5 bplus said:

Well that's even better! Never would have guessed you could get so far.

Yeah, very Easter-ish.  ;P  Does it work if you add a couple of simple spheres back in?

[tsh73]

added shading.
Read a few posts on HSL, gamma correction, whatever
Just did R/2, G/2, B/2 for shading

(code above changed to add shadow)
for Carl:
as I said,

BTW in the code there are DATA segments for 1 big sphere or 6 smaller ones. If you comment previous segment out next segment will work!

I really have to stop

[bplus]

Just keeps getting better! Shading, spheres and Egg!

A word of warning, you will have to convert the tile files to 24 bit BMP to get the code versions using them to work.

After save image download from here, just use Paint and save files AS tile1.bmp and tile2.bmp and use 24-bit option.

[tsh73]

Changed code so it checks bitmap is of the right format
So you see
 Not a valid BMP file, check first 10 bytes: .PNG......

Program needs 100x100 BMP file 24 bit per pixel
Open your picture in Paint and Save As 24 bit BMP file

-=* press Enter to quit *=-