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 ... 6
1
General questions and discussions / Sudoku
« on: 11. January 2018, 17:54:51 »
Hi,

I am studying Sudoku Game and probably will revisit Solvers eventually, at these sites:

Just Basic: http://justbasic.conforums.com/index.cgi?board=code&action=display&num=1515342883

SmallBASIC: https://smallbasic.sourceforge.io/?q=node/1773

QB64: http://www.qb64.net/forum/index.php?topic=14672.0

and here The Joyful Programmer > The QB64 Edition:
http://qb64.thejoyfulprogrammer.com/showthread.php?tid=1207&pid=5720&rndtime=15156870881901289581#pid5720

My main interest is perfecting THE GAME algorithms, board making and cell hiding such that when you hide the cells you don't create a board that can be solved more than one way.

I've already learned you can make a legit board for a game but it is trivial to solve, as discussed or illustrated in above links.

I have devised code that will create non trivial boards but need an algo to hide the cells but keep solution unique, ie only one solution set. Is there one? 

Could I understand how it is put together and works? ;-))

2
Code and examples / Happy New Year 2018
« on: 30. December 2017, 18:53:16 »
From a little challenge at the QB64.net forum:
Code: [Select]
_TITLE "Happy Trails 2018"
' 2017-12-29 another redesign of fireworks
' 2017-12-28 redesign fireworks
' now with lake refelction 2017-12-27 forget the bouncing sparks
' combine Welcome Plasma Font with landscape
'_title "Fireworks 3 translation to QB64 2017-12-26 bplus"
'fireworks 3.bas SmallBASIC 0.12.2 [B+=MGA] 2015-05-09
'fireworks 2.bas 2016-05-05 now with Gravity, Newtonian bounce, smoke debris
'fireworks 3.bas try with map variables make bursts around a central point


RANDOMIZE TIMER
CONST xmax = 1200
CONST ymax = 720
CONST waterline = 600 ' 600 = ratio 5 to 1 sky to water
'                       raise and lower waterline as desired  highest about 400?
CONST lTail = 15
CONST bluey = 5 * 256 ^ 2 + 256 * 5 + 5
CONST debrisMax = 28000

SCREEN _NEWIMAGE(xmax, ymax, 32)
_SCREENMOVE 120, 20

TYPE fireWorkType
    x AS INTEGER
    y AS INTEGER
    seed AS INTEGER
    age AS INTEGER
    life AS INTEGER
END TYPE


TYPE debrisType
    x AS SINGLE
    y AS SINGLE
    c AS LONG
END TYPE

COMMON SHARED fw() AS fireWorkType
COMMON SHARED debris() AS debrisType
COMMON SHARED cN, pR!, pG!, pB!

SCREEN _NEWIMAGE(xmax, ymax, 32)

'prepare message font
mess$ = " Happy New Year 2018"
PRINT mess$
w = 8 * LEN(mess$): h = 16
DIM p(w, h)
black&& = POINT(0, 10)
FOR y = 0 TO h
    FOR x = 0 TO w
        IF POINT(x, y) <> black&& THEN
            p(x, y) = 1
        END IF
    NEXT
NEXT
xo = 0: yo = 15: m = 7.2
resetPlasma

'prepare landscape
CLS
land& = _NEWIMAGE(xmax, ymax, 32)
_DEST land&
drawLandscape
_DEST 0

'prepare fire works
nFW = 3
DIM fw(1 TO 10) AS fireWorkType
FOR i = 1 TO nFW
    initFireWork (i)
NEXT

'debris feild
DIM debris(debrisMax) AS debrisType

'OK start the show
WHILE 1
    'cls screen with land image
    _PUTIMAGE , land&, 0

    'draw fireworks
    FOR f = 1 TO nFW
        IF fw(f).age <= fw(f).life THEN drawfw (f) ELSE initFireWork f
    NEXT

    'debris
    FOR i = 0 TO debrisStack
        PSET (debris(i).x, debris(i).y), debris(i).c
        debris(i).x = debris(i).x + RND * 3 - 1.5
        debris(i).y = debris(i).y + RND * 3.5 - 1.5
        IF debris(i).x < 0 OR debris(i).y < 0 OR debris(i).x > xmax OR debris(i).y > waterline + RND * 20 THEN NewDebris (i)
    NEXT

    'text message in plasma
    FOR y = 0 TO h - 1
        FOR x = 0 TO w - 1
            IF p(x, y) THEN
                changePlasma
            ELSE
                COLOR 0
            END IF
            LINE (xo + x * m, yo + y * m)-(xo + x * m + m, yo + y * m + m), , BF
        NEXT
    NEXT
    lc = lc + 1
    IF lc MOD 200 = 0 THEN resetPlasma

    'reflect sky
    skyWaterRatio = waterline / (ymax - waterline) - .05
    FOR y = waterline TO ymax
        FOR x = 0 TO xmax
            c&& = POINT(x, waterline - ((y - waterline - 1) * skyWaterRatio) + RND * 5)
            PSET (x, y + 1), c&& + bluey
        NEXT
    NEXT

    _DISPLAY
    _LIMIT 50 'no limit needed on my system!

    'accumulate debris
    IF lc MOD 2000 THEN
        IF debrisStack < debrisMax THEN
            FOR i = 1 TO 2
                NewDebris i + debrisStack
            NEXT
            debrisStack = debrisStack + 2
        END IF
    END IF
WEND

SUB NewDebris (i)
    debris(i).x = RND * xmax
    debris(i).y = RND * ymax
    c = RND * 155
    debris(i).c = _RGB32(c, c, c)
END SUB

SUB changePlasma ()
    cN = cN + .01
    COLOR _RGB(127 + 127 * SIN(pR! * .3 * cN), 127 + 127 * SIN(pG! * .3 * cN), 127 + 127 * SIN(pB! * .3 * cN))
END SUB

SUB resetPlasma ()
    pR! = RND ^ 2: pG! = RND ^ 2: pB! = RND ^ 2
END SUB

