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 3 ... 5
1
Code and examples / It's the 4th, have a blast!
« on: 04. July 2017, 06:33:15 »
Code: [Select]
' more particles.bas  SmallBASIC 0.12.8 [B+=MGA] 2016-11-18
' from: more particles.sdlbas [B+=MGA] 2016-11-18
' attempt to simulate alpha effect

func rand(n1, n2)
  if n1 > n2 then hi = n1 : lo = n2 else hi = n2 : lo = n1
  rand = (rnd * (hi - lo + 1)) \ 1 + lo
end

def rdir = iff(rnd < .5, -1, 1)

numPoints = 100

dim  vx(numPoints), vy(numPoints), clr(numPoints), life(numPoints), lifeTime(numPoints)

wantColor = 1  'colorize on/off, 1 or 0

for i = 0 to numPoints
  initPoint(i)
next
while 1
  cls
  for p = 0 to numPoints
    life(p) += 1
    if life(p) = lifeTime(p) then
      initPoint(p)
    else
      'redraw the whole arc of particle path
      x0 = xmax/2 : y0 = .35 *  ymax : drop = vy(p)
      for i = 0 to life(p)
        if wantColor then
          select case clr(p)
          case 0
            r = 1: g = 0 : b = 0
          case 1
            r =1 : g = 1 : b = 1
          case 2
            r =0 : g = 0 : b = 1
          case 3
            r = 0 : g = .7 : b = 0
          case 4
            r= 1: g = 1 : b = 0
          case 5
            r = 1 : g = 0 : b = 1
          case 6
            r = 1 : g = .6 : b = 0
          end select
          if r = 0 then
            r = 3 * (life(p) - i)
          else
            r = i/life(p) * 255 * r
          end if
          if g = 0 then
            g = 3 * (life(p) - i)
          else
            g = i/life(p) * 255 * g
          end if
          if b = 0 then
            b = 3 * (life(p) -1)
          else
            b = i/life(p) * 255 * b
          end if
          color rgb(r, g, b)
        else
          m = i/life(p) * 255
          color rgb(m, m, m)
        end if
        xnext = x0 + vx(p)
        drop += .1
        ynext = y0 + drop
        radius = i/life(p) * 8
        circle xnext, ynext, radius filled
        x0 = xnext
        y0 = ynext
      next
    end if
  next
  showpage
wend

sub initPoint(p)
  vx(p) = rnd * 7  * rdir
  vy(p) = rnd * 7  * rdir
  clr(p) = rand(0, 6)
  life(p) = 0
  lifeTime(p) = rand(30, 70)
end

2
Code and examples / Spirograph
« on: 01. July 2017, 19:39:45 »
Just got the mechanism worked out, here is first fancy up:
Code: [Select]
'Spirograph RO divided by 2 - 10 = RI.bas SmallBASIC 0.12.9 (B+=MGA) 2017-07-01

rO = ymax/2 - 10 ' fit screen radius of big circle
Ox = xmax/2
Oy = ymax/2
pIndex = 0
dim px(), py()
for ir = 2 to 10
  rI = rO/ir       ' smaller circle that travels inside edge of larger
  OI = rO /rI      ' rate inner circle spins compared to angle on outer circle
  for a = 0 to 2 * pi step pi/360  'while the inner circle contacts outer at angle a
    cls
    circle Ox, Oy, rO, 1, 9
    'the origin of inner circle at same angle
    Ix = Ox + (rO - rI) * cos(a)
    Iy = Oy + (rO - rI) * sin(a)
    Ia = OI * a   'the angle of the inner points are OI * a on outer circle
    'draw line from origin of inner circle to outer edge
    color 12
    wheel(Ix, Iy, rI, -Ia)
    for i = 0 to pIndex-1
      pset px(i), py(i), 15
    next
    showpage
    delay 10
  next
next
pause
sub wheel(x,y,r,a)
  local i, x1, y1, x2, y2
  circle x, y, r
  for i = 1 to 12
    x1 = x + r*cos(i*2*pi/12 + a)
    y1 = y + r*sin(i*2*pi/12 + a)
    line x, y, x1, y1
    if i = 12 then
      x2 = x + r/2*cos(i*2*pi/12 + a)
      y2 = y + r/2*sin(i*2*pi/12 + a)
      px << x2
      py << y2
      pIndex = pIndex + 1
    fi
  next
end

3
Code and examples / < 100 loc Interpreter and IDE
« on: 19. June 2017, 16:04:57 »
Smaller than Tinybasic.bas (450 lines), this SmallBASIC interpreter offers an in folder IDE in less than 100 lines of code! No punctuation is used for syntax (though . is command for print line ; is command print no CR + LF and ? is command for input). Variables are limited to lower case letters a-z. Notepad is used for editor in IDE but Linux users could change line to equivalent editor. Like Tinybasic, GOSUB is available. Unlike Tinybasic, no line numbers are needed but line labels are available for GO option. Also unlike Tinybasic, modern DO... LOOP and IF... ELSE... FI code blocks are available.
 
