Show Posts

This section allows you to view all posts made by this member. Note that you can only see posts made in areas you currently have access to.


Topics - _vince

Pages: [1] 2
1
Programs / Canonical Logarithm
« on: February 08, 2022, 09:13:32 am »
Code: [Select]
defdbl a-z
dim shared pi as double
pi = 4*atn(1)

sw = 800
sh = 600

screen _newimage(sw, sh, 32)

zoom = 100

a = 0.5
k = 0.09

sx = 2
sy = 1

tx = a*exp(k*16)*cos(16) + sx
ty = a*exp(k*16)*sin(16) + sy

x = a*exp(k*0)*cos(0) + sx - tx
y = a*exp(k*0)*sin(0) + sy - ty

r = sqr(x*x + y*y)
arg = _atan2(y, x)

for tt = r to 0 step -1
xl = tt*cos(arg)
yl = tt*sin(arg)

for yy=0 to sh
for xx=0 to sw
u = (xx - sw/2)/zoom
v = (sh/2 - yy)/zoom

cdiv uu, vv, u - xl, v - yl, u + xl, v + yl
clog uu, vv, uu, vv

mm = sqr(uu*uu + vv*vv)
aa = (pi + _atan2(vv, uu))/(2*pi)
pset (xx, yy), hrgb(aa, mm)
next
next

sleep
next

dim pp(5)
pp(5) = 0
pp(4) = 7
pp(3) = 10
pp(2) = 12
pp(1) = 15
pp(0) = 15.9

for ttt= 0 to 5
tt = pp(ttt)
for yy=0 to sh
for xx=0 to sw
u = (xx - sw/2)/zoom
v = (sh/2 - yy)/zoom

uu = 0
vv = 0
for t=tt to 16 step 0.1
x = a*exp(k*t)*cos(t) + sx - tx
y = a*exp(k*t)*sin(t) + sy - ty

cdiv p, q, 1, 0, x - u, y - v

dx = a*exp(k*t)*(k*cos(t) - sin(t))
dy = a*exp(k*t)*(k*sin(t) + cos(t))

cmul p, q, p, q, dx, dy

uu = uu + 0.1*p
vv = vv + 0.1*q
next

for t=16 - 0.1 to tt step -0.1
x =-a*exp(k*t)*cos(t) - sx + tx
y =-a*exp(k*t)*sin(t) - sy + ty

cdiv p, q, 1, 0, x - u, y - v

dx = a*exp(k*t)*(k*cos(t) - sin(t))
dy = a*exp(k*t)*(k*sin(t) + cos(t))

cmul p, q, p, q, dx, dy

uu = uu + 0.1*p
vv = vv + 0.1*q
next

cmul uu, vv, uu, vv, 0, -1/(2*pi)

mm = sqr(uu*uu + vv*vv)
aa = (pi + _atan2(vv, uu))/(2*pi)
pset (xx, yy), hrgb(aa, mm)
next
next

sleep
next

sleep
system

function hrgb&(h, m)
r =  0.5 - 0.5*sin(2*pi*h - pi/2)
    g = (0.5 + 0.5*sin(2*pi*h*1.5 - pi/2)) * -(h < 0.66)
    b = (0.5 + 0.5*sin(2*pi*h*1.5 + pi/2)) * -(h > 0.33)

    n = 128

    mm = m*10000 mod 500
p = abs((h*n) - int(h*n))

rr = 200*r - 0.15*mm - 35*p
gg = 200*g - 0.15*mm - 35*p
bb = 200*b - 0.15*mm - 35*p

if rr < 0 then rr = 0
if gg < 0 then gg = 0
if bb < 0 then bb = 0

hrgb& = _rgb(rr, gg, bb)
end function

function cosh#(x as double)
    cosh# = 0.5*(exp(x) + exp(-x))
end function

function sinh#(x as double)
    sinh# = 0.5*(exp(x) - exp(-x))
end function

'u + iv = (x + iy)^(a + ib)
sub cexp(u, v, xx, yy, aa, bb)
x = xx
y = yy
a = aa
b = bb
   
    lnz = x*x + y*y
   
    if lnz = 0 then
        u = 0
        v = 0
    else
        lnz = 0.5*log(lnz)
        argz = atan2(y, x)
       
        mag = exp(a*lnz - b*argz)
        ang = a*argz + b*lnz
       
        u = mag*cos(ang)
        v = mag*sin(ang)
    end if
end sub

'u + iv = (x + iy)*(a + ib)
sub cmul(u, v, xx, yy, aa, bb)
x = xx
y = yy
a = aa
b = bb
    u = x*a - y*b
    v = x*b + y*a
end sub

'u + iv = (x + iy)/(a + ib)
sub cdiv(u, v, xx, yy, aa, bb)
x = xx
y = yy
a = aa
b = bb

    d = a*a + b*b
    u = (x*a + y*b)/d
    v = (y*a - x*b)/d
end sub

sub clog(u, v, xx, yy)
x = xx
y = yy

    lnz = x*x + y*y
   
    if lnz = 0 then
        u = 0
        v = 0
    else
u = 0.5*log(lnz)
v = _atan2(y, x)
end if
end sub

2
Programs / Curves
« on: February 01, 2022, 04:35:33 pm »
Code: [Select]
deflng a-z
dim shared sw, sh
sw = 1024
sh = 600
dim shared pi as double
pi = 4*atn(1)

screen _newimage(sw, sh, 32)

dim as long n, r, mx, my, mb, omx, omy
n = 0
redim x(n) as long, y(n) as long

r = 5
do
getmouse mx, my, mb

if mb = 1 then
n = 1
redim _preserve x(n)
redim _preserve y(n)

x(0) = mx - sw/2
y(0) = sh/2 - my

pset (mx, my)
do while mb = 1
getmouse mx, my, mb

line -(mx, my), _rgb(30,30,30)

if (mx - omx)^2 + (my - omy)^2 > r^2 then
circlef mx, my, 3, _rgb(30,30,30)
omx = mx
omy = my

x(n) = mx - sw/2
y(n) = sh/2 - my
n = n + 1
redim _preserve x(n)
redim _preserve y(n)
end if

_display
_limit 50
loop

'close the contour
'x(n) = x(0)
'y(n) = y(0)
'n = n + 1
'redim _preserve x(n)
'redim _preserve y(n)


'redraw spline
'pset (sw/2 + x(0), sh/2 - y(0))
'for i=0 to n
'line -(sw/2 + x(i), sh/2 - y(i)), _rgb(255,0,0)
'circlef sw/2 + x(i), sh/2 - y(i), 3, _rgb(255,0,0)
'next

dim as double bx, by, t, bin
pset (sw/2 + x(0), sh/2 - y(0))
for t=0 to 1 step 0.0001
bx = 0
by = 0

for i=0 to n
bin = 1
for j=1 to i
bin = bin*(n - j)/j
next

bx = bx + bin*((1 - t)^(n - 1 - i))*(t^i)*x(i)
by = by + bin*((1 - t)^(n - 1 - i))*(t^i)*y(i)
next

line -(sw/2 + bx, sh/2 - by), _rgb(255,0,0)
next
end if

_display
_limit 50
loop until _keyhit = 27
system

sub getmouse (mx as long, my as long, mb as long)
do
mx = _mousex
my = _mousey
mb = -_mousebutton(1)
loop while _mouseinput
end sub
 
sub circlef(x as long, y as long, r as long, c as long)
dim as long x0, y0, e
        x0 = r
        y0 = 0
        e = -r
 
        do while y0 < x0
                if e <=0 then
                        y0 = y0 + 1
                        line (x - x0, y + y0)-(x + x0, y + y0), c, bf
                        line (x - x0, y - y0)-(x + x0, y - y0), c, bf
                        e = e + 2*y0
                else
                        line (x - y0, y - x0)-(x + y0, y - x0), c, bf
                        line (x - y0, y + x0)-(x + y0, y + x0), c, bf
                        x0 = x0 - 1
                        e = e - 2*x0
                end if
        loop
        line (x - r, y)-(x + r, y), c, bf
end sub


 
caligpro3.PNG

3
Programs / Removable singularity
« on: January 13, 2022, 05:23:42 am »
what happens when you take a function f(x), multiply it by (x-1) then divide by (x-1)? Would it be infinity at x=1? 

g(x) = f(x)*(x-1)/(x-1).  what is g(1)?

Try it out with the mouse:

Code: QB64: [Select]
  1. const sw = 800
  2. const sh = 600
  3.  
  5. pi = 4*atn(1)
  6.  
  7. screen _newimage(sw, sh, 32)
  8.  
  10.         do
  11.                 mx = _mousex
  12.                 my = _mousey
  13.                 mbl = _mousebutton(1)
  14.                 mbr = _mousebutton(2)
  15.                 mw = mw + _mousewheel
  16.         loop while _mouseinput
  17.  
  18.         for yy=0 to sh
  19.         for xx=0 to sw
  20.                         u = (xx - sw/2)*0.01
  21.                         v = (sh/2 - yy)*0.01
  22.  
  23.  
  24.                         cmul uu, vv, u - (mx - sw/2)*0.01, v - (sh/2 - my)*0.01, u + 0.707, v - 0.707
  25.                         cdiv x, y, uu, vv, u - 1, v
  26.  
  27.  
  28.                 m = sqr(x*x + y*y)
  29.                 a = (pi + _atan2(y, x))/(2*pi)
  30.  
  31.                 pset (xx, yy), hrgb&(a, m)
  32.  
  33.         next
  34.         next
  35.  
  36.         _display
  37.         _limit 60
  38.  
  40.  
  42.  
  43. function hrgb&(h, m)
  44.         r =  0.5 - 0.5*sin(2*pi*h - pi/2)
  45.     g = (0.5 + 0.5*sin(2*pi*h*1.5 - pi/2)) * -(h < 0.66)
  46.     b = (0.5 + 0.5*sin(2*pi*h*1.5 + pi/2)) * -(h > 0.33)
  47.  
  48.         dim n as long
  49.     n = 16
  50.    
  51.     mm = m*500 mod 500
  52.         p = abs((h*n) - int(h*n))
  53.  
  54.         rr = 255*r - 0.15*mm - 35*p
  55.         gg = 255*g - 0.15*mm - 35*p
  56.         bb = 255*b - 0.15*mm - 35*p
  57.  
  58.         if rr < 0 then rr = 0
  59.         if gg < 0 then gg = 0
  60.         if bb < 0 then bb = 0
  61.  
  62.         hrgb& = _rgb(rr, gg, bb)
  64.  
  65.  
  66. 'u + iv = (x + iy)*(a + ib)
  67. sub cmul(u, v, xx, yy, aa, bb)
  68.         x = xx
  69.         y = yy
  70.         a = aa
  71.         b = bb
  72.  
  73.     u = x*a - y*b
  74.     v = x*b + y*a
  76.  
  77. 'u + iv = (x + iy)/(a + ib)
  78. sub cdiv(u, v, xx, yy, aa, bb)
  79.         x = xx
  80.         y = yy
  81.         a = aa
  82.         b = bb
  83.  
  84.     d = a*a + b*b
  85.     u = (x*a + y*b)/d
  86.     v = (y*a - x*b)/d
  88.  

a singularity and two zeros
 
sngthere.png


singularity removed with the mouse
 
sngremoved.png