SUB drawLandscape
    'the sky
    FOR i = 0 TO ymax
        midInk 0, 0, 0, 78, 28, 68, i / ymax
        LINE (0, i)-(xmax, i)
    NEXT
    'the land
    startH = waterline - 80
    rr = 10: gg = 20: bb = 15
    FOR mountain = 1 TO 6
        Xright = 0
        y = startH
        WHILE Xright < xmax
            ' upDown = local up / down over range, change along Y
            ' range = how far up / down, along X
            upDown = (RND * .8 - .35) * (1 / (1 * mountain))
            range = Xright + rand&&(5, 35) * 2.5 / mountain
            lastx = Xright - 1
            FOR X = Xright TO range
                y = y + upDown
                COLOR _RGB32(rr, gg, bb)
                LINE (lastx, y)-(X, ymax), , BF 'just lines weren't filling right
                lastx = X
            NEXT
            Xright = range
        WEND
        rr = rand&&(rr + 5, rr): gg = rand&&(gg + 5, gg): bb = rand&&(bb + 4, bb)
        IF rr < 0 THEN rr = 0
        IF gg < 0 THEN gg = 0
        IF bb < 0 THEN bb = 0
        startH = startH + rand&&(1, 10)
    NEXT
    'LINE (0, waterline)-(xmax, ymax), _RGB32(0, 0, 0), BF
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 SUB

FUNCTION rand&& (lo&&, hi&&)
    rand&& = INT(RND * (hi&& - lo&& + 1)) + lo&&
END FUNCTION

SUB drawfw (i)
    'here's how to "save" a bunch of random numbers without data and arrays but tons of redundant calculations
    RANDOMIZE USING fw(i).seed 'this repeats all random numbers generated by seed in same sequence
    'recreate our firework from scratch!
    red = rand&&(200, 255)
    green = rand&&(200, 255)
    blue = rand&&(200, 255)
    x = rand&&(1, 4)
    IF x = 1 THEN
        red = 0
    ELSEIF x = 2 THEN
        green = 0
    ELSEIF x = 3 THEN
        blue = 0
    ELSE
        x = rand&&(1, 4)
        IF x = 1 THEN
            red = 0: green = 0
        ELSEIF x = 2 THEN
            green = 0: blue = 0
        ELSEIF x = 3 THEN
            blue = 0: red = 0
        END IF
    END IF
    ne = rand&&(80, 300)
    DIM embers(ne, 1)
    FOR e = 0 TO ne
        r = RND * 3
        embers(e, 0) = r * COS(e * _PI(2) / 101)
        embers(e, 1) = r * SIN(e * _PI(2) / 101)
    NEXT
    start = fw(i).age - lTail ' don't let tails get longer than lTail const
    IF start < 1 THEN start = 1
    FOR e = 0 TO ne
        cx = fw(i).x: cy = fw(i).y: dx = embers(e, 0): dy = embers(e, 1)
        FOR t = 1 TO fw(i).age
            cx = cx + dx
            cy = cy + dy
            IF t >= start THEN
                'too much like a flower?
                midInk 60, 60, 60, red, green, blue, (t - start) / lTail
                'midInk 60, 60, 60, 128, 160, 150, (t - start) / lTail
                fcirc cx, cy, (t - start) / lTail
            END IF

            dx = dx * .99 'air resitance
            dy = dy + .01 'gravity
        NEXT
        COLOR _RGB32(255, 255, 255)
        'COLOR _RGB32(red, green, blue)
        cx = cx + dx: cy = cy + dy
        fcirc cx, cy, (t - start) / lTail
    NEXT
    fw(i).age = fw(i).age + 1
END SUB

SUB initFireWork (i)
    fw(i).x = rand&&(.1 * xmax, .9 * xmax)
    fw(i).y = rand&&(.1 * ymax, .5 * ymax)
    fw(i).seed = rand&&(0, 32000)
    fw(i).age = 0
    fw(i).life = rand&&(20, 120)
END SUB

'Steve McNeil's  copied from his forum   note: Radius is too common a name
SUB fcirc (CX AS LONG, CY AS LONG, R AS LONG)
    DIM subRadius AS LONG, RadiusError AS LONG
    DIM X AS LONG, Y AS LONG

    subRadius = ABS(R)
    RadiusError = -subRadius
    X = subRadius
    Y = 0

    IF subRadius = 0 THEN PSET (CX, CY): EXIT SUB

    ' Draw the middle span here so we don't draw it twice in the main loop,
    ' which would be a problem with blending turned on.
    LINE (CX - X, CY)-(CX + X, CY), , BF

    WHILE X > Y
        RadiusError = RadiusError + Y * 2 + 1
        IF RadiusError >= 0 THEN
            IF X <> Y + 1 THEN
                LINE (CX - Y, CY - X)-(CX + Y, CY - X), , BF
                LINE (CX - Y, CY + X)-(CX + Y, CY + X), , BF
            END IF
            X = X - 1
            RadiusError = RadiusError - X * 2
        END IF
        Y = Y + 1
        LINE (CX - X, CY - Y)-(CX + X, CY - Y), , BF
        LINE (CX - X, CY + Y)-(CX + X, CY + Y), , BF
    WEND
END SUB

Maybe last post from the "dinosaur", got a new laptop where the limit in main loop is actually needed!

3
For some Hodiday fun, you might enjoy this link to the QB64 Season's Greeting Challenge:

http://www.qb64.net/forum/index.php?topic=14646.0

Merry Christmas!

4
Code and examples / Great balls of fire
« on: 24. November 2017, 05:00:46 »
Code: [Select]
'Great balls of fire.bas SmallBASIC 0.12.9 (B+=MGA) 2017-11-23

xxmax = 180 : yymax = 85  'pixels too slow
xstep = xmax / xxmax : ystep = ymax / yymax
dim p(300)  'pallette thanks harixxx
for i = 1 to 100
  fr = 240 * i / 100 + 15
  p(i) = rgb(fr, 0, 0)
  p(i + 100) = rgb(255, fr, 0)
  p(i + 200) = rgb(255, 255, fr)
next
dim f(xxmax, yymax) 'fire array tracks flames
nb = 13             'number of balls
acc = .1            'gravity
br = 4              'ball radius
brs = br * br       'ball radius squared
dim b(1 to nb)      'ball array
for i = 1 to nb     'ball maker
  b(i).x = (xxmax - 2 * br) * rnd + br            'x location
  b(i).y = (yymax - 2 * br) * (i - 1) / nb + br   'y location
  if rnd < .5 then b(i).dx = 1 + rnd * 2 else b(i).dx = -1 - rnd * 2  'dx change of x
  b(i).dy = 1                                                         'dy change of y