Code: [Select]
t="Nano3":color 11,1:for s=160 to 4 step -4:cls:w=window():w.setfont(s,"pt",0,0)
at(xmax-txtw(t))/2,(ymax-txth(t))/2:? t:delay 1:next:w.setfont(16,"pt",0,0)
label restart
color 0, 11:cls:anyfile=files("*nano3.txt"):sort anyfile:? "nano3 Files:":?
for i = 0 to ubound(anyfile):? i,anyfile(i):next
? : input "Enter file NUMBER (any else quits) >  ",flnm
if isnumber(flnm) then
if flnm >= 0 and flmn <=ubound(anyfile) then : getfile = anyfile(flnm) : tload getfile, p : else : end : fi
else : end : fi
color 7, 1 : cls: for i = 0 to ubound(p):? i, p(i) : next
?:? "n(New) e(Edit) r(Run) k(Kill) f(Files) q(Quits)":input cmd
select case left(cmd,1)
  case "n" : open "untitled nano3.txt" for output as #1
    print #1, "nano3.txt for Nano3.bas (B+=MGA) "+right(date,4)+"-"+mid(date,4,2)+"-"+left(date,2): close #1
    run "notepad untitled nano3.txt": goto restart 
  case "e" : run "notepad "+ getfile : goto restart
  case "f" : goto restart
  case "k" : kill getfile : goto restart
  case "q" : end
  case "r" : color 7, 0 : cls : dim v(25), w(250), stk() : cl = 0 : si = 0
label readline
w1 = word(p(cl), 1) : w2 = word(p(cl), 2)
for i = 2 to 250 : ws = word(p(cl), i) : cvtValue ws : w(i) = ws : next
if w1 = "go" then
  f = 0 : for i = 0 to ubound(p)
    if word(p(i), 1) = "mark"  and word(p(i), 2) = word(p(cl), 2) then cl = i : f = 1: exit for
  next
  if f = 0 then ? "Error: could not find go mark ";word(p(cl), 2) : goto fini
elif w1 = "cls":cls
elif w1 = "at":at val(w(2)), val(w(3))
elif w1 = "wait":delay val(w(2))
elif w1 = "solve":v(6)=v(0)*v(4)-v(1)*v(3):if v(6)<>0 then v(23)=(v(2)*v(4)-v(1)*v(5))/v(6):v(24)=(v(0)*v(5)-v(2)*v(3))/v(6)
elif w1 = "?":vn=asc(w2)-97:wn=3:while w(wn) <> "":? w(wn);" ";:wn++:wend:input "";temp:v(vn)=temp
elif w1 = "." or w1 = ";":wn=2:while w(wn)<>"":? w(wn);" ";:wn++:wend:if w1 = "." then ?
elif w1 = "loop" : c = 1 : f = 0
  for i = cl - 1 to 0 step -1 : fw = word(p(i), 1)
    if fw = "do" then
      c -- : if c = 0 then cl = i : f = 1 : exit for
    elif fw = "loop" : c ++ : fi
  next
  if f = 0 then ? "Error: could not find do to match loop on line ";cl : goto fini
elif w1 = "exit" : c = 1 : f = 0
  for i = cl + 1 to ubound(p)
    fw = word(p(i), 1)
    if fw = "loop" then
      c -- : if c = 0 then cl = i : f = 1 : exit for
    elif fw = "do" : c ++ : fi
  next
  if f = 0 then ? "Error: could not find loop to match exit on line ";cl : goto fini
elif w1 = "if" : es = "" : for i = 2 to 250 : es = es + w(i) : next : if eval(es) = 0 then cl = find(cl)
elif w1 = "else" : cl = find(cl)
elif len(w1) = 1 and asc(w1) > 96 and asc(w1) < 123 and w2 = "="
  es = "" : for i = 3 to 250 : es = es + w(i) : next : v(asc(w1) - 97) = eval(es)
elif w1 = "end" : goto fini
elif w1 = "sub" : f = 0 : for i = cl + 1 to ubound(p) : if word(p(i), 1) = "return" then cl = i : : f = 1 : exit for
  next : if f = 0 then goto fini
elif w1 = "gosub" : f = 0
  for i = 0 to ubound(p) : if word(p(i), 1) = "sub"  and word(p(i), 2) = word(p(cl), 2) then f = 1: exit for
  next : if f = 0 then ? "Error: could not find sub ";word(p(cl), 2) : goto fini else insert stk, si, cl : cl = i : si++
elif w1 = "return"
  si-- : cl = stk(si) : delete stk, si
elif w1 = "ra" : ra
fi : cl += 1 : if cl > ubound(p) then goto fini
goto readline
label fini
?:? getFile;" run is done." :?:input " Press enter to continue...";again:goto restart
case else : goto restart
end select
sub cvtValue(byref wrd)
  if len(wrd) = 1 and asc(wrd) > 96 and asc(wrd) < 123 then wrd = v(asc(wrd)-97)
end
func find(ln)
  local i, fw, c
  c = 1
  for i = ln+1 to ubound(p) : fw = word(p(i), 1)
    if fw = "fi" then
      c --
      if c = 0 then find = i : exit func
    elif fw = "if"
      c ++
    elif fw = "else" and c = 1
      find = i : exit func
    fi
  next
  ? "Error: could not find fi to match line ";ln : goto fini
