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 - B+

Pages: [1] 2
1
Code snippets / Aquarium with swaying kelp
« on: October 14, 2016 »
Well I got the kelp to sway but the movie is a little blinky...   :(

Code: [Select]
'aquarium with kelp.txt for NaaLaa 6 [B+=MGA] 2016-10-14
'tranlated from previous code

randomize(time())
radians

visible:
xmax = 600
ymax = 300
pi# = 3.1415
kelp[xmax + 1][ymax + 1]

set window 180, 40, xmax, ymax
set redraw false


hidden:
'setup n fish x, y, length, dx (x speed), plasma colors r,b,g
n = 26
r# = 0.0 ; g# = 0.0 ; b# = 0.0
x[n]; y[n]; l[n]; dx[n]; rr#[n]; gg#[n]; bb#[n]
for i = 0 to n-1
x[i] = rnd(xmax)
y[i] = rnd(ymax)
l[i] = int(float(rnd(xmax)) * 0.0625 + 18.0)
dx[i] = rnd(4) + 2
d = rnd(2)
if d <> 0 then dx[i] = dx[i] * -1
r# = r# + 0.2     ; if r# > 0.5 then r# = 0.02   ; rr#[i] = r#
g# = g# + 0.005   ; if g# > 0.5 then g# = 0.005  ; gg#[i] = g#
b# = b# + 0.01    ; if b# > 0.5 then b# = 0.01   ; bb#[i] = b#
next

'setup kelp
set color 0, 128, 0
set caret 100, 130
wln "Please wait, growing the kelp..."
redraw
_growKelp
z = 0
while 1
'clr screen with water grad
for i = 0 to ymax-1
set color 0, 0, 255 - int( float#(i) / float#(ymax)  * 255.0 )
draw line 0, i, xmax, i
next
z = z + 1
z = z % 20
_showKelp z
'draw fish
for i = 0 to n-1
x[i] = x[i] + dx[i] + rnd(3)
if float#(x[i]) + 1.25 * float#(l[i]) < 0.0 then dx[i] = -1 * dx[i]
if float#(x[i]) - 1.25 * float#(l[i]) > float#(xmax) then dx[i] = -1 * dx[i]
y[i] = y[i] + rnd(3) - 1
for ra = 1 to l[i]
rd = int(127.0 + 127.0 * sin(rr#[i] * 3.0 * float#(ra)))
gn = int(127.0 + 127.0 * sin(gg#[i] * 3.0 * float#(ra)))
bl = int(127.0 + 127.0 * sin(bb#[i] * 3.0 * float#(ra)))
set color rd, gn, bl
if dx[i] < 0 then
draw line x[i] + ra, y[i] - ra, x[i] + ra, y[i] + ra
else
draw line x[i] - ra, y[i] - ra, x[i] - ra, y[i] + ra
endif
next
for ra = 5 to int(0.3 * float#(l[i]))
rd = int(127.0 + 127.0 * sin(rr#[i] * float#(ra)))
gn = int(127.0 + 127.0 * sin(gg#[i] * float#(ra)))
bl = int(127.0 + 127.0 * sin(bb#[i] * float#(ra)))
set color rd, gn, bl
if dx[i] < 0 then
draw line x[i] + l[i] + ra, y[i] - ra, x[i] + l[i] + ra, y[i] + ra
else
draw line x[i] - l[i] - ra, y[i] - ra, x[i] - l[i] - ra, y[i] + ra
endif
next
if dx[i] < 0 then
set colori 0
      _rmDisk x[i] + int( 0.25 * float#(l[i]) ), y[i], int( 0.1 * float#(l[i]) )
set colori 0xFFFF00
      _circByLine x[i] + int(0.25 * float#(l[i]) ), y[i], int( 0.06 * float#(l[i]) )
else
set colori 0x000000
      _rmDisk x[i] - int(0.25 * float#(l[i]) ), y[i], int( 0.1 * float#(l[i]) )
set colori 0xFFFF00
      _circByLine x[i] - int(0.25 * float#(l[i])), y[i], int( 0.06 * float#(l[i]) )
endif
next
redraw
wait 25
wend

procedure circByLine(x, y, r) 'may 25, 2015
rsq = r * r; ly = 0
for cx = r downto 0
cy = int(sqr#(float(rsq - cx * cx)))
x1 = x + cx; x2 = x - cx; y1 = y + ly; y2 = y+cy; y3 = y - ly; y4 = y - cy
draw line x1, y1, x1, y2
draw line x1, y3, x1, y4
draw line x2, y1, x2, y2
draw line x2, y3, x2, y4
ly = cy
next
endproc

procedure rmDisk(x, y, r)
rsq = r * r
for a = 0 to r
b = int(sqr(float(rsq - a * a)))
x1 = x + a; x2 = x - a; y1 = y - b; y2 = y + b
draw line x1, y1, x1, y2
draw line x2, y1, x2, y2
next
endproc

procedure growKelp()
d = 1
while d <= ymax
x = rnd(xmax)
y = d
c = 0
while y <> 0 and c = 0
if y - 1 >= 0 and x + 1 <= xmax + 1 and x - 1 >= 0
c = kelp[x][ y - 1]
      if rnd(2) = 1 and kelp[x - 1][ y - 1] <> 0 then c = kelp[x - 1][y - 1]
      if c = 0
      c = kelp[x - 1][y - 1]
        c = kelp[x + 1][y - 1]
        y = y - 1
endif
else
c = (x % 23) + 1
endif
wend
if c = 0 then c = (x % 23) + 1
kelp[x][y] = c
    if y = d - 1 then d = d + 1
wend
endproc

procedure showKelp(z)
    for y = 0 to ymax
dy# = (float(y) * pi# / 180.0 + float(z)) * (float(y) / float(ymax))
xoff = int(5.0 * sin(float(dy#)))
        for x = 0 to xmax
            if kelp[x][y] > 0 and kelp[x][y] < 16 then
                set color 0, kelp[x][y] * 16, 0
                set pixel x + xoff, ymax - y
            endif
        next
    next
endproc

2
Code snippets / Another banana Mandelbrot
« on: September 21, 2016 »
Sorry, I had a few extra bananas hanging around after shooting down some gorillas:

Code: [Select]
'another banana mandelbrot.txt for Naalaa [B+=MGA] 2016-09-021
t = time()
XMAX = 700
YMAX = 600
set window 200, 40, XMAX, YMAX
set redraw off
load image 1, "assets/banana.png"
set color 255, 255, 255
draw rect 0, 0, XMAX, YMAX, true
for y = -30 to 30
  for x = -5 to 64
    m# = 0.0 ; r# = 0.0
    for k = 0 to 15
      j# = r# * r# - m# * m# - 2.0 + float(x) / 25.0
      m# = 2.0 * r# * m# + float(y) / 25.0
      r# = j#
      l = k % 16
      if j# * j# + m# * m# > 11.0 then k = 112
    next
    if l = 15
clear transformation
translate (float(x) + 5.0) * 10.0, (float(y) + 30.0) * 10.0
scale 1.0, 1.0
bananaRot# = float(rnd(360))
rotate bananaRot#
draw image 1
'set colori 0
'draw rect (x+5)*10, (y+30)*10, 10,  10, true
endif
  next
next
set caret 10, 10
set colori 0
wln "time ", (time() - t), " ms"
redraw
wait keydown

3
Code snippets / Connett Circles
« on: September 17, 2016 »
http://shawweb.myzen.co.uk/stephen/sdlbasic.htm

Code: [Select]
'patterns.txt Naalaa [B+=MGA] from
'pattern.bas for SmallBASIC 0.12.0 2015-11-27 Peter W & MGA/B+
'pixel colorized version
constant:
xmax = 800
ymax = 600
hidden:
set window 100, 40, xmax, ymax
set redraw false
 
s# = 500.0
while 1
set colori 0xffffff
cls
set colori 0
for y = 0 to ymax
for x = 0 to xmax
a# = float(x) * s / 600.0
b# = float(y) * s / 600.0
c# = a# * a# + b# * b#
d# = c# / 2.0
d# = d# - float(int(d#))
if d# < 0.25
r = int(d# * 4.0 * 255.0)
set color r, 0, 0
elseif d# < 0.5
g = int(d# * 2.0 * 255.0)
set color 0, g, 0
elseif d# < 0.75
bl = int(d# * 4.0 / 3.0 * 255.0)
set color 0, 0, bl
else
set color 0, 0, 0
endif
draw pixel x, y
next
next
redraw
wait 200
if keydown(27, true) then end
s# = s# + 5.0
if s# > 1000.0 then s# = 5.0
wend


4
Code snippets / Analog (and digital) Clock
« on: September 13, 2016 »
Testing KSINK import. Works for me!

Code: [Select]
' clock.txt [B+=MGA] 2016-09-12
' test using this ksink library and dll

import "ksink.lib"
'needs ksink.dll too in same folder

constant:
XMAX = 400
YMAX = 400
XC = 200
YC = 200
HR# = 4.0
HL1# = 175.0
HL2# = 10.0
HhandR# = 15.0
MhandR# = 8.0
ShandR# = 5.0
HhandL# = 105.0
MhandL# = 150.0
ShandL# = 160.0
visible:

hidden:

set window 100, 40, XMAX, YMAX
set redraw false
Pstart = xy2P(XC, YC)
do
set colori 0
cls
'digital time
set colori 0xffffff
set caret 5, 5
h$ = str(GetHour() + 0)
if len(h$) = 1 then h$ = "0" + h$
m$ = str(GetMinute() + 0) 
if len(m$) = 1 then m$ = "0" + m$
s$ = str(GetSecond() + 0)
if len(s$) = 1 then s$ = "0" + s$
wln h$, ":", m$, ":", s$

'allow esc
set caret 360, 380
wln "esc"

'analog time
'draw hour markers
for i = 0 to 11
'this draws an invisble arm out to hour markers
aHR# = float(i * 30) - 90.0
set colori 0
Pnext = quad(Pstart, 1.0, aHR#, HL1# - 10.0, 1.0)
'use Pnext to locate hour marker starts
set colori 0xffffff
Pnext = quad(Pnext, HR#, aHR#, HL2#, HR#)
next

'draw the clock hands
'account for partial hour and minute passed with fractions
minFrac# = float(GetMinute() % 60) / 60.0
secFrac# = float(GetSecond() % 60) / 60.0

'arm angles 0 degrees is due east, so minus 90 is north = 0 for our clock
aHour# = (float(GetHour() % 12) + minFrac#)  / 12.0  * 360.0 - 90.0
aMin# =  (minFrac# + secFrac# / 60.0) * 360.0 - 90.0
aSec# =  secFrac# * 360.0 - 90.0

'draw arms with slightly different shades of gray
set colori 0xf0f0f0
Pnext = quad(Pstart, HhandR#, aHour#, HhandL#, HhandR# - 6.0)
set colori 0xa0a0a0
Pnext = quad(Pstart, MhandR#, aMin#, MhandL#, MhandR# - 3.5)
set colori 0x707070
Pnext = quad(Pstart, ShandR#, aSec#, ShandL#, ShandR# - 3.0)

'draw a center pin
set colori 0
_fcirc XC, YC, 2

redraw
wait 1
until keydown(27, true)


function quad(pStart, r1#, ang#, lng#, r2#)
'solid fill circles at both ends, use polygon 4 points to fill middle area
'draws from pStart at radius r1 down angle ang for length of leg
'with r2 being the radius at end point
'returns the x, y end point in P form for further pendage drawing

'constants XMAX, YMAX
'needs fcirc(x, y, r)
'needs xy2P(x, y)

'extract x, y start line of circles
  fx# = float(pStart % (XMAX + 1))
fy# = float(pStart) / float(XMAX)
x1# = fx# + r1# * cos(ang# + 90.0)
y1# = fy# + r1# * sin(ang# + 90.0)
x2# = fx# + r1# * cos(ang# - 90.0)
y2# = fy# + r1# * sin(ang# - 90.0)

xe# = fx# + lng# * cos(ang#)
ye# = fy# + lng# * sin(ang#)
x3# = xe# + r2# * cos(ang# + 90.0)
y3# = ye# + r2# * sin(ang# + 90.0)
x4# = xe# + r2# * cos(ang# - 90.0)
y4# = ye# + r2# * sin(ang# - 90.0)

_fcirc int(fx#), int(fy#), int(r1#)
_fcirc int(xe#), int(ye#), int(r2#)
'draw quad fill
draw poly[int(x1#), int(y1#), int(x2#), int(y2#), int(x4#), int(y4#), int(x3#), int(y3#)], true
return xy2P(int(xe#), int(ye#))
endfunc

procedure fcirc(x, y, r)
rsq = r * r
for a = 0 to r
b = int(sqr(float(rsq - a * a)))
x1 = x + a; x2 = x - a; y1 = y - b; y2 = y + b
draw line x1, y1, x1, y2
draw line x2, y1, x2, y2
next
endproc

function xy2P(x, y)
'note uses constants XMAX screen width
return y * (XMAX + 1) + x
endfunc



5
Code snippets / Quad test
« on: September 06, 2016 »
Code: [Select]
'quad test.txt for Naalaa [B+=MGA] 2016-09-05

' try appendage with polygon fill method

constant:
XMAX = 800
YMAX = 600
hidden:

set window 100, 40, 800, 600
set redraw off
for a = 0 to 360
set colori 0
cls
set color 255, 0, 0
cp = xy2P(400, 300)
nextP = quad(cp, 1.0, float(a), 150.0, 50.0)
set color 0, 128, 0
nextP = quad(nextP, 1.0, float(a) * 4.0, 75.0, 25.0)
set color 0, 0, 255
nextP = quad(nextP, 1.0, float(a) * 16.0, 50.0, 13.0)
set color 255, 255, 0
nextP = quad(nextP, 1.0, float(a) * 64.0, 25.0, 7.0)
redraw
wait 100
next
wait keydown

function quad(pStart, r1#, ang#, lng#, r2#)
'solid fill circles at both ends, use polygon 4 points to fill middle area
'draws from pStart at radius r1 down angle ang for length of lng
'with r2 being the radius at end point
'returns the x, y end point in P form for further pendage drawing

'constants XMAX, YMAX
'needs fcirc(x, y, r)
'needs xy2P(x, y)

'extract x, y start line of circles
  fx# = float(pStart % (XMAX + 1))
fy# = float(pStart) / float(XMAX)
x1# = fx# + r1# * cos(ang# + 90.0)
y1# = fy# + r1# * sin(ang# + 90.0)
x2# = fx# + r1# * cos(ang# - 90.0)
y2# = fy# + r1# * sin(ang# - 90.0)

  xe# = fx# + lng# * cos(ang#)
  ye# = fy# + lng# * sin(ang#)
x3# = xe# + r2# * cos(ang# + 90.0)
y3# = ye# + r2# * sin(ang# + 90.0)
x4# = xe# + r2# * cos(ang# - 90.0)
y4# = ye# + r2# * sin(ang# - 90.0)

_fcirc int(fx#), int(fy#), int(r1#)
  _fcirc int(xe#), int(ye#), int(r2#)
'draw quad fill
draw poly[int(x1#), int(y1#), int(x2#), int(y2#), int(x4#), int(y4#), int(x3#), int(y3#)], true
return xy2P(int(xe#), int(ye#))
endfunc

procedure fcirc(x, y, r)
rsq = r * r
for a = 0 to r
b = int(sqr(float(rsq - a * a)))
x1 = x + a; x2 = x - a; y1 = y - b; y2 = y + b
draw line x1, y1, x1, y2
draw line x2, y1, x2, y2
next
endproc

function xy2P(x, y)
'note uses constants XMAX screen width
return y * (XMAX + 1) + x
endfunc

6
General discussion / Convert 3 r,g,b to one?
« on: September 02, 2016 »
There must be a way to convert 3 RGB integers to one for set colori to use instead of set color?

I am looking for RGB2I(r, g, b) function.

7
Code snippets / Illustrated Human Sort
« on: August 31, 2016 »
Code: [Select]
' Illustrated Human Sort.txt for Naalaa 2016-08-30 translated from
' Illustrated Human Sort.txt for JB v1.01 2016-08-30 translated from
' Illustrated Human Sort.bas SmallBASIC 0.12.6 [B+=MGA] 2016-08-29
' well this is a disaster (a quick translation is not possible) !!!
' #1 < <= > >= operators do not work on strings
' #2 printing over text on screen eg spaces does not erase
' need rebuild screen at each update

' Using Binary Search Algorithm to sort some alpha numeric strings

set window 200, 40, 400, 440
set redraw false
randomize time()
constant:
SP8$ = "        "
N = 15
visible:
fi$ = ""
high = 0
low = 0
check = 0
filed$[N + 1]
fileThis$[N + 1]
hidden:

'set up work pile
for y = 1 to N
  c$ = mid$("ABCDEFGHIJKLMNOPQRSTUVWXYZ", rnd(26), 1)
  r = rnd(8)
  for i = 0 to r
    c$ = c$ + mid$("abcdefghijklmnopqrstuvwxyz", rnd(26), 1)
  next
  if len(c$) < 5 then c$ = mid$("0123456789", rnd(10), 1) + mid$("0123456789", rnd(10), 1) + " " + c$
  fileThis$[y] = left$(c$ + SP8$, 8)
next
proc us 0

'do some filing
for i = 1 to N
'move file to working place and remove from work array
fi$ = fileThis$[i]
fileThis$[i] = ""
proc us i
  if i = 1 then
    filed$[1] = fi$
fi$ = ""
proc us i
  else
'this is main event
    iPoint = findIndex(fi$, i - 1 )
    for j = i downto iPoint + 1
        filed$[j] = filed$[j - 1]
    next
filed$[iPoint] = ""
proc us i
    filed$[iPoint] = fi$
fi$ = ""
proc us i
endif
next
set colori 0x00ffff
proc pa 0, N + 2, "  I am done sorting things out!"
redraw
wait keydown

function findIndex(find$, ub)
'proc pa 60, ub +1, find$ +", "+filed$[ub]
'OK so far

i = ub + 1
  lb = 1
check = ub
proc us i

  if GTE(find$, filed$[ub]) then
    check = 0
    return ub + 1
  else
    high = ub
check = 0
proc us i
  endif

check = lb
  proc us i
  if LTE(find$, filed$[lb]) then
high = 0
check = 0
proc us i
    return lb
  else
    low = lb
check = 0
    proc us i
  endif

  midi = int(float(high - low) / 2.0) + low
  check = midi
  proc us i
  while midi <> low
    if find$ = filed$[midi] then
      low = 0
      high = 0
      check = 0
    proc us i
      return midi
    endif

    if LT(find$, filed$[midi]) then
high = midi
check = 0
      proc us i
    else
    low = midi
check = 0
      proc us i
  endif

  midi = int(float(high - low ) / 2.0) + low
check = midi
  proc us i
  wend

  check = 0
  high = 0
  sv = low
low = 0
  proc us i
  return sv + 1
endfunc

' redraw whole screen then pause
procedure us(i)
set colori 0x0
draw rect 0, 0, 800, 600, true
set colori 0x0000ff
proc pa 0, -1, "File These:"
proc pa 15, -1, "File:"
proc pa 30, -1, "Filed:"
set colori 0xff8800
for j = 1 to N
proc pa 0, j, fileThis$[j]
next
set colori 0x00b830
proc pa 15, i, fi$
set colori 0xffffff
if low and low = high then proc pa 28, low, "?"
if high and high <> low then proc pa 28, high, "<"
if low and low <> high then proc pa 28, low, ">"
if check then
if check <> low and check <> high then proc pa 28, check, "?"
endif
set colori 0xffff00
for j = 1 to N
proc pa 30 + 0, j + 0, filed$[j +0]
next
redraw
proc d1
endproc

procedure pa(xCol, yRow, text$)
  set caret (xCol + 2) * 8, (yRow + 2) * 20
wln text$
endproc

procedure d1()
    wait 1000
endproc

'note mid$ does not error if position is less than 0 or greater than len(string) -1
'compare s1$ <= s2$ return true if so else false unless one string = "" then error, return -1
function LTE(s1$, s2$)
if s1$ = "" or s2$ = "" then return -1
if s1$ = s2$ then
return true
elseif len(s1$) <= len(s2$) then
lm1 = len(s1$) - 1 ; shorter$ = s1$
else
lm1 = len(s2$) ; shorter$ = s2$
endif
for i = 0 to lm1
if asc(mid(s1$, i, 1)) < asc(mid(s2$, i, 1)) then
return true
elseif asc(mid(s1$, i, 1)) > asc(mid(s2$, i, 1)) then
return false
endif
next
'still here?
if shorter$ = s1$ then
return true
else
return false
endif
endfunc

'if s1$ or s2$ = "" return -1, error compare s1$ < s2$
function LT(s1$, s2$)
if s1$ = "" or s2$ = "" then return -1
if s1$ = s2$ then
return false
elseif len(s1$) <= len(s2$) then
lm1 = len(s1$) - 1 ; shorter$ = s1$
else
lm1 = len(s2$) ; shorter$ = s2$
endif
for i = 0 to lm1
if asc(mid(s1$, i, 1)) < asc(mid(s2$, i, 1)) then
return true
elseif asc(mid(s1$, i, 1)) > asc(mid(s2$, i, 1)) then
return false
endif
next
'still here?
if shorter$ = s1$ then
return true
else
return false
endif
endfunc

function GTE(s1$, s2$)
if s1$ = "" or s2$ = "" then return -1
if s1$ = s2$ then
return true
elseif len(s1$) <= len(s2$) then
lm1 = len(s1$) - 1 ; shorter$ = s1$
else
lm1 = len(s2$) ; shorter$ = s2$
endif
for i = 0 to lm1
if asc(mid(s1$, i, 1)) > asc(mid(s2$, i, 1)) then
return true
elseif asc(mid(s1$, i, 1)) < asc(mid(s2$, i, 1)) then
return false
endif
next
'still here?
if shorter$ = s1$ then
return false
else
return true
endif
endfunc

8
Code snippets / Henon translation
« on: August 29, 2016 »
Code: [Select]
'Henon translation [B+=MGA] 2016-08-28

xmax = 800
ymax = 600
set window 100, 40, xmax, ymax
radians
set redraw off

a# = -10.1 ; sc# = 175.0 ; ox# = 400.0 ; oy# = 300.0
while a# < 100.0
set colori 0
draw rect 0, 0, 800, 600, true
x# = -0.1
while x# < 0.8
x# = x# + 0.05
y# = -0.1
while y# < 0.8
y# = y# + 0.05
lx# = x# ; ly# = y#
for n =1 to 40
xx# = lx# * cos(a) - (ly# - lx# * lx#) * sin(a#)
ly# = lx# * sin(a) + (ly# - lx# * lx#) * cos(a#)
lx# = xx#
if abs(int(lx#) + int(ly#)) > 3000 then n = 41
set color n * 5, 255 - n * 5, 128 + n * 2
set pixel int(ly# * sc# + ox#), int(lx# * sc# + oy#)
next
wend
wend
redraw
  a# = a# + 0.001
sc# = sc# + 0.01
wend

9
Code snippets / Aquarium
« on: August 28, 2016 »
Code: [Select]
'aquarium.txt for NaaLaa 6 [B+=MGA] 2016-08-27
'tranlated from previous code

xmax = 1200
ymax = 700
set window 80, 40, xmax, ymax
set redraw false
radians
n = 30
r# = 0.0 ; g# = 0.0 ; b# = 0.0
x[n]; y[n]; l[n]; dx[n]; rr#[n]; gg#[n]; bb#[n]
for i = 0 to n-1
x[i] = rnd(xmax)
y[i] = rnd(ymax)
l[i] = int(float(rnd(xmax)) * 0.0625 + 18.0)
dx[i] = rnd(2) + 1
d = rnd(2)
if d <> 0 then dx[i] = dx[i] * -1
r# = r# + 0.2     ; if r# > 0.5 then r# = 0.02   ; rr#[i] = r#
g# = g# + 0.005   ; if g# > 0.5 then g# = 0.005  ; gg#[i] = g#
b# = b# + 0.01    ; if b# > 0.5 then b# = 0.01   ; bb#[i] = b#
next

while 1
for i = 0 to ymax-1
set color 0, 0, 255 - int( float#(i) / float#(ymax)  * 255.0 )
draw line 0, i, xmax, i
next
for i = 0 to n-1
x[i] = x[i] + dx[i]
if float#(x[i]) + 1.25 * float#(l[i]) < 0.0 then dx[i] = -1 * dx[i]
if float#(x[i]) - 1.25 * float#(l[i]) > float#(xmax) then dx[i] = -1 * dx[i]
y[i] = y[i] + rnd(3) - 1
for ra = 1 to l[i]
rd = int(127.0 + 127.0 * sin(rr#[i] * float#(ra)))
gn = int(127.0 + 127.0 * sin(gg#[i] * float#(ra)))
bl = int(127.0 + 127.0 * sin(bb#[i] * float#(ra)))
set color rd, gn, bl
if dx[i] < 0 then
draw line x[i] + ra, y[i] - ra, x[i] + ra, y[i] + ra
else
draw line x[i] - ra, y[i] - ra, x[i] - ra, y[i] + ra
endif
next
for ra = 5 to int(0.3 * float#(l[i]))
rd = int(127.0 + 127.0 * sin(rr#[i] * float#(ra)))
gn = int(127.0 + 127.0 * sin(gg#[i] * float#(ra)))
bl = int(127.0 + 127.0 * sin(bb#[i] * float#(ra)))
set color rd, gn, bl
if dx[i] < 0 then
draw line x[i] + l[i] + ra, y[i] - ra, x[i] + l[i] + ra, y[i] + ra
else
draw line x[i] - l[i] - ra, y[i] - ra, x[i] - l[i] - ra, y[i] + ra
endif
next
if dx[i] < 0 then
set colori 0
      _DrawFilledCircle x[i] + int( 0.25 * float#(l[i]) ), y[i], int( 0.1 * float#(l[i]) )
set colori 0xFFFF00
      _DrawCircle x[i] + int(0.25 * float#(l[i]) ), y[i], int( 0.06 * float#(l[i]) )
else
set colori 0x000000
      _DrawFilledCircle x[i] - int(0.25 * float#(l[i]) ), y[i], int( 0.1 * float#(l[i]) )
set colori 0xFFFF00
      _DrawCircle x[i] - int(0.25 * float#(l[i])), y[i], int( 0.06 * float#(l[i]) )
endif
next
redraw
wend

procedure DrawCircle(x0, y0, radius)
x = radius
y = 0
err = 0
while x >= y
draw pixel x0 + x, y0 + y
draw pixel x0 - x, y0 + y
draw pixel x0 + y, y0 + x
draw pixel x0 - y, y0 + x
draw pixel x0 - x, y0 - y
draw pixel x0 + x, y0 - y
draw pixel x0 - y, y0 - x
draw pixel x0 + y, y0 - x
y = y + 1
err = err + 1 + 2*y
if 2*(err - x) + 1 > 0
x = x - 1
err = err + 1 - 2*x
endif
wend
endproc

procedure DrawFilledCircle(x0, y0, radius)
x = radius
y = 0
err = 0
while x >= y
x2 = x*2; y2 = y*2
draw rect x0 - x, y0 + y, x2, 1, true
draw rect x0 - y, y0 + x, y2, 1, true
draw rect x0 - x, y0 - y, x2, 1, true
draw rect x0 - y, y0 - x, y2, 1, true
y = y + 1
err = err + 1 + 2*y
if 2*(err - x) + 1 > 0
x = x - 1
err = err + 1 - 2*x
endif
wend
endproc

10
Suggestions, requests and demands / Cut, copy, paste
« on: August 27, 2016 »
Request cut, copy and paste from right mouse click in editor.

I noticed as soon as I started up again with Naalaa.

I also miss running from a right click but, well, that might be asking too much...

11
Code snippets / Voronoi Spiral Gem
« on: August 27, 2016 »
Code: [Select]
rem http://retrogamecoding.org/board/index.php?topic=486.0
rem Re: Voronoi Spiral gem
rem « Reply #9 on: 25. August 2016, 13:11:47 » Mopz
rem 2016-08-27 mod B+=MGA,
rem I'd rather see screen update and loose a second or 2
rem than stare at black black screen and wonder if
rem new version download was working ;))
rem I get 163 - 167 secs on 1.3GHz

gem = 700
gems = gem - 1

set window 16, 16, gem, gem
set redraw off

points = 36*13
cy = gem/2
ga# = 10.0

x[points]
y[points]
kl[points]
s# = 0.7
wln "Working, please wait ..."
redraw
t = time()
ps = points - 1
for n = 0 to ps
   x[n] = cy + int(s*float(n)*cos(float(n)*ga))
   y[n] = cy + int(s*float(n)*sin(float(n)*ga))
   if x[n] < gem and x[n] > 0 and y[n] < gem and y[n] > 0
     g = 127 - abs(cy - x[n])*127 / cy + 127 - abs(cy - y[n]) * 127 / cy
   else
     g = 0
   endif
   if x[n] < gem and x[n] > 0; r = 255 - x[n]*255/gem; else; r = 0; endif
   if y[n] < gem and y[n] > 0; b = y[n]*255 / gem; else; b = 0; endif
   kl[n] = (r SHL 16) + (g SHL 8) + b
   set colori kl[n]
   _DrawFilledCircle int(x[n]), int(y[n]), 2
next

for xx = 0 to gem
for yy = 0 to gem
d = gem*gem + 1
for i = 0 to points - 1
a = x[i] - xx; b = y[i] - yy
q = a*a + b*b
if q < d; d = q; kkl = i; endif
next
set colori kl[kkl]
set pixel xx, yy
next
redraw
next

set color 255, 255, 255
set caret 0, 0
wln "Time: ", (time() - t)/1000
redraw
wait keydown

procedure DrawCircle(x0, y0, radius)
x = radius
y = 0
err = 0
while x >= y
draw pixel x0 + x, y0 + y
draw pixel x0 - x, y0 + y
draw pixel x0 + y, y0 + x
draw pixel x0 - y, y0 + x
draw pixel x0 - x, y0 - y
draw pixel x0 + x, y0 - y
draw pixel x0 - y, y0 - x
draw pixel x0 + y, y0 - x
y = y + 1
err = err + 1 + 2*y
if 2*(err - x) + 1 > 0
x = x - 1
err = err + 1 - 2*x
endif
wend
endproc

procedure DrawFilledCircle(x0, y0, radius)
x = radius
y = 0
err = 0
while x >= y
x2 = x*2; y2 = y*2
draw rect x0 - x, y0 + y, x2, 1, true
draw rect x0 - y, y0 + x, y2, 1, true
draw rect x0 - x, y0 - y, x2, 1, true
draw rect x0 - y, y0 - x, y2, 1, true
y = y + 1
err = err + 1 + 2*y
if 2*(err - x) + 1 > 0
x = x - 1
err = err + 1 - 2*x
endif
wend
endproc

PS I think this circle fill might be better than what Rick and I came up with!

12
Code snippets / Rainbow beat
« on: October 11, 2015 »
Here is something I could not figure out in another BASIC:

Code: [Select]
rem rainbow beat.txt in NaaLaa 2015-10-10 MGA/B+
rem modified from PeterMaria BP.org 2015-10-05 "Heartbeat"
xmax=760
ymax=760
set window 400,1,xmax,ymax
set redraw off
radians
w = xmax/2
h = ymax/2
a#=0.0
while keydown(27)=0
set color 0,0,0
  cls
  for i=165 to 315
      set color 255-i%165, 255-i%200, 255-i%255, 255
      for j=1 to 10
         _circ w+int(sin(float(i))*a#),h+int(cos(float(i))*a#),388-i+j
      next
      a#=a#+0.01
      if a#>=180.0 then break
  next
if a#>=180.0 then break
redraw
wait 10
wend
rem for snapshot
wait 15000

procedure circ(x,y,r)
rsq=r*r;ly=0
for cx=r downto 0
cy=int(sqr#(float(rsq-cx*cx)))
x1=x+cx;x2=x-cx;y1=y+ly;y2=y+cy;y3=y-ly;y4=y-cy
draw line x1,y1,x1,y2
draw line x1,y3,x1,y4
    draw line x2,y1,x2,y2
    draw line x2,y3,x2,y4
ly=cy
next
endproc

How interesting that the colors are in correct order for rainbow!

13
Code snippets / Boing!
« on: July 26, 2015 »
Another fun mouse effect:
Code: [Select]
rem boing.txt for Naalaa 2015-07-25 MGA/B+ left mouse down, optional drag mouse, release, see spring action say, "boing"
xmax=1200 ; ymax=700
set window 0,0,xmax,ymax
set redraw off
radians
cx[]=[0,0,xmax+30,xmax+30]
cy[]=[50,ymax-50,50,ymax-50]
da#=0.03;a#=0.0
boingx#=0.0;boingy#=0.0
oldtx=0;oldty=0
while keydown(27)=0
if mousebutton(0) then
tx=mousex()+20
ty=mousey()
else
tx=xmax/2
ty=ymax/2
if tx<>oldtx or ty<>oldty then
boingx#=3.0*float(tx-oldtx)/4.0
boingy#=3.0*float(ty-oldty)/4.0
else
boingx#=-3.0*boingx#/4.0
boingy#=-3.0*boingy#/4.0
endif
tx=tx+int(boingx#)
ty=ty+int(boingy#)
endif
a#=0.01
oldtx=tx ; oldty=ty
set color 0,255,255
draw rect 0,0,xmax,ymax,1
for corner = 0 to 3
s1x=cx[corner] ; s1y=cy[corner]
dx#=float(tx-s1x)/2000.0 ; dy#=float(ty-s1y)/2000.0
x#=float(tx-20) ;  y#=float(ty)
for i=1 to 2000
sx#=20.0*cos(a#)+x#
sy#=20.0*sin(a#)+y#
set color 0,0,255
draw rect int(sx#),int(sy#),2,2,1
set color 0,0,0
draw pixel int(sx#),int(sy#)
set color 255,255,255
draw pixel int(sx#),int(sy#)+2
x#=x#-dx#;y#=y#-dy#
a#=a#+da#
next
next
for j=23 downto 1
set color 0,0,255-8*j
proc disk tx-20,ty,j
next
redraw
wait 10
wend
end
procedure disk(x,y,r)
rsq=r*r
for a = r downto 0
b = int(sqr(float(rsq-a*a)))
x1=x+a;x2=x-a;y1=y-b;y2=y+b
draw line x1,y1,x1,y2
draw line x2,y1,x2,y2
next
endproc

14
Code snippets / Poly and poly again...
« on: July 10, 2015 »
Some polygon recursion:
Code: [Select]
rem Poly and poly again.txt for naalaa 2015-07-09
rem translated from SmallBASIC 2015-06-28 MGA/B+
ws=760
set window 0,0,ws,ws
set redraw off
radians
visible:
d=2
pi#=3.1415
hidden:
set color 0,0,0
cls
cx=ws/2;cy=ws/2
while keydown(27)=0
do
set color 0,0,0
cls
d=d+1
side=cy-10
proc dopoly cx,cy,side,1
set color 255,128,0
set caret 0,0
wln str$(d)," poly and poly again..."
redraw
wait 2000
until d=15
d=2
wend

procedure dopoly(&xc,&yc,&level,call)
sq=level/2
if sq<1+d
  return
elseif call>4 and d>6
return
elseif call>3 and d>10
return
else
x[d]
        y[d]
        dm=d-1
        for i=0 to dm
      t#=cos(float(i)*2.0*pi#/float(d))
          x[i]=int(float(xc)+t#*float(sq))
          t#=sin(float(i)*2.0*pi#/float(d))
          y[i]=int(float(yc)+t#*float(sq))
        next
        for a=0 to dm
      b=a+1
          if b>dm then b=0
          if sq>100
            set color 255,255,255
          elseif sq>60
            set color 220,220,0
      elseif sq>30
            set color 0,128,128
          elseif sq>20
            set color 255,0,0
          elseif sq>10
            set color 0,0,200
  else
    set color 0,10*sq,10*sq
          endif

          draw line x[a],y[a],x[b],y[b]
          proc dopoly x[a],y[a],sq,call+1
next
endif
endproc

15
Showcase / Flappy 3
« on: July 06, 2015 »
Finally collision detection is by location not color:
(see Parallax thread for latest assets download)
Code: [Select]
rem
rem Flappy 3  2015-07-06 More code overhaul
rem          collision detection by pipe(x,y) and flappy(x,y) LOCATION!!!!   
rem          faster goundspeeds + more variance to pipe heights
rem          = more challenging

import "Speed.lib"

set window 200,0,432,768
set color 188, 255, 251
set redraw off

load image 1, "assets\clouds.png"
load image 2, "assets\city.png"
load image 3, "assets\trees.png"
load image 5, "assets\ground.png"
load image 7, "assets\intro.png"
load image 16, "assets\bird1.png"
load image 17, "assets\bird2.png"
load image 18, "assets\bird3.png"
load image 19, "assets\pipe200.png"
load image 20, "assets\pipe180.png"
load image 21, "assets\pipe150.png"

load sound 1, "assets\pop.wav"
load sound 2, "assets\bling.wav"
load sound 3, "assets\dead.wav"
load sound 4, "assets\flap.wav"

create font 0, "arial" , 42
set font 0

visible:
groundspeed# = 1.0
highscore=0

score = 0
scored = 0

bling = 2
dead = 3
flap = 4

flappyx = 75
flappyy = 300
pipey = -478

pipex# = 432.0
groundx# = 0.0
treesx# = 0.0
cityx# = 0.0
cloudsx# = 0.0
rem ======================== Main
proc intro
while keydown(27)=0
cls
proc movestuff
proc moveflappy
proc collision
proc updatescore
redraw
proc SPD_HoldFrame(140)
wend
end

rem
rem PROCEDURES
rem

procedure intro()
do
draw image 7, 0, 0
set color 0,0,0
set caret 217,650
center "High score today is "+str(highscore)
redraw
set color 188,255,251

if mousebutton(0) then
if mousex() > 166 and mousex() < 264 and mousey() > 366 and mousey() < 401 then
wait 1500
cls
break
elseif mousex() > 166 and mousex() < 264 and mousey() > 412 and mousey() < 446 then
cls
wait 500
end
endif
endif
if keydown(27) then end
loop
cls
endproc

procedure movestuff()
draw image 1, int(cloudsx#), 462
cloudsx#=cloudsx# -0.125*groundspeed#
if cloudsx# <= -432.0 then cloudsx# = 0.0

draw image 2, int(cityx#), 507
cityx# = cityx# -0.25*groundspeed
if cityx# <= -432.0 then cityx# = 0.0

draw image 3, int(treesx#), 552
treesx# = treesx# - 0.5*groundspeed#
if treesx# <= -432.0 then treesx# = 0.0

if groundspeed# <1.5 then
draw image 19, int(pipex#), pipey
elseif groundspeed# <2.0
draw image 20, int(pipex#), pipey
else
draw image 21, int(pipex#), pipey
endif
pipex# = pipex# - groundspeed#
if pipex# < -52.0 then
pipex# = 432.0
pipey=-600+rnd(250)
scored=0
endif

draw image 16, flappyx, flappyy

draw image 5, int(groundx#), 600
set color 0,0,0
set caret 217,650
center score
set color 188,255,251
groundx# = groundx# - groundspeed#
if groundx# <= -432.0 then groundx# = 0.0
endproc

procedure moveflappy()
if keydown(32) or mousebutton(0) then
flappyy = int(float(flappyy) -1.5)
play sound flap
else
flappyy = int(float(flappyy) +1.5)
endif
endproc

procedure collision()
rem hit top or ground?
if flappyy <-1 or flappyy >570 then
play sound(dead)
wait 1500
proc settlescore
endif

if flappyx-49<=int(pipex#) and flappyx+39>=int(pipex#) then
if groundspeed#<1.5 then
if flappyy <627 + pipey or flappyy > 630+pipey+170 then
play sound(dead)
wait 1500
proc settlescore
endif
elseif groundspeed# <2.0
if flappyy <637 + pipey or flappyy > 640+pipey+150 then
play sound(dead)
wait 1500
proc settlescore
endif
else
if flappyy <652 + pipey or flappyy > 655+pipey+120 then
play sound(dead)
wait 1500
proc settlescore
endif
endif
endif
endproc

procedure updatescore()
if flappyx >= int(pipex#)+52 and scored = 0 then
scored = 1
play sound(bling)
score = score + 1
if score <5 then
groundspeed# =1.4
elseif score <11
groundspeed#=1.9
else
groundspeed#=2.2
endif
endif
endproc

procedure settlescore()
if score>highscore then highscore=score
score = 0
scored = 0
flappyx = 75
flappyy = 300
pipey = -478
pipex# = 432.0
groundx# = 0.0
treesx# = 0.0
cityx# = 0.0
cloudsx# = 0.0
groundspeed#=1.0
proc intro
endproc

With current collision settings you will find Flappy crashed darn near if not on the pipes.

Pages: [1] 2