next

while 1  'main show
 
  cls 'some flames are sticking
  for i = 0 to xxmax : f(i, yymax) = 0 : f(i, yymax - 1) = 0 : next
  for i = 0 to yymax : f(0, i) = 0 : next
   
  for y = 1 to yymax - 2  'fire based literally on 4 pixels below it like cellular automata
    for x = 1 to xxmax - 1
      f(x, y) = max( (f(x - 1, y + 1) + f(x, y + 1) +f(x + 1, y + 1) + f(x, y + 2) ) / 4 - 5, 0)
      rect x * xstep, y * ystep, step xstep + 1, ystep + 1, p(f(x, y)) filled
    next
  next
 
  for i = 1 to nb  'move ball
    b(i).dy = b(i).dy + acc
   
    'new location unless out of boundsw
    b(i).y = b(i).y + b(i).dy
    b(i).x = b(i).x + b(i).dx
   
    'keep ball in bounds
    if b(i).y > yymax - br then b(i).dy = -.9 * b(i).dy : b(i).y = yymax - br : b(i).dx = b(i).dx *.9
    if b(i).x < br  then b(i).dx = -.9 * b(i).dx : b(i).x = br
    if b(i).x > xxmax - br  then b(i).dx = -.9 * b(i).dx : b(i).x = xxmax - br
   
    'handle new location
    fireBall b(i).x, b(i).y
   
    'handle dead balls
    if abs(b(i).lastbx - b(i).x)< .01 and abs(b(i).lastby-b(i).y) < .01  then
      b(i).x = (xxmax - 2 * br) * rnd + br
      b(i).y =  0
      b(i).dy = 1
      if rnd < .5 then b(i).dx = 1 + rnd * 2 else b(i).dx = -1 - rnd * 2  'edit
    fi
    b(i).lastby = b(i).y : b(i).lastbx = b(i).x
   
  next
  showpage
  delay 10
wend

sub fireBall(x, y)
  local xr, yr, yrMax
  for yr = 0 to br
    if y + yr <= yymax - 2  then f(x, y + yr) = 300
    if y - yr >= 0 then f(x, y - yr) = 300
  next
  for xr = 0 to br
    yrMax = (brs - xr * xr) ^ .5
    for yr = 0 to yrMax
      if x + xr < xxmax - 1 and y + yr <= yymax - 1  then f(x + xr, y + yr) = 300
      if x + xr < xxmax - 1 and y - yr >= 0  then f(x + xr, y - yr) = 300
      if x - xr >= 0 and y + yr <= yymax then f(x - xr, y + yr) = 300
      if x - xr >= 0 and y - yr >= 0  then f(x - xr, y - yr) = 300 
    next
  next
  circle x * xstep, y * ystep - ystep, br * xstep, xstep / ystep, p(300) filled
end

5
Community news and announcements / Game Competition
« on: 04. November 2017, 15:16:39 »
Richey's post reminded me of this:
http://www.qb64.net/forum/index.php?topic=14570.0

Hosted by GitHub, another game coding competition that is not too late to submit (I think).

wait... do game coders come here?

6
Code and examples / Halloween Reoccurence
« on: 31. October 2017, 04:28:10 »
Another occurrence of another variation, kind of scary how it wont go away...

QB64 so I had to make my own ellipse and fill triangle subs.

Code: [Select]
_TITLE "Halloween Reoccurence 2017-10-29 bplus"
CONST xmax = 1100
CONST ymax = 740

SCREEN _NEWIMAGE(xmax, ymax, 32)
_SCREENMOVE 160, 2

RANDOMIZE TIMER
COMMON SHARED sx
cx = xmax / 2: cy = ymax / 2: pr = .49 * xmax
d = 1: sx = 0
WHILE 1
    pumpkin cx, cy, pr, 3
    sx = sx + rand%(-4, 4)
    IF sx > .7 * pr / 12 THEN d = -1 * d: sx = 0
    IF sx < -.7 * pr / 12 THEN d = -1 * d: sx = 0
    _DISPLAY
    _LIMIT 6
WEND

FUNCTION rand% (lo%, hi%)
    rand% = INT(RND * (hi% - lo% + 1)) + lo%
END FUNCTION

SUB pumpkin (cx, cy, pr, limit)
    'carve this!
    COLOR &HFFFF0000
    fEllipse cx, cy, pr, 29 / 35 * pr
    COLOR &HFF000000
    lastr = 2 / 7 * pr
    DO
        ellipse cx, cy, lastr, 29 / 35 * pr
        lastr = .5 * (pr - lastr) + lastr + 1 / 35 * pr
        IF pr - lastr < 1 / 80 * pr THEN EXIT DO
    LOOP

    ' 'flickering candle light
    COLOR _RGB(RND * 55 + 200, RND * 55 + 200, 120)

    ' eye sockets
    ftri cx - 9 * pr / 12, cy - 2 * pr / 12, cx - 7 * pr / 12, cy - 6 * pr / 12, cx - 3 * pr / 12, cy - 0 * pr / 12
    ftri cx - 7 * pr / 12, cy - 6 * pr / 12, cx - 3 * pr / 12, cy - 0 * pr / 12, cx - 2 * pr / 12, cy - 3 * pr / 12
    ftri cx + 9 * pr / 12, cy - 2 * pr / 12, cx + 7 * pr / 12, cy - 6 * pr / 12, cx + 3 * pr / 12, cy - 0 * pr / 12
    ftri cx + 7 * pr / 12, cy - 6 * pr / 12, cx + 3 * pr / 12, cy - 0 * pr / 12, cx + 2 * pr / 12, cy - 3 * pr / 12

    ' nose
    ftri cx, cy - rand%(2, 5) * pr / 12, cx - 2 * pr / 12, cy + 2 * pr / 12, cx + rand%(1, 2) * pr / 12, cy + 2 * pr / 12

    ' evil grin
    ftri cx - 9 * pr / 12, cy + 1 * pr / 12, cx - 7 * pr / 12, cy + 7 * pr / 12, cx - 6 * pr / 12, cy + 5 * pr / 12
    ftri cx + 9 * pr / 12, cy + 1 * pr / 12, cx + 7 * pr / 12, cy + 7 * pr / 12, cx + 6 * pr / 12, cy + 5 * pr / 12

    ' moving teeth/talk/grrrr..
    u = rand%(4, 8)
    dx = pr / u
    FOR i = 1 TO u
        tx1 = cx - 6 * pr / 12 + (i - 1) * dx
        tx2 = tx1 + .5 * dx
        tx3 = tx1 + dx
        ty1 = cy + 5 * pr / 12
        ty3 = cy + 5 * pr / 12
        ty2 = cy + (4 - RND) * pr / 12
        ty22 = cy + (6 + RND) * pr / 12
        ftri tx1, ty1, tx2, ty2, tx3, ty3
        ftri tx1 + .5 * dx, ty1, tx2 + .5 * dx, ty22, tx3 + .5 * dx, ty3
    NEXT
    IF limit THEN

        'shifty eyes
        IF limit = 3 THEN sxs = sx ELSE sxs = .1 * sx
        pumpkin sxs + cx - 5 * pr / 12, cy - 2.5 * pr / 12, .15 * pr, INT(limit - 1)
        pumpkin sxs + cx + 5 * pr / 12, cy - 2.5 * pr / 12, .15 * pr, INT(limit - 1)
    END IF
