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


2
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


3
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?

4
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
++++++++[>++++[>++>+++>+++>+<<<<-]>+>->+>>+[<]<-]>>.>>---.+++++++..+++.>.<<-.>.+++.------.--------.>+.>++.+++.

5
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

6
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

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

8
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


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


10
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

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

12
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

:)


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

14
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


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

Pages: [1] 2 3 ... 6