end
func word(byref source, wnumber) 'base 0, but word(s, 1) is first word if any
  local w, p : source = trim(source) : if len(source) = 0 then word = "" : exit func
  p = instr(source, "  ")
  while  p > 0 : source = mid(source, 1, p) + mid(source, p + 2, len(source) - p - 1) : p = instr(source, "  ") : wend
  split source, " ", w : if wnumber > 0 and ubound(w) + 1 >= wnumber then word = w(wnumber - 1) else word = ""
end
func eval(s) 'thanks shian!
  chain "env " + enclose("EVAL=") + " + str(" + s + ")" : eval = env("EVAL")
end
sub ra() 'set x, y to origin, set a to rad angle, set r to length if p QB color draw ray
  local x,y:x=v(23)+v(17)*cos(v(0)):y=v(24)+v(17)*sin(v(0))
  if 0<=v(15) and v(15)<16 then:line v(23),v(24),x,y,v(15):fi:v(23)=x:v(24)=y
end
##################################################################################
# The MIT License (MIT)
# Copyright (c) 2017 B+=MGA
#
# Permission is hereby granted, free of charge, to any person obtaining a copy
# of this software and associated documentation files (the "Software"), to deal
# in the Software without restriction, including without limitation the rights
# to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
# copies of the Software, and to permit persons to whom the Software is
# furnished to do so, subject to the following conditions:
#
# The above copyright notice and this permission notice shall be included in all
# copies or substantial portions of the Software.
#
# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
# AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
# OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
# SOFTWARE.
##################################################################################

BTW, ' or REM or # or whatever are not needed for comments. To make a comment in a Nano3 program, just don't start the line with a command.
If you make a comment on an IF line after the Boolean expression, it will likely be ignored unless mistaken as part of the expression.

Do not use the lower case a as a word in a print line or input prompt unless you intend the a to be replaced by it's value displayed on screen.

Below is pictured the entire manual for Nano3-2 that is accessible from IDE files listing.

4
General questions and discussions / Turtle Essence
« on: 13. June 2017, 19:35:39 »
Code: [Select]
' turtle essence.bas SmallBASIC 0.12.9 (B+=MGA) 2017-06-13

' From my experience with Draw Strings and Nano series,
' I think I have discovered the essence of Turtle Drawing
' I contend that all can be done with 5 global variables
' x, y the start position of ray = ra line
' a, r the radian angle of direction to go and r the distance
' p is pen color, draw if 0 <= p <= 15 (QB colors 0 - 15)
' and one graphics command ra (as sub or gosub)

sub ra
  local x1 = x + r * cos(a)
  local y1 = y + r * sin(a)
  ' if pen p has a color draw, else just update x, y position
  if 0 <= p and p <= 15 then line x, y, x1, y1, p
  x = x1 : y = y1 'update x, y with current turtle position
end
'===== that's all the setup you need to do turle drawing


'but let's setup a Home position in middle of screen
homeX = xmax/2 : homeY = ymax/2


' lines commented out are from Galileo's tree code found at
' http://retrogamecoding.org/board/index.php?topic=581.0

'this code modifies Galileo's allowing tree to grow and sway with beautiful background!

'import turtle3
'clear screen
'startTurtle()
'home() ' oh this sets start angle at 270 degrees or 3*pi/2
x = homex: y =homey
a = 3*pi/2

'goy(200)
y = y + 200

'pen(1)
'color 0, 255, 0
p = 6
horizon = ymax/2 + 100
for i = 1 to 300
  cls
  for h= 0 to horizon
    midInk 0,0,128, 40, 200, 255, h/horizon
    line 0, h, xmax, h
  next
  for h = horizon to ymax
    midInk 40,200,255, 50, 200, 50, (h-horizon)/(ymax-horizon)
    line 0, h, xmax, h
  next
  tree i
  showpage
next
while 1
  sway = sway + (rnd*2) -1
  if sway > 25 then sway = 25
  if sway < -25 then sway = -25
  cls
    for h= 0 to horizon
    midInk 0,0,128, 40, 200, 255, h/horizon
    line 0, h, xmax, h
  next
  for h = horizon to ymax
    midInk 40,200,255, 50, 200, 50, (h-horizon)/(ymax-horizon)
    line 0, h, xmax, h
  next
  a = a + rad(sway)
  tree i
  a = a - rad(sway)
  showpage
wend
pause

sub tree(size)
   if size < 5 then
     'move(size)
     r = size
     ra
     
     'move(-size)
     r = -size
     ra
     
     'return
     exit sub
   end if
   'move(size/3)
   r = size/3
   ra
   
   'turn(-30)
   a = a - rad(30 + sway)
   
   tree(size*2/3)
   
   'turn(30)
   a = a + rad(30 + sway)
   
   'move(size/6)
   r = size/6
   ra
   
   'turn(25)
   a = a + rad(25 + sway)
   
   tree(size/2)
   
   'turn(-25)
   a = a - rad(25 + sway)
   
   'move(size/3)
   r = size/3
   ra
   
   'turn(25)
   a = a + rad(25 + sway)
   
   tree(size/2)
   
   'turn(-25)
   a = a - rad(25 + sway)
   
   'move(size/6)
   r = size/6
   ra
   
   'move(-size)
   r = -size
   ra