END SUB

SUB fEllipse (CX AS LONG, CY AS LONG, xRadius AS LONG, yRadius AS LONG)
    DIM scale AS SINGLE, x AS LONG, y AS LONG
    scale = yRadius / xRadius
    LINE (CX, CY - yRadius)-(CX, CY + yRadius), , BF
    FOR x = 1 TO xRadius
        y = scale * SQR(xRadius * xRadius - x * x)
        LINE (CX + x, CY - y)-(CX + x, CY + y), , BF
        LINE (CX - x, CY - y)-(CX - x, CY + y), , BF
    NEXT
END SUB

SUB ellipse (CX AS LONG, CY AS LONG, xRadius AS LONG, yRadius AS LONG)
    DIM scale AS SINGLE, xs AS LONG, x AS LONG, y AS LONG
    DIM lastx AS LONG, lasty AS LONG
    scale = yRadius / xRadius: xs = xRadius * xRadius
    PSET (CX, CY - yRadius): PSET (CX, CY + yRadius)
    lastx = 0: lasty = yRadius
    FOR x = 1 TO xRadius
        y = scale * SQR(xs - x * x)
        LINE (CX + lastx, CY - lasty)-(CX + x, CY - y)
        LINE (CX + lastx, CY + lasty)-(CX + x, CY + y)
        LINE (CX - lastx, CY - lasty)-(CX - x, CY - y)
        LINE (CX - lastx, CY + lasty)-(CX - x, CY + y)
        lastx = x: lasty = y
    NEXT
END SUB

SUB ftri (xx1, yy1, xx2, yy2, xx3, yy3)
    'make copies before swapping
    x1 = xx1: y1 = yy1: x2 = xx2: y2 = yy2: x3 = xx3: y3 = yy3
    'thanks Andy Amaya!
    'triangle coordinates must be ordered: where x1 < x2 < x3
    IF x2 < x1 THEN SWAP x1, x2: SWAP y1, y2
    IF x3 < x1 THEN SWAP x1, x3: SWAP y1, y3
    IF x3 < x2 THEN SWAP x2, x3: SWAP y2, y3
    IF x1 <> x3 THEN slope1 = (y3 - y1) / (x3 - x1)

    'draw the first half of the triangle
    length = x2 - x1
    IF length <> 0 THEN
        slope2 = (y2 - y1) / (x2 - x1)
        FOR x = 0 TO length
            LINE (INT(x + x1), INT(x * slope1 + y1))-(INT(x + x1), INT(x * slope2 + y1))
            'lastx2% = lastx%
            lastx% = INT(x + x1)
        NEXT
    END IF

    'draw the second half of the triangle
    y = length * slope1 + y1: length = x3 - x2
    IF length <> 0 THEN
        slope3 = (y3 - y2) / (x3 - x2)
        FOR x = 0 TO length
            'IF INT(x + x2) <> lastx% AND INT(x + x2) <> lastx2% THEN  'works! but need 2nd? check
            IF INT(x + x2) <> lastx% THEN
                LINE (INT(x + x2), INT(x * slope1 + y))-(INT(x + x2), INT(x * slope3 + y2))
            END IF
        NEXT
    END IF
END SUB

7
Code and examples / Fall Foliage
« on: 21. October 2017, 10:26:18 »
Code: [Select]
'fall foliage.bas SmallBASIC 0.12.9 (B+=MGA) 2017-10-21

'test landscape and portrait views for Android
xmx = min(xmax, 800) : ymx = min(600, ymax) 'portrait
'OK it's just plain better in landscape view

'now for full viewing enjoyment
xmx = xmax : ymx = ymax

n = 3
while 1
  if n < 15 then n = n + 3
  horizon = rand(.8 * ymx, .9 * ymx)
  for i= 0 to horizon
    midInk 0, 0, 128, 10, 120, 128, i/horizon
    line 0, i, xmx, i
  next
  for i = horizon to ymx
    midInk 70, 108, 30, 60, 10, 5, (i-horizon)/(ymx-horizon)
    line 0, i, xmx, i
  next
  for i = 1 to xmx * ymx * .00018
    leaf rand(0, xmx), rand(horizon * 1.002, ymx)
  next
  if n < .01 * xmx then trees = n else trees = rand(.01 * xmx, .03 * xmx)
  for i = 1 to trees
    y = horizon + .04 * ymx + i / trees * (ymx - horizon - .1 * ymx)
    r = .01 * y : h = rand(y * .15, y * .18)
    branch rand(10, xmx - 10), y, r, 90, h, 0
  next
  rect xmx, 0, xmax, ymax, 0 filled
  rect 0, ymx, xmx, ymax, 0 filled
  showpage
  delay 2000
wend

sub branch(x, y, startr, angD, length, lev)
  local x2, y2, dx, dy, bc, i
  x2 = x + cos(rad(angD)) * length
  y2 = y - sin(rad(angD)) * length
  dx = (x2 - x) / length
  dy = (y2 - y) / length
  bc = rgb(30 + 6 * lev, 15 + 3 * lev, 5 + 2 * lev)
  for i = 0 to length
    circle x + dx * i, y + dy * i, startr, 1, bc filled
  next
  if lev > 1 then leaf x2, y2
  if .8 * startr < .1 or lev > 7 or length < 3 then exit sub
  lev += 1
  branch x2, y2, .8 * startr, angD + 22 + rand(-10, 19), rand(.75 * length, .9 * length), lev
  branch x2, y2, .8 * startr, angD - 22 - rand(-10, 19), rand(.75 * length, .9 * length), lev