4
Programs / Lorenz system in color
« on: January 13, 2022, 03:31:11 am »
Lorenz system ( https://en.wikipedia.org/wiki/Lorenz_system ) flattened out to color domain.  Each pixel (x,y) becomes a particle (x,y,z) with random z and we colour it based on how long it takes to get to the center of the 'butterfly' using a poor Euler's method.  This image can be zoomed and explored

Code: [Select]
defdbl a-z

const sw = 640
const sh = 480

dim shared mx,my,mbl,mbr,mw

dim u as double, v as double
dim uu as double, vv as double
dim xx as double, yy as double
dim x0 as double, y0 as double
dim z as double, zz as double
z = 1
zz = 0.1

dim p1 as long
p1 = _newimage(sw, sh, 32)
screen _newimage(sw, sh, 32)

redraw = -1
iter = 500

dim c(100) as long, cc as long

for i=0 to 100
        if i < iter/6 then
                r = 155
                g = (i mod (iter/6))*(255/(iter/6))
                b = 0
        elseif i < 2*iter/6 then
                r = 155 - (i mod (iter/6))*(255/(iter/6))
                g = 155
                b = 0
        elseif i < 3*iter/6 then
                r = 0
                g = 155
                b = (i mod (iter/6))*(255/(iter/6))
        elseif i < 4*iter/6 then
                r = 0
                g = 155 - (i mod (iter/6))*(255/(iter/6))
                b = 155
        elseif i < 5*iter/6 then
                r = (i mod (iter/6))*(255/(iter/6))
                g = 0
                b = 155
        else
                r = 155
                g = 0
                b = 155 - (i mod (iter/6))*(255/(iter/6))
        end if
        c(i) = _rgb(r, g, b)
next

ppp=28
sss=10
bbb=8/3
zzz=0.456
hh=0.01

do
        mw = 0
        getmouse

        if redraw then
                for yy = 0 to sh-1
                for xx = 0 to sw-1
                        u = 0
                        v = 0

                        x = (xx - sw/2)*z + x0
                        y = (yy - sh/2)*z + y0
z2 = zzz

                        for i = 0 to iter
x = x + hh*sss*(y - x)
y = y + hh*(x*(ppp - z2) - y)
z2=z2 + hh*(x*y - bbb*z2)

                                if (x*x + y*y) < 2 then exit for
                        next

                        if i > iter then
                                pset(xx, yy), _rgb(0,0,0)
                        else
                                pset(xx, yy), c(i mod 100)
                        end if
                next
                next

                'locate 1,1
                'print "iter =";iter
                _title str$(iter)

                _dest p1
                _putimage , 0
                _dest 0

                _putimage , p1
                _autodisplay

                redraw = 0
        end if

        if mw < 0 then
                zz = zz + 0.01
        elseif mw > 0 then
                if zz > 0.01 then zz = zz - 0.01
        end if

        'draw box
        if omx <> mx or omy <> my or mw <> 0 then
                _putimage , p1
                line (mx - (sw*zz/2), my - (sh*zz/2))-step(sw*zz,sh*zz),_rgb(255,255,255),b
                _autodisplay

                omx = mx
                omy = my
        end if

        if mbl then
                do
                        getmouse
                loop while mbl

                x0 = x0 + (mx - sw/2)*z
                y0 = y0 - (sh/2 - my)*z
                z = z*zz

                iter = iter + 50

                redraw = -1
        elseif mbr then
                do
                        getMouse
                loop while mbr

                x0 = x0 + (mx - sw/2)*z
                y0 = y0 - (sh/2 - my)*z
                z = z/zz
                redraw = -1
        end if

        k = _keyhit
        if k = 43 then
                iter = iter + 50
                redraw = -1
        elseif k = 45 then
                if iter > 50 then iter = iter - 50
                redraw = -1
        end if

loop until k = 27
system

sub getmouse ()
        do
                mx = _mousex
                my = _mousey
                mbl = _mousebutton(1)
                mbr = _mousebutton(2)
                mw = mw + _mousewheel
        loop while _mouseinput
end sub

'u + iv = (x + iy) ^ (a + ib)
sub cexp (u as double, v as double, x as double, y as double, a as double, b as double)
        dim mag as double, arg as double
        dim lnz as double, argz as double

        lnz = 0.5*log((x*x + y*y)+0.00001)
        argz = _atan2(y, x)

        mag = exp(a*lnz - b*argz)
        arg = a*argz + b*lnz

        u = mag * cos(arg)
        v = mag * sin(arg)
end sub


 
lzfrac.PNG

5
Programs / Sliding Window
« on: January 11, 2022, 05:53:29 am »
On the topic of music visualizers, you can see the effect of windowing

(this wasn't optimized for visualization -- everything is calculated on the fly. it ran okay on my modern laptop)

Code: [Select]
'defdbl a-z

const sw = 2048
const sh = 600

dim shared pi as double
pi = 4*atn(1)

declare sub rfft(xx_r(), xx_i(), x_r(), n)

dim x_r (sw-1), x_i (sw-1)
dim xx_r(sw-1), xx_i(sw-1)

dim st_x_r (512-1), st_x_i (512-1)
dim st_xx_r(512-1), st_xx_i(512-1)

dim st_x_r2 (512-1), st_x_i2 (512-1)
dim st_xx_r2(512-1), st_xx_i2(512-1)

dim t as double

'create signal consisting of three sinewaves in RND noise
for i=0 to sw/3-1
x_r(i) = 100*sin(2*pi*(sw*1000/44000)*i/sw) + (100*rnd - 50)
next
for i=sw/3 to 2*sw/3-1
x_r(i) = 100*sin(2*pi*(sw*2000/44000)*i/sw) + (100*rnd - 50)
next
for i=2*sw/3 to sw-1
x_r(i) = 100*sin(2*pi*(sw*8000/44000)*i/sw) + (100*rnd - 50)
next


screen _newimage(sw/2, sh, 32),,1,0

'plot signal
pset (0, sh/4 - x_r(0))
for i=0 to sw/2 - 1
line -(i, sh/4 - x_r(i*2)), _rgb(70,0,0)
next
line (0, sh/4)-step(sw,0), _rgb(255,0,0),,&h5555

color _rgb(255,0,0)
_printstring (0, 0), "2048 samples of three sine waves (1 kHz, 2 kHz, 8 kHz) in RND noise sampled at 44 kHz"


rfft xx_r(), xx_i(), x_r(), sw

'plot its fft
'pset (0, 70+3*sh/4 - 0.005*sqr(xx_r(0)*xx_r(0) + xx_i(0)*xx_i(0)) )
for i=0 to sw/2
pset (i*2, 70 + 3*sh/4), _rgb(70,70,0)
line -(i*2, 70+3*sh/4 - 0.005*sqr(xx_r(i)*xx_r(i) + xx_i(i)*xx_i(i)) ), _rgb(70,70,0)
next
line (0, 70+3*sh/4)-step(sw,0), _rgb(255,255,0),,&h5555

color _rgb(70,70,0)
_printstring (0, sh/2), "its entire FFT first half"
color _rgb(70,0,0)
_printstring (0, sh/2 + 16), "rectangular short time FFT"
color _rgb(0,70,0)
_printstring (0, sh/2 + 32), "gaussian short time FFT"


screen ,,0,0
pcopy 1,0

mx = 0
do
do
mx = _mousex
my = _mousey
mbl = _mousebutton(1)
mbr = _mousebutton(2)
mw = mw + _mousewheel
loop while _mouseinput

pcopy 1,0


'draw windows
if mx > sw/2-256 then mx = sw/2 - 256 - 1
if mx < 0 then mx = 0

'''rectangular window
line (mx,1)-step(256,sh/4 - 1),_rgb(255,0,0),b

'''gaussian window
z = (0 - 256/2)/(128/2)
pset (mx, sh/4 - (sh/4)*exp(-z*z/2))
for i=0 to 256
z = (i - 256/2)/(128/2)
line -(mx + i, sh/4 - (sh/4)*exp(-z*z/2)),_rgb(0,255,0)
next


'take it's windowed short time FFT
for i=0 to 512-1
'rectangular window -- do nothing
st_x_r(i) = x_r(mx*2 + i)

'gaussian window -- smooth out the edges
z = (i - 512/2)/(256/2)
st_x_r2(i) = x_r(mx*2 + i)*exp(-z*z/2)
next

'''plot signal rectangular
pset (mx, sh/4 - st_x_r(0))
for i=0 to 256 -1
line -(mx + i, sh/4 - st_x_r(i*2)), _rgb(255,0,0)
next
line (0, sh/4)-step(sw,0), _rgb(255,0,0),,&h5555

'''plot signal gaussian
pset (mx, sh/4 - st_x_r2(0))
for i=0 to 256 -1
line -(mx + i, sh/4 - st_x_r2(i*2)), _rgb(0,255,0)
next
line (0, sh/4)-step(sw,0), _rgb(255,0,0),,&h5555


rfft st_xx_r(), st_xx_i(), st_x_r(), 512
rfft st_xx_r2(), st_xx_i2(), st_x_r2(), 512


'plot its short time fft rectangular
pset (0, 70+3*sh/4 - 0.005*sqr(st_xx_r(0)*st_xx_r(0) + st_xx_i(0)*st_xx_i(0)) )
for i=0 to 128
'pset (i*8, 70 + 3*sh/4), _rgb(256,256,0)
line -(i*8, 70+3*sh/4 - 0.005*sqr(st_xx_r(i)*st_xx_r(i) + st_xx_i(i)*st_xx_i(i)) ), _rgb(256,0,0)
next

'''parabolic tone finder
dim max as double, d as double
max = 0
m = 0
for i=0 to 256
d = sqr(st_xx_r(i)*st_xx_r(i) + st_xx_i(i)*st_xx_i(i))
if d > max then
max = d
m = i
end if
next

dim c as double
dim u_r as double, u_i as double
dim v_r as double, v_i as double

u_r = st_xx_r(m - 1) - st_xx_r(m + 1)
u_i = st_xx_i(m - 1) - st_xx_i(m + 1)
v_r = 2*st_xx_r(m) - st_xx_r(m - 1) - st_xx_r(m + 1)
v_i = 2*st_xx_i(m) - st_xx_i(m - 1) - st_xx_i(m + 1)
c = (u_r*v_r + u_i*v_i)/(v_r*v_r + v_i*v_i)

color _rgb(70,70,0)
_printstring (sw/4, sh/2), "spectral parabolic interpolation tone detector"
color _rgb(255,0,0)
_printstring (sw/4, sh/2 + 16), "f_peak = "+str$((m + c)*44000/512)+" Hz"

i = m
pset ((i + c)*8, 70 + 3*sh/4), _rgb(256,256,0)
line -((i + c)*8, sh ), _rgb(256,0,0)



'plot its short time fft gaussian
pset (0, 70+3*sh/4 - 0.005*sqr(st_xx_r2(0)*st_xx_r2(0) + st_xx_i2(0)*st_xx_i2(0)) )
for i=0 to 128
'pset (i*8, 70 + 3*sh/4), _rgb(256,256,0)
line -(i*8, 70+3*sh/4 - 0.005*sqr(st_xx_r2(i)*st_xx_r2(i) + st_xx_i2(i)*st_xx_i2(i)) ), _rgb(0,256,0)
next

'''parabolic tone finder
max = 0
m = 0
for i=0 to 256
d = sqr(st_xx_r2(i)*st_xx_r2(i) + st_xx_i2(i)*st_xx_i2(i))
if d > max then
max = d
m = i
end if
next

u_r = st_xx_r2(m - 1) - st_xx_r2(m + 1)
u_i = st_xx_i2(m - 1) - st_xx_i2(m + 1)
v_r = 2*st_xx_r2(m) - st_xx_r2(m - 1) - st_xx_r2(m + 1)
v_i = 2*st_xx_i2(m) - st_xx_i2(m - 1) - st_xx_i2(m + 1)
c = (u_r*v_r + u_i*v_i)/(v_r*v_r + v_i*v_i)

color _rgb(0,256,0)
_printstring (sw/4, sh/2 + 32), "f_peak = "+str$((m + c)*44000/512)+" Hz"

i = m
pset ((i + c)*8, 70 + 3*sh/4), _rgb(0,256,0)
line -((i + c)*8, sh ), _rgb(0,256,0)


_display
_limit 30
loop until _keyhit=27
system


sub rfft(xx_r(), xx_i(), x_r(), n)
dim w_r as double, w_i as double, wm_r as double, wm_i as double
dim u_r as double, u_i as double, v_r as double, v_i as double

log2n = log(n/2)/log(2)

for i=0 to n/2 - 1
rev = 0
for j=0 to log2n - 1
if i and (2^j) then rev = rev + (2^(log2n - 1 - j))
next

xx_r(i) = x_r(2*rev)
xx_i(i) = x_r(2*rev + 1)
next

for i=1 to log2n
m = 2^i
wm_r = cos(-2*pi/m)
wm_i = sin(-2*pi/m)

for j=0 to n/2 - 1 step m
w_r = 1
w_i = 0

for k=0 to m/2 - 1
p = j + k
q = p + (m \ 2)

u_r = w_r*xx_r(q) - w_i*xx_i(q)
u_i = w_r*xx_i(q) + w_i*xx_r(q)
v_r = xx_r(p)
v_i = xx_i(p)

xx_r(p) = v_r + u_r
xx_i(p) = v_i + u_i
xx_r(q) = v_r - u_r
xx_i(q) = v_i - u_i

u_r = w_r
u_i = w_i
w_r = u_r*wm_r - u_i*wm_i
w_i = u_r*wm_i + u_i*wm_r
next
next
next

xx_r(n/2) = xx_r(0)
xx_i(n/2) = xx_i(0)

for i=1 to n/2 - 1
xx_r(n/2 + i) = xx_r(n/2 - i)
xx_i(n/2 + i) = xx_i(n/2 - i)
next

dim xpr as double, xpi as double
dim xmr as double, xmi as double

for i=0 to n/2 - 1
xpr = (xx_r(i) + xx_r(n/2 + i)) / 2
xpi = (xx_i(i) + xx_i(n/2 + i)) / 2

xmr = (xx_r(i) - xx_r(n/2 + i)) / 2
xmi = (xx_i(i) - xx_i(n/2 + i)) / 2

xx_r(i) = xpr + xpi*cos(2*pi*i/n) - xmr*sin(2*pi*i/n)
xx_i(i) = xmi - xpi*sin(2*pi*i/n) - xmr*cos(2*pi*i/n)
next

'symmetry, complex conj
'for i=0 to n/2 - 1
' xx_r(n/2 + i) = xx_r(n/2 - 1 - i)
' xx_i(n/2 + i) =-xx_i(n/2 - 1 - i)
'next
end sub


 
sw1.PNG


6
Programs / Driving Game
« on: December 13, 2021, 12:21:44 pm »
Use "," key to go left and "." key to go right

Code: [Select]
CLS
s = 0
cr = 0
c = 7
l = 1
w = 15
1 r = l + w
IF l = 1 THEN n = 1
IF l = 25 THEN n = 0
IF n = 1 THEN l = l + 1
IF n = 0 THEN l = l - 1
'FOR k = 0 TO 4000
'NEXT k
_DELAY 0.5
a$ = INKEY$
IF a$ = "." THEN c = c + 1
IF a$ = "," THEN c = c - 1
PRINT TAB(l); "!"; TAB(c); "*"; TAB(r); "!"
IF c = l OR c = r THEN 2
IF a$ = "." OR a$ = "," THEN s = s + 1
GOTO 1
2 PRINT "***crash***"
cr = cr + 1
IF cr < 5 THEN 1
PRINT "score:"; s
PRINT "game over"
END

7
Programs / Domain Coloring
« on: August 15, 2020, 02:13:58 pm »
A kind of method for plotting complex functions:
https://en.wikipedia.org/wiki/Domain_coloring

So pretty I had to share this
Code: [Select]
defdbl a-z
dim shared pi as double
pi = 4*atn(1)

const sw = 800
const sh = 600

declare function hrgb(h as double, m as double)

screen _newimage(sw, sh, 32)


'dim as double x, y, u, v, m, a, uu, vv, x0, y0

dim p as string

for j=0 to 7
for yy=0 to sh
for xx=0 to sw
        select case j
        case 0
                u = (xx - sw/2)*0.015
                v = (sh/2 - yy)*0.015

                x = u
                y = v

                p = "z"
        case 1
                u = (xx - sw/2)*0.01 + 2
                v = (sh/2 - yy)*0.01

                x = exp(u)*cos(v)
                y = exp(u)*sin(v)

                p = "exp(z)"
        case 2
                u = (xx - sw/2)*0.015
                v = (sh/2 - yy)*0.015

                x = sin(u)*_cosh(v)
                y = cos(u)*_sinh(v)

                p = "sin(z)"
        case 3
                u = (xx - sw/2)*0.005 - 0.5
                v = (sh/2 - yy)*0.005
                x0 = u
                y0 = v
                for i=0 to 0
                        uu = u*u - v*v + x0
                        vv = 2*u*v + y0

                        u = uu
                        v = vv
                next
                x = u
                y = v

                p = "f(z) = z^2 + c"
        case 4
                u = (xx - sw/2)*0.005 - 0.5
                v = (sh/2 - yy)*0.005
                x0 = u
                y0 = v
                for i=0 to 1
                        uu = u*u - v*v + x0
                        vv = 2*u*v + y0

                        u = uu
                        v = vv
                next
                x = u
                y = v

                p = "f(f(z))"
        case 5
                u = (xx - sw/2)*0.005 - 0.5
                v = (sh/2 - yy)*0.005
                x0 = u
                y0 = v
                for i=0 to 3
                        uu = u*u - v*v + x0
                        vv = 2*u*v + y0

                        u = uu
                        v = vv
                next
                x = u
                y = v

                p = "f(f(f(f(z))))"
        case 6
                u = (xx - sw/2)*0.005 - 0.5
                v = (sh/2 - yy)*0.005
                x0 = u
                y0 = v
                for i=0 to 9
                        uu = u*u - v*v + x0
                        vv = 2*u*v + y0

                        u = uu
                        v = vv
                next
                x = u
                y = v

                p = "f(f(f(f(f(f(f(f(f(f(z))))))))))"
case 7
u = (xx - sw/2)*0.0015
v = (sh/2 - yy)*0.0015

x = sin(u/(u*u + v*v))*_cosh(-v/(u*u + v*v))
y = cos(u/(u*u + v*v))*_sinh(-v/(u*u + v*v))

p = "sin(1/z)"
        end select

        m = sqr(x*x + y*y)
        a = (pi + _atan2(y, x))/(2*pi)

        pset (xx, yy), hrgb(a, m)

        locate 1,1: ? p
next
next

sleep
next

system

function hrgb(h as double, m as double)
'dim as double r, g, b, mm

r = 0.5 - 0.5*sin(2*pi*h - pi/2)
    g = (0.5 + 0.5*sin(2*pi*h*1.5 - pi/2)) * -(h < 0.66)
    b = (0.5 + 0.5*sin(2*pi*h*1.5 + pi/2)) * -(h > 0.33)

mm = (m*100 mod 100)*0.01

if ((m*2*pi*100 mod 2*pi*100) < 50) or ((h*2*pi*100 mod 4*2*pi) < 6) then
'hrgb = _rgb(0,0,0)
hrgb = _rgb(15*r, 155*g, 155*b)
else
hrgb = _rgb(255*r, 255*g, 255*b)
end if
end function

8
Programs / Rotozoom with bilinear interpolation
« on: May 02, 2020, 11:41:33 pm »
I've recently used this algorithm in the shapes demo and wanted to try it on an image, it is supposed to improve the appearance of a rotated image. This code is inefficient because it calculates many unnecessary pixels, I may fix this later.

Code: [Select]
deflng a-z

'const sw = 800
'const sh = 600

dim shared pi as double
pi = 4*atn(1)

img = _loadimage("leopardx.jpg", 32)
w = _width(img)
h = _height(img)

dim zoom as double
dim a as double
zoom = 2.5

a = 2*sqr(w*w/4 + h*h/4)*zoom

if h < a then h = a

screen _newimage(w + a*2, h, 32)

_putimage (0,0), img

dim rot as double
do
        rot = rot + 0.1

        line (w, 0)-step(a*2, a),_rgb(0,0,0),bf
        rotzoom img, w + a/2, a/2, rot, zoom
        rotzoomb img, w + a + a/2, a/2, rot, zoom

        _display
        _limit 30
loop until _keyhit = 27

sleep
system

sub rotzoomb(img, x0, y0, rot as double, zoom as double)
        dim a as double
        dim xx as double, yy as double
        dim dx as double, dy as double

        w = _width(img)
        h = _height(img)

        if zoom = 0 then zoom = 1
        a = 2*sqr(w*w/4 + h*h/4)*zoom

        _source img

        for y=0 to a
        for x=0 to a
                xx = (x - a/2)*cos(rot)/zoom - (y - a/2)*sin(rot)/zoom + w/2
                yy = (x - a/2)*sin(rot)/zoom + (y - a/2)*cos(rot)/zoom + h/2

                if (int(xx) >=0 and int(xx) < w - 1 and int(yy) >= 0 and int(yy) < h - 1) then
                        tl = point(int(xx), int(yy))
                        tr = point(int(xx) + 1, int(yy))
                        bl = point(int(xx), int(yy) + 1)
                        br = point(int(xx) + 1, int(yy) + 1)

                        dx = xx - int(xx)
                        dy = yy - int(yy)

                        r = _round((1 - dy)*((1 - dx)*  _red(tl) + dx*  _red(tr)) + dy*((1 - dx)*  _red(bl) + dx*  _red(br)))
                        g = _round((1 - dy)*((1 - dx)*_green(tl) + dx*_green(tr)) + dy*((1 - dx)*_green(bl) + dx*_green(br)))
                        b = _round((1 - dy)*((1 - dx)* _blue(tl) + dx* _blue(tr)) + dy*((1 - dx)* _blue(bl) + dx* _blue(br)))

                        pset (x0 - a/2 + x, y0 - a/2 + y), _rgb(r, g, b)

                elseif (int(xx) >=0 and int(xx) < w - 1 and int(yy) >= 0 and int(yy) < h - 1) then
                        pset (x0 - a/2 + x, y0 - a/2 + y), point(int(xx), int(yy))
                end if
        next
        next
end sub


sub rotzoom(img, x0, y0, rot as double, zoom as double)
        dim a as double

        w = _width(img)
        h = _height(img)

        if zoom = 0 then zoom = 1
        a = 2*sqr(w*w/4 + h*h/4)*zoom

        _source img

        for y=0 to a
        for x=0 to a
                xx = (x - a/2)*cos(rot)/zoom - (y - a/2)*sin(rot)/zoom + w/2
                yy = (x - a/2)*sin(rot)/zoom + (y - a/2)*cos(rot)/zoom + h/2

                if ((xx) >= 0 and (xx) < w and (yy) >=0 and (yy) < h) then
                        pset (x0 - a/2 + x, y0 - a/2 + y), point(int(xx), int(yy))
                end if
        next
        next
end sub

9
Programs / Angle Pong
« on: March 07, 2020, 02:01:44 am »
Move the mouse left right up down to change position and angle, self explanatory

Code: [Select]
deflng a-z
const sw = 640
const sh = 480
dim shared pi as double
pi = 4*atn(1)

declare sub circlef(x, y, r, c)

dim a as double
dim b as double, d as double
dim p as double, q as double
dim cx as double, cy as double
dim vx as double, vy as double
dim vxx as double, vyy as double
cx = sw/2
cy = sh/4
vx = 0
vy = 1
r = 15

rebound = -1
ball = 0

screen 12
do

        if cx < r then
                vx = -vx
                rebound = -1
        end if
        if cx > sw - r then
                vx = -vx
                rebound = -1
        end if
        if cy < r then
                vy = -vy
                rebound = -1
        end if
        if cy > sh - r then
                cx = sw/2
                cy = sh/4
                vx = 0
                vy = 1
                rebound = -1
                ball = ball + 1
        end if

        cx = cx + vx
        cy = cy + vy

        do
                mx = _mousex
                my = _mousey
        loop while _mouseinput

        line (0,0)-(sw,sh),0,bf

        x = mx
        y = 395
        if mx < 80 then x = 80
        if mx > sw - 80 then x = sw - 80
        a = (my - sh/2)/(1.1*sh/2)*(pi/2)
        line (x, y)-step(80*cos(a), 80*sin(a))
        line (x, y)-step(-80*cos(a), -80*sin(a))

        if rebound then
        'if a >= 0 and vx <=0 or a < 0 and vx >= 0 then
                q = sin(a)*cos(a + pi/2) - cos(a)*sin(a + pi/2)
                if q <> 0 then
                        p = cy*cos(a) - cx*sin(a) - y*cos(a) + x*sin(a)
                        d = p/q
                        b = (cx + d*cos(a + pi/2) - x)/cos(a)
                        if abs(b) < 80 then
                                'line (cx, cy)- step(d*cos(a + pi/2), d*sin(a + pi/2)), 12
                                if d < r then
                                        vxx = vx*cos(2*a) + vy*sin(2*a)
                                        vyy = vx*sin(2*a) - vy*cos(2*a)
                                        vx = vxx
                                        vy = vyy
                                        rebound = 0
                                end if
                        end if
                end if
        'end if
        end if

        circlef cx, cy, r, 15

        locate 1,1: ? ball
        'locate 1,1: ? a*180/pi
        _display
        _limit 200
loop until _keyhit = 27
sleep
system

sub circlef(x, y, r, c)
        x0 = r
        y0 = 0
        e = -r

        do while y0 < x0
                if e <=0 then
                        y0 = y0 + 1
                        line (x - x0, y + y0)-(x + x0, y + y0), c, bf
                        line (x - x0, y - y0)-(x + x0, y - y0), c, bf
                        e = e + 2*y0
                else
                        line (x - y0, y - x0)-(x + y0, y - x0), c, bf
                        line (x - y0, y + x0)-(x + y0, y + x0), c, bf
                        x0 = x0 - 1
                        e = e - 2*x0
                end if
        loop
        line (x - r, y)-(x + r, y), c, bf
end sub

10
Programs / Re: Math Puzzle
« on: February 28, 2020, 04:43:28 pm »
Note: This message is awaiting approval by a moderator.
Quite silly, you are subtracting the number from a slightly modified version of that number, intuitive that it could cancel out, hardly a trick. I guess the 'trick' is sticking a bunch of 2's in there that cancel out to hide the fact that you're doing a mere addition to the original number

((x + 5)*2 - 2)/2 - x = ((x + 5) - 1) - x = x + 4 - x = 4

11
Programs / Fast Fourier Transform
« on: November 30, 2019, 02:34:17 pm »
A fast algorithm for computing the DFT for N=2^k

To use in your own programs you just need SUB fft or SUB rfft if dealing with real only signals.
i.e.:
Code: QB64: [Select]
  1. const n = 512
  2.  
  4. pi = 4*atn(1)
  5.  
  6. dim x_r(n-1), x_i(n-1)
  7. dim xx_r(n-1), xx_i(n-1)
  8.  
  9. 'create signal
  10. for i=0 to n-1
  11.         x_r(i) = 100*sin(2*pi*62.27*i/n) + 25*cos(2*pi*132.27*i/n)
  12.         x_i(i) = 0
  14.  
  15. fft xx_r(), xx_i(), x_r(), x_i(), n
  16.  

SUB fft
x_r, x_i is the input signal real and complex values, must be arrays of size n
xx_r, xx_i must also be arrays of size n and will contain output
Code: QB64: [Select]
  1. sub fft(xx_r(), xx_i(), x_r(), x_i(), n)
  2.         dim w_r as double, w_i as double, wm_r as double, wm_i as double
  3.         dim u_r as double, u_i as double, v_r as double, v_i as double
  4.  
  5.         log2n = log(n)/log(2)
  6.  
  7.         'bit rev copy
  8.         for i=0 to n - 1
  9.                 rev = 0
  10.                 for j=0 to log2n - 1
  11.                         if i and (2^j) then rev = rev + (2^(log2n - 1 - j))
  12.                 next
  13.  
  14.                 xx_r(i) = x_r(rev)
  15.                 xx_i(i) = x_i(rev)
  16.         next
  17.  
  18.  
  19.         for i=1 to log2n
  20.                 m = 2^i
  21.                 wm_r = cos(-2*pi/m)
  22.                 wm_i = sin(-2*pi/m)
  23.  
  24.                 for j=0 to n - 1 step m
  25.                         w_r = 1
  26.                         w_i = 0
  27.  
  28.                         for k=0 to m/2 - 1
  29.                                 p = j + k
  30.                                 q = p + (m \ 2)
  31.  
  32.                                 u_r = w_r*xx_r(q) - w_i*xx_i(q)
  33.                                 u_i = w_r*xx_i(q) + w_i*xx_r(q)
  34.                                 v_r = xx_r(p)
  35.                                 v_i = xx_i(p)
  36.  
  37.                                 xx_r(p) = v_r + u_r
  38.                                 xx_i(p) = v_i + u_i
  39.                                 xx_r(q) = v_r - u_r
  40.                                 xx_i(q) = v_i - u_i
  41.  
  42.                                 u_r = w_r
  43.                                 u_i = w_i
  44.                                 w_r = u_r*wm_r - u_i*wm_i
  45.                                 w_i = u_r*wm_i + u_i*wm_r
  46.                         next
  47.                 next
  48.         next
  50.  

SUB rfft
This is about 2x faster than above fft if dealing with only real values
x_r is the input signal, must be an array of size n
xx_r, xx_i must also be arrays of size n and will contain output
Since in the real FFT the second half of the output are complex conjugates of the first half, you may wish to not compute the second half and remove the last 4 lines in this SUB. I left it in just in case.
Code: QB64: [Select]
  1. sub rfft(xx_r(), xx_i(), x_r(), n)
  2.         dim w_r as double, w_i as double, wm_r as double, wm_i as double
  3.         dim u_r as double, u_i as double, v_r as double, v_i as double
  4.  
  5.         log2n = log(n/2)/log(2)
  6.  
  7.         for i=0 to n/2 - 1
  8.                 rev = 0
  9.                 for j=0 to log2n - 1
  10.                         if i and (2^j) then rev = rev + (2^(log2n - 1 - j))
  11.                 next
  12.  
  13.                 xx_r(i) = x_r(2*rev)
  14.                 xx_i(i) = x_r(2*rev + 1)
  15.         next
  16.  
  17.         for i=1 to log2n
  18.                 m = 2^i
  19.                 wm_r = cos(-2*pi/m)
  20.                 wm_i = sin(-2*pi/m)
  21.  
  22.                 for j=0 to n/2 - 1 step m
  23.                         w_r = 1
  24.                         w_i = 0
  25.  
  26.                         for k=0 to m/2 - 1
  27.                                 p = j + k
  28.                                 q = p + (m \ 2)
  29.  
  30.                                 u_r = w_r*xx_r(q) - w_i*xx_i(q)
  31.                                 u_i = w_r*xx_i(q) + w_i*xx_r(q)
  32.                                 v_r = xx_r(p)
  33.                                 v_i = xx_i(p)
  34.  
  35.                                 xx_r(p) = v_r + u_r
  36.                                 xx_i(p) = v_i + u_i
  37.                                 xx_r(q) = v_r - u_r
  38.                                 xx_i(q) = v_i - u_i
  39.  
  40.                                 u_r = w_r
  41.                                 u_i = w_i
  42.                                 w_r = u_r*wm_r - u_i*wm_i
  43.                                 w_i = u_r*wm_i + u_i*wm_r
  44.                         next
  45.                 next
  46.         next
  47.  
  48.         xx_r(n/2) = xx_r(0)
  49.         xx_i(n/2) = xx_i(0)
  50.  
  51.         for i=1 to n/2 - 1
  52.                 xx_r(n/2 + i) = xx_r(n/2 - i)
  53.                 xx_i(n/2 + i) = xx_i(n/2 - i)
  54.         next
  55.  
  56.         dim xpr as double, xpi as double
  57.         dim xmr as double, xmi as double
  58.  
  59.         for i=0 to n/2 - 1
  60.                 xpr = (xx_r(i) + xx_r(n/2 + i)) / 2
  61.                 xpi = (xx_i(i) + xx_i(n/2 + i)) / 2
  62.  
  63.                 xmr = (xx_r(i) - xx_r(n/2 + i)) / 2
  64.                 xmi = (xx_i(i) - xx_i(n/2 + i)) / 2
  65.  
  66.                 xx_r(i) = xpr + xpi*cos(2*pi*i/n) - xmr*sin(2*pi*i/n)
  67.                 xx_i(i) = xmi - xpi*sin(2*pi*i/n) - xmr*cos(2*pi*i/n)
  68.         next
  69.  
  70.         'symmetry, complex conj
  71.         for i=0 to n/2 - 1
  72.                 xx_r(n/2 + i) = xx_r(n/2 - 1 - i)
  73.                 xx_i(n/2 + i) =-xx_i(n/2 - 1 - i)
  74.         next
  76.  

As an example FYI, here is a direct unoptimized DFT for comparison. It is much slower but can be used with any n
Code: QB64: [Select]
  1. sub dft(xx_r(), xx_i(), x_r(), x_i(), n)
  2.         for i=0 to n-1
  3.                 xx_r(i) = 0
  4.                 xx_i(i) = 0
  5.                 for j=0 to n-1
  6.                         xx_r(i) = xx_r(i) + x_r(j)*cos(2*pi*i*j/n) + x_i(j)*sin(2*pi*i*j/n)
  7.                         xx_i(i) = xx_i(i) - x_r(j)*sin(2*pi*i*j/n) + x_i(j)*cos(2*pi*i*j/n)
  8.                 next
  9.         next
  11.  

if you wish to take the inverse FFT then do the following to get back x_r and x_i from xx_r and xx_i. I chose not to include a inverse flag in the sub for my own reasons, it should be easy enough to modify above SUBs to add an inverse option if you so wish.
Code: QB64: [Select]
  1. 'inverse fft
  2. for i=0 to n-1
  3.         xx_i(i) = -xx_i(i)
  5.  
  6. fft x_r(), x_i(), xx_r(), xx_i(), n
  7.  
  8. for i=0 to n-1
  9.         x_r(i) = x_r(i)/n
  10.         x_i(i) = x_i(i)/n
  12.  

Here is a basic example using and plotting all the SUBs:
Code: QB64: [Select]
  1. 'defdbl a-z
  2.  
  3. const sw = 1024
  4. const sh = 600
  5.  
  7. 'pi = 2*asin(1)
  8. pi = 4*atn(1)
  9.  
  10. declare sub rfft(xx_r(), xx_i(), x_r(), n)
  11. declare sub fft(xx_r(), xx_i(), x_r(), x_i(), n)
  12. declare sub dft(xx_r(), xx_i(), x_r(), x_i(), n)
  13.  
  14.  
  15. dim x_r(sw-1), x_i(sw-1)
  16. dim xx_r(sw-1), xx_i(sw-1)
  18.  
  19. for i=0 to sw-1
  20.         x_r(i) = 100*sin(2*pi*62.27*i/sw) + 25*cos(2*pi*132.27*i/sw)
  21.         x_i(i) = 0
  23.  
  24.  
  25. 'screenres sw, sh, 32
  26. screen _newimage(sw, sh, 32)
  27.  
  28. pset (0, sh/4 - x_r(0))
  29. for i=0 to sw-1
  30.         line -(i, sh/4 - x_r(i)), _rgb(100,100,100)
  32.  
  33. dft xx_r(), xx_i(), x_r(), x_i(), sw
  34. pset (0, 3*sh/4 - 0.1*sqr(xx_r(0)*xx_r(0) + xx_i(0)*xx_i(0)) ), _rgb(0,255,0)
  35. for i=0 to sw - 1
  36.         line -(i, 3*sh/4 - 0.1*sqr(xx_r(i)*xx_r(i) + xx_i(i)*xx_i(i)) ), _rgb(0,255,0)
  38. line (0, 3*sh/4)-step(sw,0), _rgb(0,255,0),,&h5555
  39.  
  40. t = timer
  41. for i=0 to 50
  42. fft xx_r(), xx_i(), x_r(), x_i(), sw
  44. locate 1,1
  45. print "50x fft ";timer - t
  46.  
  47. pset (0, 50+3*sh/4 - 0.1*sqr(xx_r(0)*xx_r(0) + xx_i(0)*xx_i(0)) ), _rgb(255,0,0)
  48. for i=0 to sw - 1
  49.         line -(i, 50+3*sh/4 - 0.1*sqr(xx_r(i)*xx_r(i) + xx_i(i)*xx_i(i)) ), _rgb(255,0,0)
  51. line (0, 50+3*sh/4)-step(sw,0), _rgb(255,0,0),,&h5555
  52.  
  53.  
  54. for i=0 to sw-1
  55.         xx_r(i) = 0
  56.         xx_i(i) = 0
  58.  
  59. t = timer
  60. for i=0 to 50
  61. rfft xx_r(), xx_i(), x_r(), sw
  63. locate 2,1
  64. print "50x rfft ";timer - t
  65.  
  66. pset (0, 100+3*sh/4 - 0.1*sqr(xx_r(0)*xx_r(0) + xx_i(0)*xx_i(0)) ), _rgb(255,255,0)
  67. for i=0 to sw - 1
  68.         line -(i, 100+3*sh/4 - 0.1*sqr(xx_r(i)*xx_r(i) + xx_i(i)*xx_i(i)) ), _rgb(255,255,0)
  70. line (0, 100+3*sh/4)-step(sw,0), _rgb(255,255,0),,&h5555
  71.  
  74.  
  75.  
  76. sub rfft(xx_r(), xx_i(), x_r(), n)
  77.         dim w_r as double, w_i as double, wm_r as double, wm_i as double
  78.         dim u_r as double, u_i as double, v_r as double, v_i as double
  79.  
  80.         log2n = log(n/2)/log(2)
  81.  
  82.         for i=0 to n/2 - 1
  83.                 rev = 0
  84.                 for j=0 to log2n - 1
  85.                         if i and (2^j) then rev = rev + (2^(log2n - 1 - j))
  86.                 next
  87.  
  88.                 xx_r(i) = x_r(2*rev)
  89.                 xx_i(i) = x_r(2*rev + 1)
  90.         next
  91.  
  92.         for i=1 to log2n
  93.                 m = 2^i
  94.                 wm_r = cos(-2*pi/m)
  95.                 wm_i = sin(-2*pi/m)
  96.  
  97.                 for j=0 to n/2 - 1 step m
  98.                         w_r = 1
  99.                         w_i = 0
  100.  
  101.                         for k=0 to m/2 - 1
  102.                                 p = j + k
  103.                                 q = p + (m \ 2)
  104.  
  105.                                 u_r = w_r*xx_r(q) - w_i*xx_i(q)
  106.                                 u_i = w_r*xx_i(q) + w_i*xx_r(q)
  107.                                 v_r = xx_r(p)
  108.                                 v_i = xx_i(p)
  109.  
  110.                                 xx_r(p) = v_r + u_r
  111.                                 xx_i(p) = v_i + u_i
  112.                                 xx_r(q) = v_r - u_r
  113.                                 xx_i(q) = v_i - u_i
  114.  
  115.                                 u_r = w_r
  116.                                 u_i = w_i
  117.                                 w_r = u_r*wm_r - u_i*wm_i
  118.                                 w_i = u_r*wm_i + u_i*wm_r
  119.                         next
  120.                 next
  121.         next
  122.  
  123.         xx_r(n/2) = xx_r(0)
  124.         xx_i(n/2) = xx_i(0)
  125.  
  126.         for i=1 to n/2 - 1
  127.                 xx_r(n/2 + i) = xx_r(n/2 - i)
  128.                 xx_i(n/2 + i) = xx_i(n/2 - i)
  129.         next
  130.  
  131.         dim xpr as double, xpi as double
  132.         dim xmr as double, xmi as double
  133.  
  134.         for i=0 to n/2 - 1
  135.                 xpr = (xx_r(i) + xx_r(n/2 + i)) / 2
  136.                 xpi = (xx_i(i) + xx_i(n/2 + i)) / 2
  137.  
  138.                 xmr = (xx_r(i) - xx_r(n/2 + i)) / 2
  139.                 xmi = (xx_i(i) - xx_i(n/2 + i)) / 2
  140.  
  141.                 xx_r(i) = xpr + xpi*cos(2*pi*i/n) - xmr*sin(2*pi*i/n)
  142.                 xx_i(i) = xmi - xpi*sin(2*pi*i/n) - xmr*cos(2*pi*i/n)
  143.         next
  144.  
  145.         'symmetry, complex conj
  146.         for i=0 to n/2 - 1
  147.                 xx_r(n/2 + i) = xx_r(n/2 - 1 - i)
  148.                 xx_i(n/2 + i) =-xx_i(n/2 - 1 - i)
  149.         next
  151.  
  152. sub fft(xx_r(), xx_i(), x_r(), x_i(), n)
  153.         dim w_r as double, w_i as double, wm_r as double, wm_i as double
  154.         dim u_r as double, u_i as double, v_r as double, v_i as double
  155.  
  156.         log2n = log(n)/log(2)
  157.  
  158.         'bit rev copy
  159.         for i=0 to n - 1
  160.                 rev = 0
  161.                 for j=0 to log2n - 1
  162.                         if i and (2^j) then rev = rev + (2^(log2n - 1 - j))
  163.                 next
  164.  
  165.                 xx_r(i) = x_r(rev)
  166.                 xx_i(i) = x_i(rev)
  167.         next
  168.  
  169.  
  170.         for i=1 to log2n
  171.                 m = 2^i
  172.                 wm_r = cos(-2*pi/m)
  173.                 wm_i = sin(-2*pi/m)
  174.  
  175.                 for j=0 to n - 1 step m
  176.                         w_r = 1
  177.                         w_i = 0
  178.  
  179.                         for k=0 to m/2 - 1
  180.                                 p = j + k
  181.                                 q = p + (m \ 2)
  182.  
  183.                                 u_r = w_r*xx_r(q) - w_i*xx_i(q)
  184.                                 u_i = w_r*xx_i(q) + w_i*xx_r(q)
  185.                                 v_r = xx_r(p)
  186.                                 v_i = xx_i(p)
  187.  
  188.                                 xx_r(p) = v_r + u_r
  189.                                 xx_i(p) = v_i + u_i
  190.                                 xx_r(q) = v_r - u_r
  191.                                 xx_i(q) = v_i - u_i
  192.  
  193.                                 u_r = w_r
  194.                                 u_i = w_i
  195.                                 w_r = u_r*wm_r - u_i*wm_i
  196.                                 w_i = u_r*wm_i + u_i*wm_r
  197.                         next
  198.                 next
  199.         next
  201.  
  202. sub dft(xx_r(), xx_i(), x_r(), x_i(), n)
  203.         for i=0 to n-1
  204.                 xx_r(i) = 0
  205.                 xx_i(i) = 0
  206.                 for j=0 to n-1
  207.                         xx_r(i) = xx_r(i) + x_r(j)*cos(2*pi*i*j/n) + x_i(j)*sin(2*pi*i*j/n)
  208.                         xx_i(i) = xx_i(i) - x_r(j)*sin(2*pi*i*j/n) + x_i(j)*cos(2*pi*i*j/n)
  209.                 next
  210.         next
  212.  

A common use for FFT is filtering unwanted frequencies. The following example demonstrates this, with screenshots attached
Code: QB64: [Select]
  1. 'defdbl a-z
  2.  
  3. const sw = 512
  4. const sh = 600
  5.  
  7. 'pi = 2*asin(1)
  8. pi = 4*atn(1)
  9.  
  10. declare sub fft(xx_r(), xx_i(), x_r(), x_i(), n)
  11.  
  12.  
  13. dim x_r(sw-1), x_i(sw-1)
  14. dim xx_r(sw-1), xx_i(sw-1)
  16.  
  17. for i=0 to sw-1
  18.         'x_r(i) = 100*sin(2*pi*62.27*i/sw) + 25*cos(2*pi*132.27*i/sw)
  19.         x_r(i) = 100*sin(0.08*i) + 25*cos(i)
  20.         x_i(i) = 0
  22.  
  23.  
  24. 'screenres sw, sh, 32
  25. screen _newimage(sw*2, sh, 32)
  26.  
  27. 'plot input signal
  28. pset (0, sh/4 - x_r(0))
  29. for i=0 to sw-1
  30.         line -(i, sh/4 - x_r(i)), _rgb(255,0,0)
  32. line (0, sh/4)-step(sw,0), _rgb(255,0,0),,&h5555
  33. color _rgb(255,0,0)
  34. _printstring (0,0), "input signal"
  35.  
  36. fft xx_r(), xx_i(), x_r(), x_i(), sw
  37.  
  38. 'plot its fft
  39. pset (0, 50+3*sh/4 - 0.01*sqr(xx_r(0)*xx_r(0) + xx_i(0)*xx_i(0)) ), _rgb(255,255,0)
  40. for i=0 to sw/2
  41.         line -(i*2, 50+3*sh/4 - 0.01*sqr(xx_r(i)*xx_r(i) + xx_i(i)*xx_i(i)) ), _rgb(255,255,0)
  43. line (0, 50+3*sh/4)-step(sw,0), _rgb(255,255,0),,&h5555
  44.  
  45.  
  46. 'set unwanted frequencies to zero
  47. for i=50 to sw/2
  48.         xx_r(i) = 0
  49.         xx_i(i) = 0
  50.         xx_r(sw - i) = 0
  51.         xx_i(sw - i) = 0
  53.  
  54. 'plot fft of filtered signal
  55. pset (sw, 50+3*sh/4 - 0.01*sqr(xx_r(0)*xx_r(0) + xx_i(0)*xx_i(0)) ), _rgb(255,255,0)
  56. for i=0 to sw/2
  57.         line -(sw + i*2, 50+3*sh/4 - 0.01*sqr(xx_r(i)*xx_r(i) + xx_i(i)*xx_i(i)) ), _rgb(0,155,255)
  59. line (sw, 50+3*sh/4)-step(sw,0), _rgb(0,155,255),,&h5555
  60.  
  61. 'take inverse fft
  62. for i=0 to sw-1
  63.         xx_i(i) = -xx_i(i)
  65.  
  66. fft x_r(), x_i(), xx_r(), xx_i(), sw
  67.  
  68. for i=0 to sw-1
  69.         x_r(i) = x_r(i)/sw
  70.         x_i(i) = x_i(i)/sw
  72.  
  73.  
  74. 'plot filtered signal
  75. pset (sw, sh/4 - x_r(0))
  76. for i=0 to sw-1
  77.         line -(sw + i, sh/4 - x_r(i)), _rgb(0,255,0)
  79. line (sw, sh/4)-step(sw,0), _rgb(0,255,0),,&h5555
  80.  
  81. color _rgb(0,255,0)
  82. _printstring (sw,0), "filtered signal"
  83.  
  86.  
  87. sub fft(xx_r(), xx_i(), x_r(), x_i(), n)
  88.         dim w_r as double, w_i as double, wm_r as double, wm_i as double
  89.         dim u_r as double, u_i as double, v_r as double, v_i as double
  90.  
  91.         log2n = log(n)/log(2)
  92.  
  93.         'bit rev copy
  94.         for i=0 to n - 1
  95.                 rev = 0
  96.                 for j=0 to log2n - 1
  97.                         if i and (2^j) then rev = rev + (2^(log2n - 1 - j))
  98.                 next
  99.  
  100.                 xx_r(i) = x_r(rev)
  101.                 xx_i(i) = x_i(rev)
  102.         next
  103.  
  104.  
  105.         for i=1 to log2n
  106.                 m = 2^i
  107.                 wm_r = cos(-2*pi/m)
  108.                 wm_i = sin(-2*pi/m)
  109.  
  110.                 for j=0 to n - 1 step m
  111.                         w_r = 1
  112.                         w_i = 0
  113.  
  114.                         for k=0 to m/2 - 1
  115.                                 p = j + k
  116.                                 q = p + (m \ 2)
  117.  
  118.                                 u_r = w_r*xx_r(q) - w_i*xx_i(q)
  119.                                 u_i = w_r*xx_i(q) + w_i*xx_r(q)
  120.                                 v_r = xx_r(p)
  121.                                 v_i = xx_i(p)
  122.  
  123.                                 xx_r(p) = v_r + u_r
  124.                                 xx_i(p) = v_i + u_i
  125.                                 xx_r(q) = v_r - u_r
  126.                                 xx_i(q) = v_i - u_i
  127.  
  128.                                 u_r = w_r
  129.                                 u_i = w_i
  130.                                 w_r = u_r*wm_r - u_i*wm_i
  131.                                 w_i = u_r*wm_i + u_i*wm_r
  132.                         next
  133.                 next
  134.         next
  136.  


Another common thing seems to be wanting to find an exact frequency of a signal. The following demonstrates calculating the frequency of a sine corrupted in noise and applying bin to frequency correction for extra accuracy, screenshot attached.
Code: QB64: [Select]
  1. 'defdbl a-z
  2.  
  3. const sw = 1024
  4. const sh = 600
  5.  
  7. 'pi = 2*asin(1)
  8. pi = 4*atn(1)
  9.  
  10. declare sub rfft(xx_r(), xx_i(), x_r(), n)
  11.  
  12. dim x_r(sw-1), x_i(sw-1)
  13. dim xx_r(sw-1), xx_i(sw-1)
  15.  
  16. for i=0 to sw-1
  17.         x_r(i) = 100*sin(2*pi*(sw*2000/44000)*i/sw) + (100*rnd - 50)
  19.  
  20.  
  21. 'screenres sw, sh, 32
  22. screen _newimage(sw, sh, 32)
  23.  
  24. 'plot signal
  25. pset (0, sh/4 - x_r(0))
  26. for i=0 to sw-1
  27.         line -(i, sh/4 - x_r(i)), _rgb(255,0,0)
  29. line (0, sh/4)-step(sw,0), _rgb(255,0,0),,&h5555
  30.  
  31. _printstring (0, 0), "2000 kHz signal with RND noise sampled at 44 kHz in 1024 samples"
  32.  
  33.  
  34. rfft xx_r(), xx_i(), x_r(), sw
  35.  
  36. 'plot its fft
  37. pset (0, 50+3*sh/4 - 0.005*sqr(xx_r(0)*xx_r(0) + xx_i(0)*xx_i(0)) ), _rgb(255,255,0)
  38. for i=0 to sw/2
  39.         line -(i*2, 50+3*sh/4 - 0.005*sqr(xx_r(i)*xx_r(i) + xx_i(i)*xx_i(i)) ), _rgb(255,255,0)
  41. line (0, 50+3*sh/4)-step(sw,0), _rgb(255,255,0),,&h5555
  42.  
  43.  
  44. 'find peak
  46. max = 0
  47. m = 0
  48. for i=0 to sw/2
  49.         d = 0.01*sqr(xx_r(i)*xx_r(i) + xx_i(i)*xx_i(i))
  50.         if d > max then
  51.                 max = d
  52.                 m = i
  53.         end if
  55.  
  56. _printstring (0, sh/2), "m_peak ="+str$(m)
  57. _printstring (0, sh/2 + 16), "f_peak = m_peak * 44 kHz / 1024 samples = "+str$(m*44000/1024)+" Hz"
  58.  
  59. 'apply frequency correction, only works for some signals
  61. dim u_r as double, u_i as double
  62. dim v_r as double, v_i as double
  63.  
  64. u_r = xx_r(m - 1) - xx_r(m + 1)
  65. u_i = xx_i(m - 1) - xx_i(m + 1)
  66. v_r = 2*xx_r(m) - xx_r(m - 1) - xx_r(m + 1)
  67. v_i = 2*xx_i(m) - xx_i(m - 1) - xx_i(m + 1)
  68. c = (u_r*v_r + u_i*v_i)/(v_r*v_r + v_i*v_i)
  69.  
  70. _printstring (0, sh/2 + 2*16), "f_corrected = "+str$((m+c)*44000/1024)+" Hz"
  71.  
  74.  
  75.  
  76. sub rfft(xx_r(), xx_i(), x_r(), n)
  77.         dim w_r as double, w_i as double, wm_r as double, wm_i as double
  78.         dim u_r as double, u_i as double, v_r as double, v_i as double
  79.  
  80.         log2n = log(n/2)/log(2)
  81.  
  82.         for i=0 to n/2 - 1
  83.                 rev = 0
  84.                 for j=0 to log2n - 1
  85.                         if i and (2^j) then rev = rev + (2^(log2n - 1 - j))
  86.                 next
  87.  
  88.                 xx_r(i) = x_r(2*rev)
  89.                 xx_i(i) = x_r(2*rev + 1)
  90.         next
  91.  
  92.         for i=1 to log2n
  93.                 m = 2^i
  94.                 wm_r = cos(-2*pi/m)
  95.                 wm_i = sin(-2*pi/m)
  96.  
  97.                 for j=0 to n/2 - 1 step m
  98.                         w_r = 1
  99.                         w_i = 0
  100.  
  101.                         for k=0 to m/2 - 1
  102.                                 p = j + k
  103.                                 q = p + (m \ 2)
  104.  
  105.                                 u_r = w_r*xx_r(q) - w_i*xx_i(q)
  106.                                 u_i = w_r*xx_i(q) + w_i*xx_r(q)
  107.                                 v_r = xx_r(p)
  108.                                 v_i = xx_i(p)
  109.  
  110.                                 xx_r(p) = v_r + u_r
  111.                                 xx_i(p) = v_i + u_i
  112.                                 xx_r(q) = v_r - u_r
  113.                                 xx_i(q) = v_i - u_i
  114.  
  115.                                 u_r = w_r
  116.                                 u_i = w_i
  117.                                 w_r = u_r*wm_r - u_i*wm_i
  118.                                 w_i = u_r*wm_i + u_i*wm_r
  119.                         next
  120.                 next
  121.         next
  122.  
  123.         xx_r(n/2) = xx_r(0)
  124.         xx_i(n/2) = xx_i(0)
  125.  
  126.         for i=1 to n/2 - 1
  127.                 xx_r(n/2 + i) = xx_r(n/2 - i)
  128.                 xx_i(n/2 + i) = xx_i(n/2 - i)
  129.         next
  130.  
  131.         dim xpr as double, xpi as double
  132.         dim xmr as double, xmi as double
  133.  
  134.         for i=0 to n/2 - 1
  135.                 xpr = (xx_r(i) + xx_r(n/2 + i)) / 2
  136.                 xpi = (xx_i(i) + xx_i(n/2 + i)) / 2
  137.  
  138.                 xmr = (xx_r(i) - xx_r(n/2 + i)) / 2
  139.                 xmi = (xx_i(i) - xx_i(n/2 + i)) / 2
  140.  
  141.                 xx_r(i) = xpr + xpi*cos(2*pi*i/n) - xmr*sin(2*pi*i/n)
  142.                 xx_i(i) = xmi - xpi*sin(2*pi*i/n) - xmr*cos(2*pi*i/n)
  143.         next
  144.  
  145.         'symmetry, complex conj
  146.         for i=0 to n/2 - 1
  147.                 xx_r(n/2 + i) = xx_r(n/2 - 1 - i)
  148.                 xx_i(n/2 + i) =-xx_i(n/2 - 1 - i)
  149.         next
  151.  

12
QB64 Discussion / Pattern Challenge 2
« on: July 02, 2019, 03:21:05 pm »
In spirit of bplus's thread, I challenge you to draw the attached image.  The only rule is that it has to be a fully re-sizable vector image that doesn't lose detail with change in size (ie no bitmaps/putimage).  Bonus points if you can make the circles and widths variable size. I will be very impressed if someone pulls this off!

13
Programs / PENtrIS
« on: October 11, 2018, 05:42:37 pm »
An extension of tetris to pentominos as described here https://en.wikipedia.org/wiki/Pentomino

I've never actually played this variant before other then this very program so not sure how playable and balanced it is, I am able to get several lines with a bit of luck.  Suggestions such as which pieces to add/remove, board size, etc are welcome.  Edit: fixed lines not being cleared issue

Code: QB64: [Select]
  2. deflng a-z
  3.  
  4. dim shared piece(17, 2, 4)
  5. dim shared piece_color(17)
  6. dim shared size, sw, sh
  7.  
  8. size = 35
  9. sw = 11
  10. sh = 25
  11.  
  12. redim shared board(sw - 1, sh - 1)
  13.  
  14. piece(0,0,0)=0: piece(0,1,0)=1: piece(0,2,0)=0
  15. piece(0,0,1)=0: piece(0,1,1)=1: piece(0,2,1)=0
  16. piece(0,0,2)=0: piece(0,1,2)=1: piece(0,2,2)=0
  17. piece(0,0,3)=0: piece(0,1,3)=1: piece(0,2,3)=0
  18. piece(0,0,4)=0: piece(0,1,4)=1: piece(0,2,4)=0
  19.  
  20. piece(1,0,0)=0: piece(1,1,0)=0: piece(1,2,0)=0
  21. piece(1,0,1)=0: piece(1,1,1)=0: piece(1,2,1)=0
  22. piece(1,0,2)=0: piece(1,1,2)=1: piece(1,2,2)=1
  23. piece(1,0,3)=1: piece(1,1,3)=1: piece(1,2,3)=0
  24. piece(1,0,4)=0: piece(1,1,4)=1: piece(1,2,4)=0
  25.  
  26. piece(2,0,0)=0: piece(2,1,0)=0: piece(2,2,0)=0
  27. piece(2,0,1)=0: piece(2,1,1)=0: piece(2,2,1)=0
  28. piece(2,0,2)=1: piece(2,1,2)=1: piece(2,2,2)=0
  29. piece(2,0,3)=0: piece(2,1,3)=1: piece(2,2,3)=1
  30. piece(2,0,4)=0: piece(2,1,4)=1: piece(2,2,4)=0
  31.  
  32. piece(3,0,0)=0: piece(3,1,0)=0: piece(3,2,0)=0
  33. piece(3,0,1)=0: piece(3,1,1)=1: piece(3,2,1)=0
  34. piece(3,0,2)=0: piece(3,1,2)=1: piece(3,2,2)=0
  35. piece(3,0,3)=0: piece(3,1,3)=1: piece(3,2,3)=0
  36. piece(3,0,4)=1: piece(3,1,4)=1: piece(3,2,4)=0
  37.  
  38. piece(4,0,0)=0: piece(4,1,0)=0: piece(4,2,0)=0
  39. piece(4,0,1)=0: piece(4,1,1)=1: piece(4,2,1)=0
  40. piece(4,0,2)=0: piece(4,1,2)=1: piece(4,2,2)=0
  41. piece(4,0,3)=0: piece(4,1,3)=1: piece(4,2,3)=0
  42. piece(4,0,4)=0: piece(4,1,4)=1: piece(4,2,4)=1
  43.  
  44. piece(5,0,0)=0: piece(5,1,0)=0: piece(5,2,0)=0
  45. piece(5,0,1)=0: piece(5,1,1)=0: piece(5,2,1)=0
  46. piece(5,0,2)=1: piece(5,1,2)=1: piece(5,2,2)=0
  47. piece(5,0,3)=1: piece(5,1,3)=1: piece(5,2,3)=0
  48. piece(5,0,4)=0: piece(5,1,4)=1: piece(5,2,4)=0
  49.  
  50. piece(6,0,0)=0: piece(6,1,0)=0: piece(6,2,0)=0
  51. piece(6,0,1)=0: piece(6,1,1)=0: piece(6,2,1)=0
  52. piece(6,0,2)=0: piece(6,1,2)=1: piece(6,2,2)=1
  53. piece(6,0,3)=0: piece(6,1,3)=1: piece(6,2,3)=1
  54. piece(6,0,4)=0: piece(6,1,4)=1: piece(6,2,4)=0
  55.  
  56. piece(7,0,0)=0: piece(7,1,0)=0: piece(7,2,0)=0
  57. piece(7,0,1)=0: piece(7,1,1)=1: piece(7,2,1)=0
  58. piece(7,0,2)=0: piece(7,1,2)=1: piece(7,2,2)=0
  59. piece(7,0,3)=1: piece(7,1,3)=1: piece(7,2,3)=0
  60. piece(7,0,4)=1: piece(7,1,4)=0: piece(7,2,4)=0
  61.  
  62. piece(8,0,0)=0: piece(8,1,0)=0: piece(8,2,0)=0
  63. piece(8,0,1)=0: piece(8,1,1)=1: piece(8,2,1)=0
  64. piece(8,0,2)=0: piece(8,1,2)=1: piece(8,2,2)=0
  65. piece(8,0,3)=0: piece(8,1,3)=1: piece(8,2,3)=1
  66. piece(8,0,4)=0: piece(8,1,4)=0: piece(8,2,4)=1
  67.  
  68. piece(9,0,0)=0: piece(9,1,0)=0: piece(9,2,0)=0
  69. piece(9,0,1)=0: piece(9,1,1)=0: piece(9,2,1)=0
  70. piece(9,0,2)=1: piece(9,1,2)=1: piece(9,2,2)=1
  71. piece(9,0,3)=0: piece(9,1,3)=1: piece(9,2,3)=0
  72. piece(9,0,4)=0: piece(9,1,4)=1: piece(9,2,4)=0
  73.  
  74. piece(10,0,0)=0: piece(10,1,0)=0: piece(10,2,0)=0
  75. piece(10,0,1)=0: piece(10,1,1)=0: piece(10,2,1)=0
  76. piece(10,0,2)=0: piece(10,1,2)=0: piece(10,2,2)=0
  77. piece(10,0,3)=1: piece(10,1,3)=0: piece(10,2,3)=1
  78. piece(10,0,4)=1: piece(10,1,4)=1: piece(10,2,4)=1
  79.  
  80. piece(11,0,0)=0: piece(11,1,0)=0: piece(11,2,0)=0
  81. piece(11,0,1)=0: piece(11,1,1)=0: piece(11,2,1)=0
  82. piece(11,0,2)=0: piece(11,1,2)=0: piece(11,2,2)=1
  83. piece(11,0,3)=0: piece(11,1,3)=0: piece(11,2,3)=1
  84. piece(11,0,4)=1: piece(11,1,4)=1: piece(11,2,4)=1
  85.  
  86. piece(12,0,0)=0: piece(12,1,0)=0: piece(12,2,0)=0
  87. piece(12,0,1)=0: piece(12,1,1)=0: piece(12,2,1)=0
  88. piece(12,0,2)=0: piece(12,1,2)=0: piece(12,2,2)=1
  89. piece(12,0,3)=0: piece(12,1,3)=1: piece(12,2,3)=1
  90. piece(12,0,4)=1: piece(12,1,4)=1: piece(12,2,4)=0
  91.  
  92. piece(13,0,0)=0: piece(13,1,0)=0: piece(13,2,0)=0
  93. piece(13,0,1)=0: piece(13,1,1)=0: piece(13,2,1)=0
  94. piece(13,0,2)=0: piece(13,1,2)=1: piece(13,2,2)=0
  95. piece(13,0,3)=1: piece(13,1,3)=1: piece(13,2,3)=1
  96. piece(13,0,4)=0: piece(13,1,4)=1: piece(13,2,4)=0
  97.  
  98. piece(14,0,0)=0: piece(14,1,0)=0: piece(14,2,0)=0
  99. piece(14,0,1)=0: piece(14,1,1)=1: piece(14,2,1)=0
  100. piece(14,0,2)=1: piece(14,1,2)=1: piece(14,2,2)=0
  101. piece(14,0,3)=0: piece(14,1,3)=1: piece(14,2,3)=0
  102. piece(14,0,4)=0: piece(14,1,4)=1: piece(14,2,4)=0
  103.  
  104. piece(15,0,0)=0: piece(15,1,0)=0: piece(15,2,0)=0
  105. piece(15,0,1)=0: piece(15,1,1)=1: piece(15,2,1)=0
  106. piece(15,0,2)=0: piece(15,1,2)=1: piece(15,2,2)=1
  107. piece(15,0,3)=0: piece(15,1,3)=1: piece(15,2,3)=0
  108. piece(15,0,4)=0: piece(15,1,4)=1: piece(15,2,4)=0
  109.  
  110. piece(16,0,0)=0: piece(16,1,0)=0: piece(16,2,0)=0
  111. piece(16,0,1)=0: piece(16,1,1)=0: piece(16,2,1)=0
  112. piece(16,0,2)=0: piece(16,1,2)=1: piece(16,2,2)=1
  113. piece(16,0,3)=0: piece(16,1,3)=1: piece(16,2,3)=0
  114. piece(16,0,4)=1: piece(16,1,4)=1: piece(16,2,4)=0
  115.  
  116. piece(17,0,0)=0: piece(17,1,0)=0: piece(17,2,0)=0
  117. piece(17,0,1)=0: piece(17,1,1)=0: piece(17,2,1)=0
  118. piece(17,0,2)=1: piece(17,1,2)=1: piece(17,2,2)=0
  119. piece(17,0,3)=0: piece(17,1,3)=1: piece(17,2,3)=0
  120. piece(17,0,4)=0: piece(17,1,4)=1: piece(17,2,4)=1
  121.  
  122. screen _newimage(sw*size, sh*size, 32)
  123.  
  124. piece_color(0) = _rgb(255,0,0)
  125. piece_color(1) = _rgb(255,145,0)
  126. piece_color(2) = _rgb(255,200,211)
  127. piece_color(3) = _rgb(0,255,220)
  128. piece_color(4) = _rgb(0,230,255)
  129. piece_color(5) = _rgb(0,170,10)
  130. piece_color(6) = _rgb(0,250,20)
  131. piece_color(7) = _rgb(128,230,0)
  132. piece_color(8) = _rgb(80,150,0)
  133. piece_color(9) = _rgb(0,200,0)
  134. piece_color(10) = _rgb(50,160,170)
  135. piece_color(11) = _rgb(50,110,175)
  136. piece_color(12) = _rgb(50,50,175)
  137. piece_color(13) = _rgb(110,50,175)
  138. piece_color(14) = _rgb(210,0,255)
  139. piece_color(15) = _rgb(110,0,130)
  140. piece_color(16) = _rgb(255,0,140)
  141. piece_color(17) = _rgb(170,0,100)
  142.  
  144.  
  145. redraw = -1
  146.  
  147. speed = 2
  148. lines = 0
  149. pause = 0
  150. putpiece = 0
  151. startx = (sw - 4)/2
  152.  
  153. pn = int(rnd*18)
  154. px = startx
  155. py = -2
  156. rot = 0
  157.  
  158. title$ = "lines="+ltrim$(str$(lines))+",speed="++ltrim$(str$(speed))
  159. _title title$
  160.  
  161. t = timer
  162.  
  164.         if (timer - t) > (1/speed) and not pause then
  165.                 if valid(pn, px, py + 1, rot) then py = py + 1 else putpiece = -1
  166.  
  167.                 t = timer
  168.                 redraw = -1
  169.         end if
  170.  
  171.         if putpiece then
  172.                 if valid(pn, px, py, rot) then
  173.                         n = place(pn, px, py, rot)
  174.                         if n then
  175.                                 lines = lines + n
  176.                                 title$ = "lines="+ltrim$(str$(lines))+",speed="++ltrim$(str$(speed))
  177.                                 _title title$
  178.                         end if
  179.                 end if
  180.  
  181.                 pn = int(rnd*18)
  182.                 px = startx
  183.                 py = -2
  184.                 rot = 0
  185.  
  186.                 putpiece = 0
  187.                 redraw = -1
  188.  
  189.                 if not valid(pn, px, py, rot) then
  190.                         for y=0 to sh-1
  191.                                 for x=0 to sw-1
  192.                                         board(x, y) = 0
  193.                                 next
  194.                         next
  195.                         lines = 0
  196.                         title$ = "lines="+ltrim$(str$(lines))+",speed="++ltrim$(str$(speed))
  197.                         _title title$
  198.                 end if
  199.         end if
  200.  
  201.         if redraw then
  202.                 line (0,0)-(sw*size, sh*size),_rgb(0,0,0),bf
  203.                 for y=0 to sh - 1
  204.                         for x=0 to sw - 1
  205.                                 if board(x, y) <> 0 then
  206.                                         line (x*size, y*size)-step(size-2, size-2), piece_color(board(x, y)-1), bf
  207.                                 else
  208.                                         line (x*size, y*size)-step(size-2, size-2), _rgb(50,50,50), b
  209.                                 end if
  210.                         next
  211.                 next
  212.  
  213.                 for y=0 to 4
  214.                         for x=0 to 2
  215.                                 rotate xx, yy, x, y, pn, rot
  216.                                 if piece(pn, x, y) then line ((px + xx)*size, (py + yy)*size)-step(size-2, size-2), piece_color(pn), bf
  217.                         next
  218.                 next
  219.  
  220.                 _display
  221.                 redraw = 0
  222.         end if
  223.  
  224.         k = _keyhit
  225.         if k then
  226.                 shift = _keydown(100304) or _keydown(100303)
  227.                 select case k
  228.                 case 18432 'up
  229.                         if valid(pn, px, py, (rot + 1) mod 4) then rot = (rot + 1) mod 4
  230.                         pause = 0
  231.                 case 19200 'left
  232.                         if shift then
  233.                                 for xx=0 to sw-1
  234.                                         if not valid(pn, px - xx, py, rot) then exit for
  235.                                 next
  236.                                 px = px - xx + 1
  237.                         else
  238.                                 if valid(pn, px - 1, py, rot) then px = px - 1
  239.                         end if
  240.                         pause = 0
  241.                 case 19712 'right
  242.                         if shift then
  243.                                 for xx=px to sw-1
  244.                                         if not valid(pn, xx, py, rot) then exit for
  245.                                 next
  246.                                 px = xx - 1
  247.                         else
  248.                                 if valid(pn, px + 1, py, rot) then px = px + 1
  249.                         end if
  250.                         pause = 0
  251.                 case 20480, 32 'down
  252.                         if shift or k = 32 then
  253.                                 for yy=py to sh-1
  254.                                         if not valid(pn, px, yy, rot) then exit for
  255.                                 next
  256.                                 py = yy - 1
  257.                                 putpiece = -1
  258.                         else
  259.                                 if valid(pn, px, py + 1, rot) then py = py + 1
  260.                         end if
  261.                         pause = 0
  262.                 case 112 'p
  263.                         pause = not pause
  264.                 case 13 'enter
  265.                         for y=0 to sh-1
  266.                                 for x=0 to sw-1
  267.                                         board(x, y) = 0
  268.                                 next
  269.                         next
  270.                         pn = int(rnd*17)
  271.                         px = startx
  272.                         py = -2
  273.                         rot = 0
  274.                         putpiece = 0
  275.                         lines = 0
  276.                         title$ = "lines="+ltrim$(str$(lines))+",speed="++ltrim$(str$(speed))
  277.                         _title title$
  278.                 case 43, 61 'plus
  279.                         if speed < 100 then
  280.                                 speed = speed + 1
  281.                                 title$ = "lines="+ltrim$(str$(lines))+",speed="++ltrim$(str$(speed))
  282.                                 _title title$
  283.                         end if
  284.                 case 95, 45
  285.                         if speed > 1 then
  286.                                 speed = speed - 1
  287.                                 title$ = "lines="+ltrim$(str$(lines))+",speed="++ltrim$(str$(speed))
  288.                                 _title title$
  289.                         end if
  290.                 case 27
  291.                         exit do
  292.                 end select
  293.  
  294.                 redraw = -1
  295.         end if
  298.  
  299.  
  300. sub rotate(xx, yy, x, y, pn, rot)
  301.         select case pn
  302.         case 0
  303.                 rot_new = rot mod 2
  304.         case else
  305.                 rot_new = rot
  306.         end select
  307.  
  308.         select case rot_new
  309.         case 0
  310.                 xx = x
  311.                 yy = y
  312.         case 1
  313.                 if pn = 0 then
  314.                         xx = y - 1
  315.                         yy = 3 - x
  316.                 elseif pn = 14 or pn = 15 then
  317.                         xx = y - 1
  318.                         yy = 3 - x
  319.                 else
  320.                         xx = y - 2
  321.                         yy = 4 - x
  322.                 end if
  323.         case 2
  324.                 if pn = 14 or pn = 15 then
  325.                         xx = 2 - x
  326.                         yy = 4 - y
  327.                 else
  328.                         xx = 2 - x
  329.                         yy = 6 - y
  330.                 end if
  331.         case 3
  332.                 if pn = 14 or pn = 15 then
  333.                         xx = 3 - y
  334.                         yy = x + 1
  335.                 else
  336.                         xx = 4 - y
  337.                         yy = x + 2
  338.                 end if
  339.         end select
  341.  
  342. function valid(pn, px, py, rot)
  343.         for y=0 to 4
  344.                 for x=0 to 2
  345.                         rotate xx, yy, x, y, pn, rot
  346.                         if py + yy >= 0 then
  347.                                 if piece(pn, x, y) then
  348.                                         if (px + xx >= sw) or (px + xx < 0) then
  349.                                                 valid = 0
  350.                                                 exit function
  351.                                         end if
  352.                                         if (py + yy >= sh) then
  353.                                                 valid = 0
  354.                                                 exit function
  355.                                         end if
  356.                                         'if (py >= 0) then
  357.                                         if board(px + xx, py + yy) then
  358.                                                 valid = 0
  359.                                                 exit function
  360.                                         end if
  361.                                         'end if
  362.                                 end if
  363.                         end if
  364.                 next
  365.         next
  366.  
  367.         valid = -1
  369.  
  370. function place(pn, px, py, rot)
  371.         lines = 0
  372.  
  373.         for y=0 to 4
  374.                 for x=0 to 2
  375.                         rotate xx, yy, x, y, pn, rot
  376.                         if py + yy >= 0 then if piece(pn, x, y) then board(px + xx, py + yy) = pn + 1
  377.                 next
  378.         next
  379.  
  380.         'clear lines
  381.         for y=py-5 to py+5
  382.                 if y>=0 and y<sh then
  383.                         clr = -1
  384.                         for x=0 to sw - 1
  385.                                 if board(x, y) = 0 then
  386.                                         clr = 0
  387.                                         exit for
  388.                                 end if
  389.                         next
  390.  
  391.                         if clr then
  392.                                 lines = lines + 1
  393.                                 for yy=y to 1 step -1
  394.                                         for x=0 to sw-1
  395.                                                 board(x, yy) = board(x, yy-1)
  396.                                         next
  397.                                 next
  398.                         end if
  399.                 end if
  400.         next
  401.  
  402.         place = lines
  404.  

14
Programs / Tetris
« on: September 24, 2018, 04:06:21 pm »
clean and simple tetris implementation. you can change variables size, sw, and sh for custom board sizes.

controls:
* arrow keys: movement, up: rotate
* shift + left/right/down: hard left/right/drop
* spacebar: hard drop
* +/-: change speed
* p: pause
* Enter: restart
* Esc: quit

Code: QB64: [Select]
  2. deflng a-z
  3.  
  4. dim shared piece(6, 3, 1)
  5. dim shared piece_color(6)
  6. dim shared size, sw, sh
  7.  
  8. size = 35
  9. sw = 10
  10. sh = 20
  11.  
  12. redim shared board(sw - 1, sh - 1)
  13.  
  14. piece(0,0,0)=0: piece(0,1,0)=1: piece(0,2,0)=1: piece(0,3,0)=0
  15. piece(0,0,1)=0: piece(0,1,1)=1: piece(0,2,1)=1: piece(0,3,1)=0
  16. piece(1,0,0)=1: piece(1,1,0)=1: piece(1,2,0)=1: piece(1,3,0)=1
  17. piece(1,0,1)=0: piece(1,1,1)=0: piece(1,2,1)=0: piece(1,3,1)=0
  18. piece(2,0,0)=0: piece(2,1,0)=0: piece(2,2,0)=1: piece(2,3,0)=1
  19. piece(2,0,1)=0: piece(2,1,1)=1: piece(2,2,1)=1: piece(2,3,1)=0
  20. piece(3,0,0)=0: piece(3,1,0)=1: piece(3,2,0)=1: piece(3,3,0)=0
  21. piece(3,0,1)=0: piece(3,1,1)=0: piece(3,2,1)=1: piece(3,3,1)=1
  22. piece(4,0,0)=0: piece(4,1,0)=1: piece(4,2,0)=1: piece(4,3,0)=1
  23. piece(4,0,1)=0: piece(4,1,1)=0: piece(4,2,1)=1: piece(4,3,1)=0
  24. piece(5,0,0)=0: piece(5,1,0)=1: piece(5,2,0)=1: piece(5,3,0)=1
  25. piece(5,0,1)=0: piece(5,1,1)=1: piece(5,2,1)=0: piece(5,3,1)=0
  26. piece(6,0,0)=0: piece(6,1,0)=1: piece(6,2,0)=1: piece(6,3,0)=1
  27. piece(6,0,1)=0: piece(6,1,1)=0: piece(6,2,1)=0: piece(6,3,1)=1
  28.  
  29. screen _newimage(sw*size, sh*size, 32)
  30.  
  31. piece_color(0) = _rgb(0,200,0)
  32. piece_color(1) = _rgb(200,0,0)
  33. piece_color(2) = _rgb(156,85,211)
  34. piece_color(3) = _rgb(219,112,147)
  35. piece_color(4) = _rgb(0,100,250)
  36. piece_color(5) = _rgb(230,197,92)
  37. piece_color(6) = _rgb(0,128,128)
  38.  
  40.  
  41. redraw = -1
  42.  
  43. speed = 10
  44. lines = 0
  45. pause = 0
  46. putpiece = 0
  47. startx = (sw - 4)/2
  48.  
  49. pn = int(rnd*7)
  50. px = startx
  51. py = 1
  52. rot = 0
  53.  
  54. title$ = "lines="+ltrim$(str$(lines))+",speed="++ltrim$(str$(speed))
  55. _title title$
  56.  
  57. t = timer
  58.  
  60.         if (timer - t) > (1/speed) and not pause then
  61.                 if valid(pn, px, py + 1, rot) then py = py + 1 else putpiece = -1
  62.  
  63.                 t = timer
  64.                 redraw = -1
  65.         end if
  66.  
  67.         if putpiece then
  68.                 if valid(pn, px, py, rot) then
  69.                         n = place(pn, px, py, rot)
  70.                         if n then
  71.                                 lines = lines + n
  72.                                 title$ = "lines="+ltrim$(str$(lines))+",speed="++ltrim$(str$(speed))
  73.                                 _title title$
  74.                         end if
  75.                 end if
  76.  
  77.                 pn = int(rnd*7)
  78.                 px = startx
  79.                 py = 0
  80.                 rot = 0
  81.  
  82.                 putpiece = 0
  83.                 redraw = -1
  84.  
  85.                 if not valid(pn, px, py, rot) then
  86.                         for y=0 to sh-1
  87.                                 for x=0 to sw-1
  88.                                         board(x, y) = 0
  89.                                 next
  90.                         next
  91.                         lines = 0
  92.                         title$ = "lines="+ltrim$(str$(lines))+",speed="++ltrim$(str$(speed))
  93.                         _title title$
  94.                 end if
  95.         end if
  96.  
  97.         if redraw then
  98.                 line (0,0)-(sw*size, sh*size),_rgb(0,0,0),bf
  99.                 for y=0 to sh - 1
  100.                         for x=0 to sw - 1
  101.                                 if board(x, y) <> 0 then
  102.                                         line (x*size, y*size)-step(size-2, size-2), piece_color(board(x, y)-1), bf
  103.                                 else
  104.                                         line (x*size, y*size)-step(size-2, size-2), _rgb(50,50,50), b
  105.                                 end if
  106.                         next
  107.                 next
  108.  
  109.                 for y=0 to 1
  110.                         for x=0 to 3
  111.                                 rotate xx, yy, x, y, pn, rot
  112.                                 if piece(pn, x, y) then line ((px + xx)*size, (py + yy)*size)-step(size-2, size-2), piece_color(pn), bf
  113.                         next
  114.                 next
  115.  
  116.                 _display
  117.                 redraw = 0
  118.         end if
  119.  
  120.         k = _keyhit
  121.         if k then
  122.                 shift = _keydown(100304) or _keydown(100303)
  123.                 select case k
  124.                 case 18432 'up
  125.                         if valid(pn, px, py, (rot + 1) mod 4) then rot = (rot + 1) mod 4
  126.                         pause = 0
  127.                 case 19200 'left
  128.                         if shift then
  129.                                 for xx=0 to sw-1
  130.                                         if not valid(pn, px - xx, py, rot) then exit for
  131.                                 next
  132.                                 px = px - xx + 1
  133.                         else
  134.                                 if valid(pn, px - 1, py, rot) then px = px - 1
  135.                         end if
  136.                         pause = 0
  137.                 case 19712 'right
  138.                         if shift then
  139.                                 for xx=px to sw-1
  140.                                         if not valid(pn, xx, py, rot) then exit for
  141.                                 next
  142.                                 px = xx - 1
  143.                         else
  144.                                 if valid(pn, px + 1, py, rot) then px = px + 1
  145.                         end if
  146.                         pause = 0
  147.                 case 20480, 32 'down
  148.                         if shift or k = 32 then
  149.                                 for yy=py to sh-1
  150.                                         if not valid(pn, px, yy, rot) then exit for
  151.                                 next
  152.                                 py = yy - 1
  153.                                 putpiece = -1
  154.                         else
  155.                                 if valid(pn, px, py + 1, rot) then py = py + 1
  156.                         end if
  157.                         pause = 0
  158.                 case 112 'p
  159.                         pause = not pause
  160.                 case 13 'enter
  161.                         for y=0 to sh-1
  162.                                 for x=0 to sw-1
  163.                                         board(x, y) = 0
  164.                                 next
  165.                         next
  166.                         pn = int(rnd*7)
  167.                         px = startx
  168.                         py = 0
  169.                         rot = 0
  170.                         putpiece = 0
  171.                         lines = 0
  172.                         title$ = "lines="+ltrim$(str$(lines))+",speed="++ltrim$(str$(speed))
  173.                         _title title$
  174.                 case 43, 61 'plus
  175.                         if speed < 100 then
  176.                                 speed = speed + 1
  177.                                 title$ = "lines="+ltrim$(str$(lines))+",speed="++ltrim$(str$(speed))
  178.                                 _title title$
  179.                         end if
  180.                 case 95, 45
  181.                         if speed > 1 then
  182.                                 speed = speed - 1
  183.                                 title$ = "lines="+ltrim$(str$(lines))+",speed="++ltrim$(str$(speed))
  184.                                 _title title$
  185.                         end if
  186.                 case 27
  187.                         exit do
  188.                 end select
  189.  
  190.                 redraw = -1
  191.         end if
  194.  
  195. sub rotate(xx, yy, x, y, pn, rot)
  196.         select case pn
  197.         case 0
  198.                 rot_new = 0
  199.         case 1 to 3
  200.                 rot_new = rot mod 2
  201.         case 4 to 6
  202.                 rot_new = rot
  203.         end select
  204.  
  205.         select case rot_new
  206.         case 0
  207.                 xx = x
  208.                 yy = y
  209.         case 1
  210.                 xx = y + 2
  211.                 yy = 2 - x
  212.         case 2
  213.                 xx = 4 - x
  214.                 yy = 1 - y
  215.         case 3
  216.                 xx = 2 - y
  217.                 yy = x - 1
  218.         end select
  220.  
  221. function valid(pn, px, py, rot)
  222.         for y=0 to 1
  223.                 for x=0 to 3
  224.                         rotate xx, yy, x, y, pn, rot
  225.                         if py + yy >= 0 then
  226.                                 if piece(pn, x, y) then
  227.                                         if (px + xx >= sw) or (px + xx < 0) then
  228.                                                 valid = 0
  229.                                                 exit function
  230.                                         end if
  231.                                         if (py + yy >= sh) then
  232.                                                 valid = 0
  233.                                                 exit function
  234.                                         end if
  235.                                         if (py >= 0) then
  236.                                         if board(px + xx, py + yy) then
  237.                                                 valid = 0
  238.                                                 exit function
  239.                                         end if
  240.                                         end if
  241.                                 end if
  242.                         end if
  243.                 next
  244.         next
  245.  
  246.         valid = -1
  248.  
  249. function place(pn, px, py, rot)
  250.         lines = 0
  251.  
  252.         for y=0 to 1
  253.                 for x=0 to 3
  254.                         rotate xx, yy, x, y, pn, rot
  255.                         if py + yy >= 0 then if piece(pn, x, y) then board(px + xx, py + yy) = pn + 1
  256.                 next
  257.         next
  258.  
  259.         'clear lines
  260.         for y=py-1 to py+2
  261.                 if y>=0 and y<sh then
  262.                         clr = -1
  263.                         for x=0 to sw - 1
  264.                                 if board(x, y) = 0 then
  265.                                         clr = 0
  266.                                         exit for
  267.                                 end if
  268.                         next
  269.  
  270.                         if clr then
  271.                                 lines = lines + 1
  272.                                 for yy=y to 1 step -1
  273.                                         for x=0 to sw-1
  274.                                                 board(x, yy) = board(x, yy-1)
  275.                                         next
  276.                                 next
  277.                         end if
  278.                 end if
  279.         next
  280.  
  281.         place = lines
  283.  

15
QB64 Discussion / interesting plot
« on: July 23, 2018, 07:12:33 pm »
Code: QB64: [Select]
  1. deflng a-z
  4. for u=0 to 640
  5.         uu=2.8 + 1.2*u/640
  6.         for x=0 to 480
  7.                 xx = x/480
  8.                 for i=0 to 500
  9.                         xx = uu*xx*(1-xx)
  10.                 next
  11.                 pset(u,480*(1-xx))
  12.         next
  16.  
  17.  

Pages: [1] 2