end sub

sub midInk(r1, g1, b1, r2, g2, b2, fr)
  color rgb(r1+(r2-r1)*fr, g1+(g2-g1)*fr, b1+(b2-b1)*fr)
end


5
 
1st Annual 100 Line-of-Code Programming Language Competition Rules
http://thejoyfulprogrammer.com/qb64/forum/showthread.php?tid=805&rndtime=14970925651503921598

So far one submission to contest, here is a review:
Quote
Bplus -

This project kicks lots of CENSORED. Thanks for setting the bar so high so that I don't waste any time trying to out-compete you in less than 100 lines of QB45 code. Your implementation language was well chosen, too - it would take hundreds of lines to simply get to the same starting place as you. Makes me think that if I enter this contest, I would have to jump right to Python or C++ to save myself the overheard.

I have not forgone my own personal entry into this contest yet, but I predict you'll be the winner if our judges have any neurological activity whatsoever.... AND if I don't join in :-)

Ah... bplus knows there are better coders than he that should be informed of the competition so that they may dust off some old esoteric brain intercourse efil project, tweak it a bit and enter. ;) I mean, to some people 100 lines of code is equivalent to unlimited!

Open to any language or flavor but IMO the judge is partial to GNU/Linux.

You might also want to check out the rest of the forum, members are given their own language boards.


6
Code and examples / Curlie transformer
« on: 10. June 2017, 05:30:28 »
From Scarab to batman! in 100 pics

Code: [Select]
' transformer scarab to batman.bas SmallBASIC 0.12.9 (B+=MGA) 2017-06-09
' in 100 pics
color 15, 4
for j = 3.14 to 6.28 step .0314
  cls : c++ : print c, "press any...
  x = 650 : x1 = x : y = 500 : f = 0
  for z = 1 to 200000
    f = f + j   : g = f * f
    x = x + cos(g) : x1 = x1 - cos(g)
    y = y + sin(g) : p = z % 255
    pset x, y, rgb(p, p, p)
    pset x1, y, rgb(p, p,,p)
  next
  while len(inkey)= 0 : showpage : wend
next
pause

7
Code and examples / Pulsar Star Galaxy Rotation
« on: 29. May 2017, 23:36:18 »
Ready for a wicked headache?

Code: [Select]
' Pulsar star galaxy rotation.bas SmallBASIC 0.12.9 (B+=MGA) 2017-05-30

'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
'
'   CAUTION: DO NOT RUN THIS CODE IF YOU ARE SUSCEPTIBLE to SEIZURES
'
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

sr = 10 : cx = xmax/2 : cy = ymax/2 : b = 1 : bdir = 1
rr = rnd : gg = rnd : bb = rnd
while 1
  cls
  nstars = 1 : starN = 1
  for s = 1 to sr step 3
    color rgb(rnd*255, rnd*255, rnd *255)
    star cx, cy, .1*s, s, 5, deg(a)*20
  next
  rr = 2 * sr
  while nstars < 1000
    circ = 2 * pi * rr
    n = int(circ / (2*sr))
    clr++
    color rgb(127+127*sin(clr*rr), 127+127*sin(clr*gg), 127+127*sin(clr*bb))
    for i = 1 to n
      x = cx + b*rr*cos(i * 2*pi/n + a)
      y = cy + 1/b*rr*sin(i * 2*pi/n + a)
      star x, y, .1*sr, .8*sr, 5, deg(a)*20
    next
    nstars = nstars + n
    rr = rr + 2 * sr
  wend
  showpage
  a = a + pi/90
  b = b + .01 * bdir
  if b > 2.5  then bdir = bdir * -1 : b = 2.5
  if b < .2 then bdir = bdir * -1 : rr = rnd : gg = rnd : bb = rnd : b = .2
wend

sub star( x, y, rInner, rOuter, nPoints, angleOffset)
  local pAngle, radAngleOffset, i, x1, y1, x2, y2, x3, y3
  ' x, y are same as for circle,
  ' rInner is center circle radius
  ' rOuter is the outer most point of star
  ' nPoints is the number of points,
  ' angleOffset = angle offset IN DEGREES, it will be converted to radians in sub
  ' this is to allow us to spin the polygon of n sides
  pAngle = RAD(360 / nPoints)  :  radAngleOffset = RAD(angleOffset)
  x1 = x + rInner * cos(radAngleOffset)
  y1 = y + rInner * sin(radAngleOffset)
  for i = 0 to nPoints - 1
    x2 = x + rOuter * cos(i * pAngle + radAngleOffset + .5 * pAngle)
    y2 = y + rOuter * sin(i * pAngle + radAngleOffset + .5 * pAngle)
    x3 = x + rInner * cos((i + 1) * pAngle + radAngleOffset)
    y3 = y + rInner * sin((i + 1) * pAngle + radAngleOffset)
    line x1, y1, x2, y2
    line x2, y2, x3, y3
    x1 = x3 : y1 = y3
  next
end sub