end

sub leaf(x, y)
   local sp, n, c, xoff, yoff, woff, hoff
   sp = 15 : leafs = rand(xmx * ymx * .00001, xmx * ymx * .00002)
   for n = 1 to leafs
      c = rgb(rand(50, 250), rand(25, 255), rand(0, 40))
      xoff = x + rnd * sp - rnd * sp
      yoff = y + rnd * sp - rnd * sp
      woff = 3 + rnd * 3
      hoff = 3 + rnd * 3
      rect xoff, yoff step woff, hoff, c filled
   next
end

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

def rand(lo, hi) = (rnd * (hi - lo + 1)) \ 1 + lo


8
Code and examples / Here is my favorite screen saver from past
« on: 30. September 2017, 15:13:32 »
This is all from memory, I tried to look up Mystic Screen saver and got nowhere... so I might have the name wrong.

SmallBASIC version:
Code: [Select]
' Mystic memories.bas SmallBASIC 0.12.9 (B+=MGA) 2017-09-29
' I modified from my posted 2017-09-29 for QB64
' Mystic screen saver as I remember it plus...

option predef antialias off  'runs faster (or smoother) might improve image
randomize timer
dim x(2), y(2), dx(2), dy(2)
for i = 0 to 2
    newPoint i
next
saveX = x : saveY = y : saveDX = dx : saveDY = dy
dmode = 1 : nT = 50
resetPlasma
while 1
  cls
  color 11
  ? " Number of triangles = ";nT;" press m for more, l for less,"
  ? " spacebar to change color, d for duplicate image toggle."
  cN = cN - nT + 1
  x = saveX : y = saveY : dx = saveDX : dy = saveDY
  for i = 0 to 2
    updatePoint i
  next
  saveX = x : saveY = y : saveDX = dx : saveDY = dy
  for j = 1 to nT
    for i = 0 to 2
      updatePoint i
    next
    changePlasma
    for i = 0 to 2
      line x(i), y(i), x((i+1) mod 3), y((i+1) mod 3)
    next
    if dmode = 1 then
      for i = 0 to 2
        line xmax - x(i), ymax - y(i), xmax - x((i+1) mod 3), ymax - y((i+1) mod 3)
      next
    end if
  next
  showpage
  delay 10
  k = inkey
  if k = " " then
    resetPlasma
  elif k = "d"
    dmode = not dmode
  elif k = "m"
    nT = nT + 1: if nT > 100 then nT = 100
  elif k = "l"
    nT = nT - 1: if nT < 1 then nT = 1
  fi
wend

sub newPoint(p)
  x(p) = RND * xmax
  y(p) = RND * ymax
  dx(p) = (RND * 10 + 1) * rdir
  dy(p) = (RND * 6 + 1) * rdir
end

sub updatePoint(p)
  if x(p) + dx(p) < 0 then dx(p) = -dx(p)
  if y(p) + dy(p) < 40 then dy(p) = -dy(p)
  if x(p) + dx(p) > xmax then dx(p) = -dx(p)
  if y(p) + dy(p) > ymax - 40 then dy(p) = -dy(p)
  x(p) = x(p) + dx(p)
  y(p) = y(p) + dy(p)
end

sub changePlasma ()
  cN = cN + 1
  color rgb(127 + 127 * sin(pR * .2 * cN), 127 + 127 * sin(pG * .2 * cN), 127 + 127 * sin(pB * .2 * cN))
end

sub resetPlasma ()
  pR = rnd ^ 2: pG = rnd ^ 2: pB = rnd ^ 2
end

func rdir()
  IF rnd < .5 THEN rdir = -1 ELSE rdir = 1
end




QB64 version (which you might see, no great difference in PL):
Code: [Select]
_TITLE "Mystic Memories by bplus, d toggles duplicate on/off, spacebar resets color, m = more, l = less triangles"
'posted 2017-09-29 for QB64, Mystic screen saver as I remember it plus...

RANDOMIZE TIMER
CONST xmax = 1100
CONST ymax = 700

TYPE point
    x AS INTEGER
    y AS INTEGER
    dx AS SINGLE
    dy AS SINGLE
END TYPE
COMMON SHARED pR, pG, pB, cN
SCREEN _NEWIMAGE(xmax, ymax, 32)
_SCREENMOVE (_DESKTOPWIDTH - xmax) / 2, (_DESKTOPHEIGHT - ymax) / 2 '_MIDDLE does not work?

DIM tri(2) AS point
FOR i = 0 TO 2
    newPoint tri(i)
NEXT
DIM saveP1 AS point
DIM saveP2 AS point
DIM saveP3 AS point
saveP1 = tri(0): saveP2 = tri(1): saveP3 = tri(2)
dmode = 0: nT = 50
resetPlasma
WHILE 1
    CLS , 0
    cN = cN - nT
    tri(0) = saveP1: tri(1) = saveP2: tri(2) = saveP3
    FOR i = 0 TO 2
        updatePoint tri(i)
    NEXT
    saveP1 = tri(0): saveP2 = tri(1): saveP3 = tri(2)
    FOR j = 1 TO nT
        FOR i = 0 TO 2
            updatePoint tri(i)
        NEXT
        changePlasma
        FOR i = 0 TO 2
            LINE (tri(i).x, tri(i).y)-(tri((i + 1) MOD 3).x, tri((i + 1) MOD 3).y)
        NEXT
        IF dmode THEN
            FOR i = 0 TO 2
                LINE (xmax - tri(i).x, ymax - tri(i).y)-(xmax - tri((i + 1) MOD 3).x, ymax - tri((i + 1) MOD 3).y)
            NEXT
        END IF
    NEXT
    _DISPLAY
    k$ = INKEY$
    IF k$ = " " THEN
        resetPlasma
    ELSEIF k$ = "d" THEN
        dmode = NOT dmode
    ELSEIF k$ = "m" THEN
        nT = nT + 1: IF nT > 500 THEN nT = 500
    ELSEIF k$ = "l" THEN
        nT = nT - 1: IF nT < 1 THEN nT = 1
    END IF
    _LIMIT 10
