RetroBASIC
Basicprogramming(.org) => Code and examples => Topic started by: Galileo on February 11, 2017, 11:50:38 AM
-
I love computer generated graphic effects. Usually people get them using special programs, but they can also be achieved with imagination and a simple BASIC interpreter.
// Effect 1
// Developed in Yabasic 2.78.0 by Galileo, 2/2017
// Play with parameters
width = 640 : height = 480
sizeletter = 300 : t$ = "B"
open window width,height
backcolor 0,0,0
clear window
color 1,0,0
text width/2,height/2,t$,"swiss"+str$(sizeletter),"cc"
for y = 0 to height step 5
for x = 0 to width step 5
cpixel$ = getbit$(x,y,x,y)
if cpixel$ = "rgb 1,1:010000" then
cx = x + (2 - int(ran(5))) : cy = y + (2 - int(ran(5)))
cb = 255
for n = 5 to 1 step -1
color cb,cb,cb
circle cx,cy,n
cb = cb / 2
next n
end if
next x
next y
-
Another simple sample:
// Effect 2
// Developed in Yabasic 2.78.0 by Galileo, 2/2017
// Play with parameters
width = 640 : height = 480
sizeletter = 300 : t$ = "B"
open window width,height
backcolor 0,0,0
clear window
color 1,0,0
text width/2,height/2,t$,"swiss"+str$(sizeletter),"cc"
for y = 0 to height step 15
for x = 1 to width
cpixel$ = getbit$(x,y,x,y)
if cpixel$ = "rgb 1,1:010000" then
color 255,0,0
dot x,y
else
color 255,255,255
dot x,y
end if
next x
next y
-
And, with little change ...
// Effect 3
// Developed in Yabasic 2.78.0 by Galileo, 2/2017
// Play with parameters
width = 640 : height = 480
sizeletter = 300 : t$ = "B"
open window width,height
backcolor 0,0,0
clear window
color 1,0,0
text width/2,height/2,t$,"swiss"+str$(sizeletter),"cc"
color 255,255,255
for y = 0 to height step 15
for x = 1 to width
cpixel$ = getbit$(x,y,x,y)
if cpixel$ = "rgb 1,1:010000" then
dot x,y-5
else
dot x,y
end if
next x
next y
-
// Effect 4
// Developed in Yabasic 2.78.0 by Galileo, 2/2017
// Play with parameters
width = 640 : height = 480
ndrops = 500
sizeletter = 300 : t$ = "B"
DIM drop(ndrops, 3)
dcount = 0
for n = 1 to ndrops
newDrop(n)
next n
open window width,height
backcolor 0,0,0
clear window
color 1,0,0
text width/2,height/2,t$,"swiss"+str$(sizeletter),"cc"
color 255,255,255
do
for n = 1 to ndrops
x = drop(n,1) : y = drop(n,2)
if drop(n,2) > height+2 newDrop(n)
cpixel$ = getbit$(x,y+2,x,y+2)
if cpixel$ <> "rgb 1,1:010000" then
clear fill circle drop(n,1),drop(n,2), 1
end if
drop(n,2) = drop(n,2) + drop(n,3)
fill circle drop(n,1),drop(n,2), 1
next n
loop
sub newDrop(n)
drop(n, 1) = ran(width)
drop(n, 2) = -ran(height)
drop(n, 3) = ran(4)+.5
end sub
-
// Effect 5
// Developed in Yabasic 2.78.0 by Galileo, 3/2017
// Play with parameters
width = 250 : height = 250
sizeletter = 200 : t$ = "B"
open window width,height
backcolor 255,255,255
clear window
color 0,0,0
text width/2,height/2,t$,"swiss"+str$(sizeletter),"cc"
dim p(width+1, height+1)
for x = 0 to width
for y = 0 to height
if getbit$(x,y,x,y) = "rgb 1,1:000000" then
p(x,y) = 0
else
p(x,y) = 255
end if
next y
next x
do
for x = 1 to width-1
for y = 1 to height-1
c = 0
c = c + p(x-1,y-1)
c = c + p(x,y-1)
c = c + p(x+1,y-1)
c = c + p(x-1,y)
c = c + p(x,y)
c = c + p(x+1,y)
c = c + p(x-1,y+1)
c = c + p(x,y+1)
c = c + p(x+1,y+1)
c = c/9
p(x,y)=c
color c,c,c
dot x,y
next y
next x
loop
-
// Effect 7
// Developed in Yabasic 2.78.0 by Galileo, 2/2017
// Play with parameters
width = 640 : height = 512
sizeletter = 400 : t$ = "S"
open window width,height
backcolor 0,0,0
clear window
color 1,0,0
text width/2,height/2,t$,"swiss"+str$(sizeletter),"cc"
dim p(width, height)
for x = 0 to width
for y = 0 to height
if (getbit$(x,y,x,y) = "rgb 1,1:010000") p(x,y) = 255
next y
next x
text 0,0,"","swiss12"
mx=50
my=42
dim scr(mx,my)
for y=0 to my
for x=0 to mx
scr(x,y)=int(ran(96)+33)
next x
next y
ms=75
dim sx(ms)
dim sy(ms)
for a=1 to ms
sx(a)=int(ran(mx))
sy(a)=int(ran(my))
next a
do
for s=1 to ms
x=sx(s)
y=sy(s)
letter(0,255,0)
y=y-1
letter(0,128,0)
y=y-1
letter(0,50,0)
y=y-24
color 0,0,0
fill rect x*12.8-1,y*12.8+4 to x*12.8+12,y*12.8-10
next s
for s=1 to ms
if int(ran(5)+1)=1 sy(s)=sy(s)+1
if sy(s)>my+25 then
sy(s)=0
sx(s)=int(ran(mx))
end if
next s
loop
sub letter(r,g,b)
local c,d
if y<0 or y>my return
c=scr(x,y)
d = p(x*12,y*12)
if d then
color d,d,d
else
color r,g,b
end if
text x*12.8,y*12.8,chr$(c)
end sub
-
// Effect 8
// Developed in Yabasic 2.78.0 by Galileo, 2/2017
// Play with parameters
width = 640 : height = 480
sizeletter = 300 : t$ = "B"
open window width,height
backcolor 0,0,0
clear window
color 1,0,0
text width/2,height/2,t$,"swiss"+str$(sizeletter),"cc"
do
color ran(255),ran(255),ran(255)
for y = 0 to height step 10
for x = 0 to width step 10
cpixel$ = getbit$(x,y,x,y)
if cpixel$ = "rgb 1,1:010000" then
text x,y,chr$(ran(32)+32),"swiss10"
end if
next x
next y
loop
-
// Effect 10
// Developed in Yabasic 2.78.0 by Galileo, 2/2017
// Play with parameters
// Taking advantage of code get from the snowflakes program in SpecBAS
SCRw = 640 : SCRh = 480
sizeletter = 300 : t$ = "B"
OPEN WINDOW SCRw, SCRh
flakes=500
DEG = 0.0174532925
DIM a(flakes,2)
DIM w(flakes,2)
DIM p(flakes,7)
DIM s(SCRw, SCRh)
FOR f=1 TO flakes
genera()
p(f,2)=-RAN(SCRh)
NEXT f
BACKCOLOR 0,0,0
clear window
color 1,0,0
text SCRw/2,SCRh/2,t$,"swiss"+str$(sizeletter),"cc"
for x = 0 to SCRw
for y = 0 to SCRh
cpixel$ = getbit$(x,y,x,y)
if cpixel$ = "rgb 1,1:010000" then
s(x, y) = 1
end if
next y
next x
COLOR 255,255,255
do
FOR f=1 TO flakes
x = p(f,1) : y = p(f,2)
ink = p(f,6)
color ink,ink,ink
if (x > -1) and (y > -1) and (x <= SCRw) and (y <= SCRh) and not(s(x,y)) eraseSF()
p(f,2) = p(f,2) + p(f,3)
IF p(f,2)>SCRh genera()
a3=SIN(DEG * ((p(f,2)+p(f,5))/(w(f,2)/SCRh)))
p(f,1)=a3*a(f,1)*SIN(DEG * ((p(f,2)+p(f,5))/(w(f,1)/SCRw)))+p(f,4)
drawSF()
NEXT f
loop
REM New flake - call with f for the index
sub genera()
a(f,1)=(10+RAN(700))*(RAN(2)-1)
w(f,1)=3200+RAN(300)
a(f,2)=10+RAN(100)
w(f,2)=3200+RAN(300)
p(f,4)=RAN(SCRw+200)-100
p(f,2)=0
p(f,3)=.5+RAN(2)
p(f,1)=p(f,4)
p(f,5)=RAN(SCRh)
p(f,6)=RAN(16)+(255-16)
p(f,7)=INT(RAN(3))
end sub
sub eraseSF()
IF p(f,7)=1 THEN
clear DOT p(f,1),p(f,2)
ELSE
clear FILL CIRCLE p(f,1),p(f,2),p(f,7)
END IF
end sub
sub drawSF()
IF p(f,7)=1 THEN
DOT p(f,1),p(f,2)
ELSE
FILL CIRCLE p(f,1),p(f,2),p(f,7)
END IF
end sub
-
Variation of the previous one.
// Effect 10B
// Developed in Yabasic 2.78.0 by Galileo, 2/2017
// Play with parameters
// Taking advantage of code get from the eponymous program in SpecBAS
SCRw = 640 : SCRh = 480
sizeletter = 300 : t$ = "U"
OPEN WINDOW SCRw, SCRh
flakes=500
DEG = 0.0174532925
DIM a(flakes,2)
DIM w(flakes,2)
DIM p(flakes,7)
DIM s(SCRw, SCRh)
print "Please, wait ..."
FOR f=1 TO flakes
genera()
p(f,2)=-RAN(SCRh)
NEXT f
BACKCOLOR 0,0,0
clear window
color 1,0,0
text SCRw/2,SCRh/2,t$,"swiss"+str$(sizeletter),"cc"
for x = 0 to SCRw
for y = 0 to SCRh
cpixel$ = getbit$(x,y,x,y)
if cpixel$ = "rgb 1,1:010000" then
s(x, y) = 1
end if
next y
next x
COLOR 255,255,255
clear screen
do
FOR f=1 TO flakes
x = p(f,1) : y = p(f,2)
ink = p(f,6)
color ink,ink,ink
if (x > -1) and (y > -1) and (x < SCRw+1) and (y <= SCRh) and not(s(x,y)) then
eraseSF()
else
genera()
end if
p(f,2) = p(f,2) + p(f,3)
IF p(f,2)>SCRh genera()
a3=SIN(DEG * ((p(f,2)+p(f,5))/(w(f,2)/SCRh)))
p(f,1)=a3*a(f,1)*SIN(DEG * ((p(f,2)+p(f,5))/(w(f,1)/SCRw)))+p(f,4)
drawSF()
NEXT f
loop
REM New flake - call with f for the index
sub genera()
a(f,1)=(10+RAN(700))*(RAN(2)-1)
w(f,1)=3200+RAN(300)
a(f,2)=10+RAN(100)
w(f,2)=3200+RAN(300)
p(f,4)=RAN(SCRw+200)-100
p(f,2)=0
p(f,3)=.5+RAN(2)
p(f,1)=p(f,4)
p(f,5)=RAN(SCRh)
p(f,6)=RAN(16)+(255-16)
p(f,7)=INT(RAN(3))
end sub
sub eraseSF()
IF p(f,7)=1 THEN
clear DOT p(f,1),p(f,2)
ELSE
clear FILL CIRCLE p(f,1),p(f,2),p(f,7)
END IF
end sub
sub drawSF()
IF p(f,7)=1 THEN
DOT p(f,1),p(f,2)
ELSE
FILL CIRCLE p(f,1),p(f,2),p(f,7)
END IF
end sub
-
REM *** Original code by Xalthorn ***
REM Modified and adapted for Yabasic 2.768 by Galileo, 4/2015
REM Little addition for letter effect, 2/2017
gosub initialise
gosub main
exit
label main
do
backcolor fl,fl,fl
pause 0
clear window
if fl > 0 then
fl = max(0, fl - 10)
text w/2,h/2,"B","swiss300","cc"
end if
if fl = 0 and int(ran(100)) = 1 fl = int(ran(100) + 155)
gosub drawrain
gosub drawsplashes
loop
return
label drawsplashes
for a = 1 to numsplash
if splashy(a) <= h then
color 200, 200, 200
x = splashx(a) : y = splashy(a)
fill circle x, y, 1
splashy(a) = splashy(a) + splashyv(a)
splashx(a) = splashx(a) + splashxv(a)
splashyv(a) = splashyv(a) + 0.4
end if
next a
return
label addsplash
found = 0 : b = 0
repeat
b = b + 1
if splashy(b) > h found = 1
until(found = 1 or b = numsplash)
if found <> 0 then
splashy(b) = 510
splashyv(b) = -int(ran(4) + 3)
splashx(b) = x
end if
return
label drawrain
for a = 1 to numrain
x = rainx(a) : y = rainy(a)
s = rains(a)
b1 = br1(s) : b2 = br2(s) : b3 = br3(s)
s1 = s1(s) : s2 = s2(s) : s3 = s3(s)
color b1, b1, b1 : line x, y - s1 to x, y + s1
color b2, b2, b2 : line x, y - s2 to x, y + s2
color b3, b3, b3 : line x, y - s3 to x, y + s3
y = y + 6 * rains(a)
if y >= 540 then
rainx(a) = int(ran(640))
y = -50
gosub addsplash
gosub addsplash
end if
rainy(a) = y
next a
return
label initialise
w = 640 : h = 512
open window w, h
dim co(360), si(360)
for a = 0 to 360
co(a) = cos(a * (pi / 180))
si(a) = sin(a * (pi / 180))
next a
numrain = 50
dim rainx(numrain), rainy(numrain), rains(numrain)
for a = 1 to numrain
rainx(a) = int(ran(w))
rainy(a) = int(ran(h))
rains(a) = mod(a, 3) + 2
next a
numsplash = 40
dim splashx(numsplash), splashy(numsplash)
dim splashxv(numsplash), splashyv(numsplash)
for a = 1 to numsplash
splashxv(a) = int(ran(6)) - 3
splashy(a) = 520
next a
dim br1(4), br2(4), br3(4), s1(4), s2(4), s3(4)
for a = 1 to 4
br1(a) = a * 25
br2(a) = a * 30
br3(a) = a * 50
s1(a) = a * 10
s2(a) = a * 8
s3(a) = a * 5
next a
return
-
//fire demo for smallbasic adapted to Yabasic 2.78.0 by Galileo 2/2017
print "Wait, please ..."
xmax=640:ymax=480
open window xmax,ymax
dim s(xmax, ymax)
BACKCOLOR 0,0,0
clear window
color 1,0,0
text xmax/2,ymax/2,"B","swiss300","cc"
for x = 0 to xmax
for y = 0 to ymax
if getbit$(x,y,x,y) = "rgb 1,1:010000" s(x, y) = 1
next y
next x
window origin "lt"
dim f(41,41)//fire
dim r(9999)//random table
//make random table
for i=0 to 9999
r(i)=int(ran(2240)-1000)
next i
a=xmax*1.03/41
b=ymax*1.08/41
n=340
//main loop
do
//scroll xpos message
n=mod((n+1), 800)
for i=1 to 40
x=i*a-a
s=1-s
s1=mod((i+n),400)
s2=mod((i+n+1),400)
//random fire seeds
f(i,41)=r(m)
m=mod((m+1),10000)
for j=40 to 0 step -1
//make fire
c=f(i-1,j)+f(i,j+1)+f(i+1,j+1)
c=abs(mod(c/3-1,255))
f(i,j)=c
if s(x+(a+1)/2,min(ymax,j*b+(b+2)/2)) then
color c+5,0,0
else
color c,0,0
end if
//draw rectangle with mixed palette
fill rectangle x,j*b, x+a+1,j*b+b+2
next j
next i
loop
-
// Effect 3b
// Developed in Yabasic 2.78.0 by Galileo, 2/2017
// Play with parameters
width = 640 : height = 480
sizeletter = 300 : t$ = "B"
open window width,height
backcolor 0,0,0
clear window
color 1,0,0
text width/2,height/2,t$,"swiss"+str$(sizeletter),"cc"
inix = width/2-sizeletter/2 : finx = inix+sizeletter
iniy = height/2-sizeletter/2 : finy = iniy+sizeletter
for x = inix to finx step 5
for y = iniy to finy step 5
col = int(ran(128))+64
cpixel$ = getbit$(x,y,x,y)
if cpixel$ = "rgb 1,1:010000" then
color col,col,col
fill box x,y to x+5,y+5
end if
next y
next x
-
// Effect 13
// Developed in Yabasic 2.78.0 by Galileo, 2/2017
// Play with parameters
width = 640 : height = 480
sizeletter = 300 : t$ = "B"
open window width,height
backcolor 0,0,0
clear window
color 1,0,0
text width/2,height/2,t$,"swiss"+str$(sizeletter),"cc"
inix = width/2-sizeletter/2 : finx = inix+sizeletter
iniy = height/2-sizeletter/2 : finy = iniy+sizeletter
for x = inix to finx
if not cw then col = int(ran(2)) : cw = int(ran(3))+2 : end if
if col then color 255,255,255 else color 0,0,0 end if
for y = iniy to finy
cpixel$ = getbit$(x,y,x,y)
if cpixel$ = "rgb 1,1:010000" then
dot x,y
end if
next y
cw = cw - 1
next x
-
// Effect 14
// Developed in Yabasic 2.78.0 by Galileo, 2/2017
// Play with parameters
width = 640 : height = 480
sizeletter = 300 : t$ = "B"
open window width,height
clear window
scol = 255/height
col = 0
for y = height to 0 step -1
color col,col,col
line 0,y to width,y
col = col + scol
next y
color 100,100,100
text width/2+5,height/2+5,t$,"swiss"+str$(sizeletter),"cc"
color 1,0,0
text width/2,height/2,t$,"swiss"+str$(sizeletter),"cc"
inix = width/2-sizeletter/2 : finx = inix+sizeletter
iniy = height/2-sizeletter/2 : finy = iniy+sizeletter
scol = 255/(finy-iniy)
col = 255
for y = iniy to finy
color col,col,col
for x = inix to finx
cpixel$ = getbit$(x,y,x,y)
if cpixel$ = "rgb 1,1:010000" then
dot x,y
end if
next x
col = col - scol
next y
-
// Effect 5b
// Developed in Yabasic 2.78.0 by Galileo, 2/2017
// Play with parameters
width = 640 : height = 480
ndrops = 500
sizeletter = 300 : t$ = "B"
dim drop(ndrops, 6)
dim bg(width, height)
dcount = 0
for n = 1 to ndrops
newDrop(n)
next n
open window width,height
backcolor 255,255,255
clear window
color 1,0,0
text 10,15,"Please, wait ...","swiss12"
color 0,0,0
text width/2,height/2,t$,"swiss"+str$(sizeletter),"cc"
for x = 1 to width
for y = 1 to height
if getbit$(x,y,x,y) = "rgb 1,1:000000" bg(x, y) = 1
next y
next x
clear window
do
for n = 1 to ndrops
x = drop(n,1) : y = drop(n,2)
if drop(n,2) > height+3 newDrop(n)
clear fill circle drop(n,1),drop(n,2), 3
if (x > -1) and (x < width + 1) and (y > -1) and (y < height + 1) and bg(x, y) then
if drop(n,3)> .01 then
drop(n,3)=drop(n,3)-.01
else
drop(n,3)=0
end if
end if
drop(n,2) = drop(n,2) + drop(n,3)
color drop(n,4),drop(n,5),drop(n,6)
fill circle drop(n,1),drop(n,2), 3
next n
loop
sub newDrop(n)
drop(n, 1) = ran(width)
drop(n, 2) = -ran(height)
drop(n, 3) = ran(3)+.5
drop(n, 4) = ran(255)
drop(n, 5) = ran(255)
drop(n, 6) = ran(255)
end sub
-
fire is really cool ..
thanks galileo ;)