Screenshots look harmless enough... hee, hee...

8
Code and examples / Tree Swirl
« on: 28. May 2017, 05:26:11 »
hmm... trees instead of stars?

Code: [Select]
' tree swirl.bas SmallBASIC 0.12.9 (B+=MGA) 2017-05-27
' mod with trees
' Psychedelic Star Swirl.bas  SmallBASIC 0.12.8 [B+=MGA] 2017-03-03

cx = xmax / 2 : cy = ymax / 2 : StartAngle = 0
clr = 1 : r = rnd : g = rnd : b = rnd

while 1
  cls
  Bang
  showpage
  delay 1
  StartAngle = StartAngle - pi/72
wend
 
sub Bang()
  angle = StartAngle
  size = 3 : radius = .1 : ds = .1
  while radius < 400
    x = cos(angle) * radius
    y = sin(angle) * radius
    chColor
    branch cx + x, cy + y, deg(atan2((y-cy),(x-cx))-90), size, 1
    angle = angle + 41.0
    radius = radius + 2.0
    size = size + ds
    ds = ds + 0.0001
  wend
end

sub chColor()
  clr = clr + 1
  color rgb(30+20*sin(r*clr), 167+80*sin(g*clr), 30+20*sin(r*clr))
  if clr > 10000 then r = rnd : g = rnd : b = rnd : clr = 0
end

sub branch(x, y, angD, length, lev)
  local x2, y2, dx, dy, bc, i
  x2 = x + cos(rad(angD)) * length
  y2 = y - sin(rad(angD)) * length
  line x, y, x2, y2
  if lev>6 or length<1 then exit sub
  lev+=1
  branch x2,y2,angD+10+30*rnd,.8*length+.2*rnd*length,lev
  branch x2,y2,angD-10-30*rnd,.8*length+.2*rnd*length,lev
end

:)


9
General questions and discussions / Method or Madness ;-))
« on: 25. May 2017, 19:28:46 »
Method or Madness, method to madness?  ;D

I say it is crazy addictive ear worm started at Naalaa because no built-in circle drawing at all, which is maddening for graphics crazed hobby programmers.

Here is my latest filled circle algo in SmallBASIC time is 40% of my last best filled circle algo. Results are more dramatic for larger radii.
Code: [Select]
'new circle algo test.bas for SmallBASIC 0.12.9 (B+=MGA) 2017-05-25 post
' MIT license info below for fCirc2 algo

const sqr12 = sqr(.5)
radius = 350
ox = xmax/2
oy = ymax/2

t0 = ticks
for i = 1 to 100
  color (i mod 15 + 1)
  fCirc ox, oy, radius
next
t = ticks - t0
? t;" ms to draw 100 of these filled circles (r =350) my old fastest algo."
delay 4000

t0 = ticks
for i = 1 to 100
  color (i mod 15 + 1)
  fCirc2 ox, oy, radius
next
t = ticks - t0
? t;" ms for same circle test with new fastest algo."
pause

sub fCirc(xx, yy, r)
r2 = r * r
for x = 0 to r
  y = sqr(r2-x*x)
  line xx-x, yy+y, xx-x, yy-y
  line xx+x, yy+y, xx+x, yy-y
next
end sub

sub fCirc2(xx, yy, r)
  'const sqr12 = sqr(.5) 'in main const section
  r2 = r * r
  sqr12r = sqr12*r
  rect xx-sqr12r, yy-sqr12r, xx + sqr12r, yy+sqr12r filled
  for x = 0 to sqr12r
    y = sqr(r2-x*x)
    line xx-x, yy+sqr12r, xx-x, yy+y
    line xx-x, yy-sqr12r, xx-x, yy-y
    line xx+x, yy+sqr12r, xx+x, yy+y
    line xx+x, yy-sqr12r, xx+x, yy-y
  next
  for x = sqr12*r to r
    y = sqr(r2-x*x)
    line xx-x, yy+y, xx-x, yy-y
    line xx+x, yy+y, xx+x, yy-y
  next
end sub

##################################################################################

# The MIT License (MIT)
# Copyright (c) 2016-2017 B+=MGA
#
# Permission is hereby granted, free of charge, to any person obtaining a copy
# of this software and associated documentation files (the "Software"), to deal
# in the Software without restriction, including without limitation the rights
# to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
# copies of the Software, and to permit persons to whom the Software is
# furnished to do so, subject to the following conditions:
#
# The above copyright notice and this permission notice shall be included in all
# copies or substantial portions of the Software.
#
# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
# AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
# OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
# SOFTWARE.

##################################################################################

(see attached)

Hi Marcus,

I would have posted in Naalaa a translation of SmallBASIC code but the madness is how Naalaa does math eg floats and integers, crazy confusing for a language that claims not to be advanced.

10
Offtopic / Programming history
« on: 10. May 2017, 18:41:57 »
Here is a link to 80's computing, a series of 10 programs from UK.

I wanted to watch whole series before sharing this that was shared with me.

But it is potentially too good to wait, I think, I do know some who would love this and would not want me to hold another second.

https://www.youtube.com/watch?v=5dIcOXx3Exc&list=PLOtimvwAoYtnCtLiLspq_Gnng1XusYwPU