WEND

SUB newPoint (p AS point)
    p.x = RND * xmax
    p.y = RND * ymax
    p.dx = (RND * 10 + 1) * rdir
    p.dy = (RND * 6 + 1) * rdir
END SUB

SUB updatePoint (p AS point)
    IF p.x + p.dx < 0 THEN p.dx = p.dx * -1
    IF p.y + p.dy < 0 THEN p.dy = p.dy * -1
    IF p.x + p.dx > xmax THEN p.dx = p.dx * -1
    IF p.y + p.dy > ymax THEN p.dy = p.dy * -1
    p.x = p.x + p.dx
    p.y = p.y + p.dy
END SUB

SUB changePlasma ()
    cN = cN + 1
    COLOR _RGB(127 + 127 * SIN(pR * .1 * cN), 127 + 127 * SIN(pG * .1 * cN), 127 + 127 * SIN(pB * .1 * cN))
END SUB

SUB resetPlasma ()
    pR = RND ^ 2: pG = RND ^ 2: pB = RND ^ 2
END SUB

FUNCTION rdir% ()
    IF RND < .5 THEN rdir% = -1 ELSE rdir% = 1
END FUNCTION



Maybe you guys have a favorite cloned from the past?

9
Code and examples / Modern Sun Dial
« on: 01. September 2017, 23:04:06 »
I may have learned how to draw the landscape at BP.org, maybe a mod Aurel's code? It's been awhile!

Code: [Select]
'Sunburst 3.bas for QB64 fork (B+=MGA) 2017-09-01
'spiral rays anyone?  throw in the kitchen clock too...

RANDOMIZE TIMER
CONST xmax = 800
CONST ymax = 600
COMMON SHARED cN, pR, pG
SCREEN _NEWIMAGE(xmax, ymax, 32)
_TITLE "Modern Sun Dial by bplus, press spacebar for new view"

'set working variables
midx = xmax / 2
cN = 1
horizon = ymax / 2
maxd = ((xmax - midx) ^ 2 + (ymax - horizon) ^ 2) ^ .5
switch = -1
WHILE 1
    land& = _NEWIMAGE(xmax, ymax, 32)
    _DEST land&
    drawLandscape
    _DEST 0
    switch = NOT switch
    WHILE 1
        CLS
        IF _KEYHIT = 32 THEN EXIT WHILE
        resetPlasma
        _PUTIMAGE , land&, 0
        IF switch THEN
            FOR a = 0 TO _PI(2) STEP _PI(1 / 36)
                IF a = 0 THEN
                    lastx = midx + maxd * COS(a)
                    lasty = horizon + maxd * SIN(a)
                ELSE
                    x1 = midx + maxd * COS(a)
                    y1 = horizon + maxd * SIN(a)
                    changePlasma
                    filltri midx, horizon, lastx, lasty, x1, y1
                    lastx = x1: lasty = y1
                END IF
            NEXT
        END IF
        radius = 0: angle = sangle
        WHILE radius < 400
            x = COS(angle) * radius
            y = SIN(angle) * radius
            r2 = (x ^ 2 + y ^ 2) ^ .5
            size = 4 * r2 ^ .25
            angle = angle - .4
            radius = radius + 2
            COLOR _RGBA(200 + RND * 55, 255, 0, 30)
            sx = midx + 5 * COS(angle + _PI(1 / 2))
            sy = horizon + 5 * SIN(angle + _PI(1 / 2))
            sx1 = midx + 5 * COS(angle - _PI(1 / 2))
            sy1 = horizon + 5 * SIN(angle - _PI(1 / 2))
            filltri sx, sy, sx1, sy1, midx + x, horizon + y
        WEND
        sangle = sangle + _PI(1 / 18)
        IF switch THEN
            FOR r = 25 TO 0 STEP -1
                COLOR _RGBA(255, 255, 205, (25 - r) ^ 2 / 2.45)
                fillcirc midx, horizon, r
            NEXT
        END IF

        now$ = TIME$
        min = VAL(MID$(now$, 4, 2)) / 60
        h = VAL(MID$(now$, 1, 2)) + min
        IF h > 12 THEN h = h - 12
        hourA = h * _PI(1 / 6) - _PI(1 / 2)
        minA = min * _PI(2) - _PI(1 / 2)

        COLOR _RGBA(255, 255, 255, 48)
        sx = midx + 5 * COS(hourA + _PI(1 / 2))
        sy = horizon + 5 * SIN(hourA + _PI(1 / 2))
        sx1 = midx + 5 * COS(hourA - _PI(1 / 2))
        sy1 = horizon + 5 * SIN(hourA - _PI(1 / 2))
        filltri sx, sy, sx1, sy1, midx + 150 * COS(hourA), horizon + 150 * SIN(hourA)


        sx = midx + 5 * COS(minA + _PI(1 / 2))
        sy = horizon + 5 * SIN(minA + _PI(1 / 2))
        sx1 = midx + 5 * COS(minA - _PI(1 / 2))
        sy1 = horizon + 5 * SIN(minA - _PI(1 / 2))
        filltri sx, sy, sx1, sy1, midx + 250 * COS(minA), horizon + 250 * SIN(minA)

        _DISPLAY
        _LIMIT 1
    WEND
WEND

SUB changePlasma ()
    cN = cN + 1
    COLOR _RGBA(200 + 56 * SIN(pR * cN), 200 + 56 * SIN(pG * cN), 128, RND * 32)
END SUB

SUB resetPlasma ()
    pR = RND ^ 2: pG = RND ^ 2
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 SUB

FUNCTION rand% (lo%, hi%)
    rand% = (RND * (hi% - lo% + 1)) \ 1 + lo%
END FUNCTION

'Steve McNeil's  copied from his forum   note: Radius is too common a name
SUB fillcirc (CX AS LONG, CY AS LONG, R AS LONG)
    DIM subRadius AS LONG, RadiusError AS LONG
    DIM X AS LONG, Y AS LONG

    subRadius = ABS(R)
    RadiusError = -subRadius
    X = subRadius
    Y = 0

    IF subRadius = 0 THEN PSET (CX, CY): EXIT SUB

    ' Draw the middle span here so we don't draw it twice in the main loop,
    ' which would be a problem with blending turned on.
    LINE (CX - X, CY)-(CX + X, CY), , BF

    WHILE X > Y
        RadiusError = RadiusError + Y * 2 + 1
        IF RadiusError >= 0 THEN
            IF X <> Y + 1 THEN
                LINE (CX - Y, CY - X)-(CX + Y, CY - X), , BF
                LINE (CX - Y, CY + X)-(CX + Y, CY + X), , BF
            END IF
            X = X - 1
            RadiusError = RadiusError - X * 2
        END IF
        Y = Y + 1
        LINE (CX - X, CY - Y)-(CX + X, CY - Y), , BF
        LINE (CX - X, CY + Y)-(CX + X, CY + Y), , BF
    WEND