I don't know, Richey may have posted this already, sorry if so but I had to post this in case he hadn't.
I am sure he would enjoy this and maybe Paul Dunn as well, at least those two might like this.

Well, anyway,

Cheers


11
Offtopic / Wanted Poster
« on: 05. May 2017, 17:21:56 »

Wanted!

Code for a Coffee Machine

New or Used does Not Matter

REWARD!

Our Eternal Gratitude


Mr Coffee are you out there?

12
Code and examples / In a doNUT SHELL
« on: 04. May 2017, 05:47:32 »
Hungry for some sweet code?  ;D

Code: [Select]
' In a doNUT SHELL.bas SmallBASIC 0.12.9 (B+=MGA) 2017-05-03

const cx = xmax/2  'center screen
const cy = ymax/2
const tw = txtw("W") 'text char width
const th = txth("Q") 'text char height

sub midInk(r1, g1, b1, r2, g2, b2, fr)
  color rgb(r1+(r2-r1)*fr, g1+(g2-g1)*fr, b1+(b2-b1)*fr)
end

tload("In a doNUT SHELL.bas", f, 1)
lenF = len(f)
'lenF = 800  'don't want to get much more than 800 chars

tArea = tw * th * lenF / 1.95  'text area in pixels
'had to divide by 2 for some reason then fudge

'tArea = pi * (2/3 * r)^2
'9/4 * tArea/pi = r^2
r = sqr(9/4 * tArea/pi)

'divide screen into character cells and see if in or out of donut
' if in, print a character from this source code until run out
' then send XO's
idx = 0
for y = 0 to ymax step th
  for x = 0 to xmax step tw
    d = ((x - cx) ^ 2 + (y - cy) ^ 2) ^.5
    if r/3 < d and d < r then
      idx +=1
      at x, y
      midink(255, 255, 255, 80, 40, 20, abs(2/3*r - d)/(.335*r))
      if idx < lenF then
        ? mid(f, idx, 1);
      else
        this = iff(idx mod 2, "X", "O") : ? this;
      fi
    fi
  next
next
print
pause   

13
Code and examples / Rain drain.bas
« on: 27. April 2017, 01:53:02 »
Code: [Select]
'Rain Drain.bas  SmallBASIC 0.12.9 [B+=MGA] 2017-04-26

def rand(lo, hi) = (rnd * (hi - lo + 1)) \ 1 + lo
def rdir = iff(rnd < .5, -1, 1)
def rclr = rgb(0, rand(200, 255), rand(200, 255))

label restart
balls = 130
dim b(balls)
for i = 1 to balls
  b(i).x = rand(0, xmax - m)
  b(i).y = 0
  b(i).speed = rand(3, 15)
  b(i).r = rand(5, 15)
  b(i).c = rclr
next

m = 100
nbl = 20
dim bl(nbl)
for i = 1 to nbl
  bl(i).x1 = rand(m, xmax - m)
  bl(i).y1 = rand(m, ymax)
  bl(i).d = 300 
  bl(i).a = rnd*pi/4*rdir + rand(0,1)*pi
  bl(i).x2 = bl(i).x1 + bl(i).d * cos(bl(i).a)
  bl(i).y2 = bl(i).y1 + bl(i).d * sin(bl(i).a)
next

while 1
  cls
  if pen(3) then goto restart
  for j = 1 to balls
    if b(j).y - b(j).r > ymax or b(j).x + b(j).r < 0 or b(j).x - b(j).r > xmax then
      b(j).x = rand(m, xmax-m) : b(j).y = 0
    fi
    color b(j).c
    circle b(j).x, b(j).y, b(j).r filled
    testx = b(j).x + b(j).speed * cos(pi/2)
    testy = b(j).y + b(j).speed * sin(pi/2)
    cFlag = 0
    for i = 1 to nbl
      color 12
      line bl(i).x1, bl(i).y1, bl(i).x2, bl(i).y2
      if cFlag = 0 then
        if  ballCollide(testx, testy, b(j).r, bl(i).x1, bl(i).y1, bl(i).x2, bl(i).y2) then
          bx1 = b(j).x + b(j).speed * cos(bl(i).a)
          bx2 = b(j).x + b(j).speed * cos(pi - bl(i).a)
          by1 = yy(bx1, bl(i).x1, bl(i).y1, bl(i).x2, bl(i).y2) - b(j).r - 1
          by2 = yy(bx2, bl(i).x1, bl(i).y1, bl(i).x2, bl(i).y2) - b(j).r - 1
          if by1 = (-9999 - b(j).r - 1) or by2 = (-9999 - b(j).r - 1) then
            cFlag = 0 : exit for
          fi
          if by1 > by2 then b(j).y = by1 : b(j).x = bx1 else b(j).y = by2 : b(j).x = bx2
          cFlag = 1
        fi
      fi
    next
    if cFlag = 0 then b(j).x = testx : b(j).y = testy
  next
  showpage
wend

func ballCollide(x, y, r, x1, y1, x2, y2)
  if x1 > x2 then swap x1, x2 : swap y1, y2
  if x < x1 or x > x2 then ballCollide = 0 : exit sub
  if ((y2-y1)/(x2-x1))*(x - x1) + y1 - r < y and  y < ((y2-y1)/(x2-x1))*(x - x1) + y1 + r then
    ballCollide = 1
  else
    ballCollide = 0
  fi
end

func yy(x, x1, y1, x2, y2)
  if x1 > x2 then swap x1, x2 : swap y1, y2
  if x1 <= x and x <= x2 then
    yy = ((y2-y1)/(x2-x1)) * (x - x1) + y1
  else
    yy = -9999
  fi
end

14
Code and examples / Bonkers Air Hockey
« on: 23. April 2017, 18:38:17 »
Mouse controls Player's striker on right. Computer dumbed down, when puck is behind computer striker, striker only moves along x and can knock puck into player's goal. When puck is again in front of the computer striker, it will jump into action. Had to do something so humans have a chance to win.  ;)
Code: [Select]
'Bonkers Air Hockey.bas for SmallBASIC 0.12.9 2017-04-22 (started) from
'bplus paddleball 2016-02-05 for SmallBASIC 0.12.2 [B+=MGA]
'and Bonkers Methods of tracking puck angle and collisions

const pr = 16                'puck radius
const pr2 = 2 * pr           'puck diameter = bumper width = radius of strikers
const tl = xmax              'table length
const tw = tl / 2            'table width
const tw13 = .3333 * tw \ 1  'goal end point
const tw23 = .6667 * tw \ 1  'goal end point
const speed = 40
const midc = (tl - 2 * pr2) \ 4    'mid point x of computer's field

computer = 0   'score
player = 0     'score
initball
pen on
while player < 21 and computer < 21
  cls
  updateScore
  drawTable
  drawComputerStriker
  drawPlayerStriker
  drawPuck
  showpage
  delay 10
wend
pen off
if computer > player then
  s = "Game Won by Computer."
else
  s = "Game Won by Player!"
end if
color rgb(200, 240, 140)
text (tl - txtw(s))/2, tw + 30, 26, s
showpage
delay 3000

sub initball
  px = tl/2 : py = tw/2 : pa = pi + rnd * pi/10
  rnddir = (rnd*2)\1 : if rnddir then pa = pi-pa
end

sub updateScore
  color rgb(40, 200, 255)
  s = "Computer: " + str(computer) + space(50) +"Player: " + str(player)
  text (tl - txtw(s))/2, tw + 30, 26, s
end

sub drawTable
  for i = 0 to pr2 step 4
    shade = 64 + i/pr2 * 100
    color rgb(shade, shade, shade)
    rect i, i, tl-i, tw-i filled
  next                                 
  rect pr2, pr2, tl - pr2, tw - pr2, rgb(190, 230, 255) filled 'field
  rect pr, tw13, pr2, tw23, rgb(60, 60, 60) filled                           'player goal
  rect tl - pr2, tw13, tl-pr, tw23, rgb(60, 60, 60) filled                   'computer goal
  rect tl \ 2 - 1, pr2, tl \ 2 + 1, tw- pr2, 8 filled          'center line
end

sub drawPlayerStriker
  psx = pen(4) : psy = pen(5)
  if psx - pr2 < tl/2     then psx = tl/2 + pr2
  if psx + pr2 > tl - pr2 then psx = tl - 2 * pr2
  if psy - pr2 < pr2      then psy = 2 * pr2
  if psy + pr2 > tw - pr2 then psy = tw - 2 * pr2
  striker psx, psy
end

sub drawComputerStriker
  c1 += pi/80
  csx = midc + pr2 + (midc-pr2) * sin(c1)
  if px > csx then csy = py + pr2 * 1.5 * sin(c1)
  if csy - pr2 < pr2 then csy = 2 * pr2
  if csy + pr2 > tw - pr2 then csy = tw - 2 * pr2
  striker csx, csy
end

sub drawPuck
  'update ball x, y and see if hit anything
  px = px + speed * cos(pa)
  py = py + speed * sin(pa)
 
  if px - pr < pr2 then
    if tw13 < py - pr and py + pr < tw23 then
      player += 1
      cls
      updateScore
      drawTable
      striker csx, csy
      striker psx, psy
      puck pr, py
      for i = 0 to pr step 4
        shade = 64 + i/pr2 * 100
        color rgb(shade, shade, shade)
        rect i, t13, pr, tw23 filled
      next 
      sound 1200, 200
      sound 2200, 300
      showpage
      initball
      delay 500
      exit sub
    else
      sound 2600, 8
      pa = pi - pa
      px = pr2 + pr
    fi
  fi
     
  if px + pr > tl - pr2 then
    if tw13 < py - pr and py + pr < tw23 then
      computer += 1
      cls
      updateScore
      drawTable
      striker csx, csy
      striker psx, psy
      puck tl-pr, py
      for i = 0 to pr step 4
        shade = 64 + i/pr2 * 100
        color rgb(shade, shade, shade)
        rect tl-pr, t13, tl-i, tw23 filled
      next
      sound 2200, 300
      sound 1200, 200
      showpage
      initball
      delay 500
      exit sub
    else
      sound 2600, 5
      pa = pi - pa
      px = tl - pr2 - pr
    fi
  fi
 
  if py - pr < pr2 then
    sound 2600, 8
    pa = -pa
    py = pr2 + pr
  fi

  if py + pr > tw - pr2 then
    sound 2600, 8
    pa = - pa
    py = tw - pr2 - pr
  end if
 
  if sqr((px-psx)^2 + (py-psy)^2) < (pr + pr2) then
    pa = atan2(py-psy, px-psx)
    sound 2200, 4
  fi
  if sqr((px-csx)^2 + (py-csy)^2) < (pr + pr2) then
    pa = atan2(py-csy, px-csx)
    sound 2200, 4
  fi       
  puck px, py