END SUB

'Andy Amaya's triangle fill modified for QB64
SUB filltri (xx1, yy1, xx2, yy2, xx3, yy3)
    'make copies before swapping
    x1 = xx1: y1 = yy1: x2 = xx2: y2 = yy2: x3 = xx3: y3 = yy3

    'triangle coordinates must be ordered: where x1 < x2 < x3
    IF x2 < x1 THEN SWAP x1, x2: SWAP y1, y2
    IF x3 < x1 THEN SWAP x1, x3: SWAP y1, y3
    IF x3 < x2 THEN SWAP x2, x3: SWAP y2, y3
    IF x1 <> x3 THEN slope1 = (y3 - y1) / (x3 - x1)

    'draw the first half of the triangle
    length = x2 - x1
    IF length <> 0 THEN
        slope2 = (y2 - y1) / length
        FOR x = 0 TO length
            LINE (INT(x + x1), INT(x * slope1 + y1))-(INT(x + x1), INT(x * slope2 + y1))
            lastx% = INT(x + x1)
        NEXT
    END IF

    'draw the second half of the triangle
    y = length * slope1 + y1: length = x3 - x2
    IF length <> 0 THEN
        slope3 = (y3 - y2) / length
        FOR x = 0 TO length
            IF INT(x + x2) <> lastx% THEN
                LINE (INT(x + x2), INT(x * slope1 + y))-(INT(x + x2), INT(x * slope3 + y2))
            END IF
        NEXT
    END IF
END SUB

SUB drawLandscape
    'the sky
    FOR i = 0 TO ymax
        midInk 50, 25, 128, 100, 200, 255, i / ymax
        LINE (0, i)-(xmax, i)
    NEXT
    'the land
    startH = ymax - 200
    rr = 70: gg = 70: bb = 90
    FOR mountain = 1 TO 6
        Xright = 0
        y = startH
        WHILE Xright < xmax
            ' upDown = local up / down over range, change along Y
            ' range = how far up / down, along X
            upDown = (RND * .8 - .35) * (mountain * .5)
            range = Xright + rand%(15, 25) * 2.5 / mountain
            lastx = Xright - 1
            FOR X = Xright TO range
                y = y + upDown
                COLOR _RGB(rr, gg, bb)
                LINE (lastx, y)-(X, ymax), , BF 'just lines weren't filling right
                lastx = X
            NEXT
            Xright = range
        WEND
        rr = rand%(rr - 15, rr): gg = rand%(gg - 15, gg): bb = rand%(bb - 25, bb)
        IF rr < 0 THEN rr = 0
        IF gg < 0 THEN gg = 0
        IF bb < 0 THEN bb = 0
        startH = startH + rand%(5, 20)
    NEXT
END SUB


10
Code and examples / Pentacle Flux Capacitor #3, "Dancing Man"
« on: 25. August 2017, 21:04:27 »
Code: [Select]
' Pentacle Flux Capacitor #3.bas SmallBASIC 0.12.9 (B+=MGA) 2017-08-25
' based on mods made in Just Basic version

' Pentacle Flux Capacitor 2.bas SmallBASIC 0.12.9 (B+=MGA) 2017-08-23
'Pentacle Flux Capacitor 2.bas for QB64 fork 2017-08-23
'translated from: Pentacle Flux Capacitor 2.txt for JB (B+=MGA) 2017-08-23

'Some dancing music for the Dancing figure

'Electric Light Orchestra (ELO) It's a Livin' Thing...
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'  https://www.youtube.com/watch?v=i2d45tOgBl0&index=1&list=RDi2d45tOgBl0
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

RANDOMIZE TIMER
'COMMON SHARED xc, yc, dist, tp(), tp2()
xc = xmax / 2
yc = ymax / 2
DIM tp(4, 1), tp2(4, 1)
drawPFC
PFC = Image(0, 0, xmax, ymax)
while 1
  cls
  PFC.show(0, 0, , 20) ' use image transparency
  color rgb(rand(100, 255), rand(100, 255), rand(200, 255))
  Lightning xc, yc - 90, xc, yc + 10, 135
  FOR i = 0 TO 4
    xe = tp2(i, 0)
    ye = tp2(i, 1)
    d = rand(.1 * dist, .7 * dist)
    SELECT CASE i
    CASE 0
      Lightning xc, yc - 90, xe, ye, .65*d
      Lightning xc, yc - 90, xe, ye, .65*d
    CASE 1, 4
      Lightning xc, yc - 70, xe, ye, d
    CASE 2, 3
      Lightning xc, yc + 10, xe, ye, d
    END SELECT
  NEXT
  Showpage
  delay 30
WEND

SUB drawPFC
  local pRadius, cRadius, a3, r, ao, a, rr, i, xx, yy, dGray, dis, pnt, midx, midy
  'keep global tp(), tp2(), xc, yc, dist
  '3 main points for array tp()
  pRadius = 40: cRadius = 1.5 * pRadius
  a3 = PI * (2 / 5): r = ymax / 2 - cRadius - 20
  ao = PI* (-1 / 2): a = ao
  FOR rr = ymax/2-20 TO 0 STEP -1
    midInk 0, 0, 0, 128, 0, 0, rr / r
    Circle xc, yc, rr filled
  NEXT
  FOR i = 0 TO 4
    tp(i, 0) = xc + r * COS(a)
    tp(i, 1) = yc + r * SIN(a)
    FOR rr = cRadius TO pRadius STEP -1
      COLOR RGB((rr - pRadius) /(cRadius - pRadius) * 255 * (cRadius - rr + pRadius) / cRadius, 0, 0)
      xx = tp(i, 0): yy = tp(i, 1)
      Circle xx, yy, rr filled
    NEXT
    a = a + a3
  NEXT
  xx = tp(0, 0): yy = tp(0, 1)
  dist = distance(xx, yy, xc, yc) 'global
  FOR pnt = 0 TO 4
    FOR dis = 0 TO .5 * dist STEP 10
      dGray = 255 * dis / dist
      xx = tp(pnt, 0): yy = tp(pnt, 1)
      midpoint xx, yy, xc, yc, dis / dist, midx, midy
      FOR r = pRadius * (dist - dis) / dist TO 0 STEP -1
        midInk dGray, dGray, dGray, 255, 255, 255, (pRadius - r) / pRadius
        Circle midx, midy, r filled
      NEXT
    NEXT
    tp2(pnt, 0) = midx
    tp2(pnt, 1) = midy
  NEXT
END SUB

SUB Lightning (x1, y1, x2, y2, d)
  local mx, my
  IF d < 5 THEN
    LINE x1, y1, x2, y2
  ELSE
    mx = (x2 + x1) / 2
    my = (y2 + y1) / 2
    mx = mx + -.5 * RND * d * .4 * rand(-2, 2)
    my = my + -.5 * RND * d * .4 * rand(-2, 2)
    Lightning x1, y1, mx, my, d / 2
    Lightning x2, y2, mx, my, d / 2
  END IF
END SUB

SUB midpoint (x1, y1, x2, y2, fraction, byref midx, byref midy)
  midx = (x2 - x1) * fraction + x1
  midy = (y2 - y1) * fraction + y1
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 SUB

FUNC distance(x1, y1, x2, y2)
  distance = ((x1 - x2) ^ 2 + (y1 - y2) ^ 2) ^ .5
END

FUNC rand(lo, hi)
  rand = INT(RND * (hi - lo + 1)) + lo
END


11
Offtopic / ProBoards
« on: 12. August 2017, 18:34:28 »
Literally in your face for using an ad blocker!

http://qb64.freeforums.net/thread/66/
(Dang! you have to be a member there too for attached materials.)

Is that what a pro should do?

12
Code: [Select]
'BF in QB.bas for SmallBASIC 0.12.9 (B+=MGA) 2017-07-22
' I just translated some QB code from Rosetta to SmallBASIC
' and tested a couple of programs Hello World, Goodbye World
' count down also found at Rosetta Code.

CLS
memsize = 20000
instChars = "+-<>.,[]" 'valid characters
ptr = 0 'memory pointer
source = ""
INPUT "BF Filename (if blank will use lineput for program) ... "; filename
IF filename = "" THEN
  ? "Please enter the BF program line to intepret."
  LINEINPUT source
ELSE
  OPEN filename FOR INPUT AS #1
  repeat
    LINEINPUT #1, FLINE
    source = source + FLINE 
  UNTIL EOF(1)
  close #1
END IF
if len(source) < 1 then
  ? "No source code to BF."
  pause
  stop
'else
'  ? source
end if

'let's clean the code up, check bracket balance
bktCnt = 0
code = ""
FOR i = 1 TO LEN(source)
  char = MID(source, i, 1)
  'check to see if this is a valid instruction character
  IF INSTR(instChars, char) THEN
    code = code + char
    'count brackets
    IF char = "[" THEN bktCnt = bktCnt + 1
    IF char = "]" THEN bktCnt = bktCnt - 1
  END IF
NEXT

IF bktCnt THEN 'mismatched brackets
  PRINT "Uneven brackets"
  pause
  stop
else
  ? "Code: ";code
END IF
'
DIM memory(memsize)
inLine = "" 'input buffer
FOR i = 1 TO LEN(code) 'loop through the code
  instruction = MID(code, i, 1) 'get the instruction we're on
  SELECT CASE instruction
  CASE "+"
    memory(ptr) = memory(ptr) + 1
  CASE "-"
    memory(ptr) = memory(ptr) - 1
  CASE "."
    PRINT CHR(memory(ptr));
  CASE ","
    IF inLine = "" THEN LINEINPUT inLine 'buffer input
    inChar = LEFT(inLine, 1) 'take the first char off the buffer
    inLine = MID(inLine, 2) 'delete it from the buffer
    memory(ptr) = ASC(inChar) 'use it
  CASE ">"
    ptr = ptr + 1
    IF ptr > 20000 THEN
      PRINT "Memory pointer out of range"
      pause
      stop
    END IF
  CASE "<"
    ptr = ptr - 1
    IF ptr < 0 THEN
      PRINT "Memory pointer out of range"
      pause
      stop
    END IF
  CASE "["
    IF memory(ptr) = 0 THEN
      bktCnt = 1 'count the bracket we're on
      i = i + 1 'move the code pointer to the next char
      WHILE bktCnt <> 0
        'count nested loops till we find the matching one
        IF MID(code, i, 1) = "]" THEN bktCnt = bktCnt - 1
        IF MID(code, i, 1) = "[" THEN bktCnt = bktCnt + 1
        i = i + 1 'search forward
      WEND
    END IF
  CASE "]"
    IF memory(ptr) <> 0 THEN
      bktCnt = -1'count the bracket we're on
      i = i - 1'move the code pointer back a char
      WHILE bktCnt <> 0
        'count nested loops till we fine the matching one
        IF MID(code, i, 1) = "]" THEN bktCnt = bktCnt - 1
        IF MID(code, i, 1) = "[" THEN bktCnt = bktCnt + 1
        i = i - 1 'search backwards
      WEND
    END IF
  END SELECT
NEXT
?:? "done"
pause


Feel free to change memsize!
bf count down.txt
++++++++++++++++++++++++++++++++[>+>+<<-]>>+++++++++++++++++++++++++<<++++++++++[>>.-<.<-]

bf goodbye.txt
++++++++++[>+>+++>++++>+++++++>++++++++>+++++++++>++++++++++>+++++++++++>++++++++++++<<<<<<<<<-]>>>>+.>>>>+..<.<++++++++.>>>+.<<+.<<<<++++.<++.>>>+++++++.>>>.+++.<+++++++.--------.<<<<<+.<+++.---.

bf hello.txt
++++++++[>++++[>++>+++>+++>+<<<<-]>+>->+>>+[<]<-]>>.>>---.+++++++..+++.>.<<-.>.+++.------.--------.>+.>++.+++.

13
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

14
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

15
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.

Pages: [1] 2 3 ... 6