end

sub puck(x, y)
  color rgb(90, 90, 90)
  circle x, y, pr filled
  color rgb(190, 100, 0)
  circle x, y, pr - 4 filled
end

sub striker(x, y)
  local i
  for i = pr2 to pr step -1
    shade = 164 - 90 * sin((i)*2*pi/pr)
    color rgb(shade, shade, shade)
    circle x, y, i filled
  next
  for i = pr to 0 step -1
    shade = 185 + 70*(pr - i)/pr
    color rgb(shade, shade, shade)
    circle x, y, i filled
  next
end

sub text(x, y, size, s) ' a sub to make translating to SmallBASIC from SdlBasic easier
  'when this sub is used text size is altered for the rest of the run
  local l
  l.w = window() : l.w.setfont(size, "pt", 0, 0)
  at x, y : ? s
end

15
Code and examples / Bonkers Symphony Number 37
« on: 21. April 2017, 23:00:26 »
Code: [Select]
' Bonkers Symphony Number 37.bas  SmallBASIC 0.12.9 [B+=MGA] 2017-04-21

def rand(lo, hi) = (rnd * (hi - lo + 1)) \ 1 + lo
def rdir = iff(rnd < .5, -1, 1)

gravity = 3

'balls
bR = 10
n = 80
speed = 12
dim x(n), y(n), a(n), c(n), rr(n), gg(n), bb(n), rd(n)
for i = 1 to n
  x(i) = rand(xmax/2-10, xmax/2+10)
  y(i) = rand(-200, 0)
  rd(i) = rand(3, 20)
  a(i) = pi/2 + pi/90 * rdir
  rr(i) = rand(60, 100)
  gg(i) = rand(60, 100)
  bb(i) = rand(60, 100)
next

'pins
pR = 25
maxrow = 7
nP = maxrow * (maxrow + 1) * .5
pxo = xmax / (maxrow + 1) 'pin space along x
pyo = ymax / (maxrow + 1) 'pin spacing along y
dim px(nP), py(nP)
for row = 1 to maxrow
  for col = 1 TO row
    pidx +=1
    px(pidx) = pxo*col+(maxrow - row) * .5*pxo
    py(pidx) = pyo*row
  next
next

clrMode = 1
while 1
  k = inkey
  if asc(k) = 32 then clrMode *= -1
  if clrMode < 0 then cls

  'draw pins
  for i = 1 to nP
    for r = pR to 1 step -1
      color rgb(r/pR*255,r/pR*255, r/pR*255)
      circle px(i), py(i), r filled
    next
  next
 
  'calc collsions
  for i = 1 to n
    for j = 1 to nP
      if sqr((x(i)-px(j))^2 + (y(i)-py(j))^2) < rd(i) + pR then
          a(i) = atan2(y(i)-py(j), x(i)-px(j))
          color 0
          circle px(j), py(j), pR filled
          sound 120 + py(j)/ ymax * 5000, px(j) / xmax * 55
          exit for
      end if
    next
    for j = i + 1 to n
      if j <> i and c(j) <> 1 then
        if sqr((x(i)-x(j))^2 + (y(i)-y(j))^2) < rd(i) + rd(j) then
          a(i) = atan2(y(i)-y(j), x(i)-x(j))
          a(j) = atan2(y(j)-y(i), x(j)-x(i))
          c(i) = 1 : c(j) = 1
          exit for
        fi
      fi
    next
   
    'update balls
    dx = cos(a(i)) * speed
    dy = sin(a(i)) * speed + gravity
    a(i) = atan2(dy, dx)
    x(i) = x(i) + cos(a(i)) * speed
    y(i) = y(i) + sin(a(i)) * speed
   
    if x(i) < rd(i) or x(i) > xmax + rd(i) or y(i) > ymax + rd(i) then
      x(i) = rand(xmax/2-10, xmax/2+10)
      y(i) = rand(-250, -bR)
      a(i) = pi/2 + pi/90 * rdir
    fi
    if a(i) > 2 * pi then a(i) = a(i) - 2 * pi
    if a(i) < 0 then a(i) = a(i) + 2 * pi
   
   for r = rd(i) to 1 step -1
      color rgb(255-rr(i)-150*r/rd(i), 255-gg(i)-150*r/rd(i), 255-bb(i)-150*r/rd(i))
      circle x(i), y(i), r filled
    next
    c(i) = 0
  next
  showpage
  delay 10
wend


Pages: [1] 2 3 ... 5