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.


Messages - B+

Pages: [1] 2 3 ... 31
1
General questions and discussions / Re: Sudoku
« on: 17. January 2018, 20:54:40 »
And here is my most recent update of the Sudoku Game in SmallBASIC version 0.12.11
This uses not so random hiding of cells and levels of play are decided by how many cells per box to remove ie, 0 would display a solved puzzle, 9 would display a board with 0 clues left; easy, intermediate and difficult would be levels: 4, 5 and 6.

Code: [Select]
' SB1 Sudoku Game.bas SmallBASIC 0.12.11 (B+=MGA) 2018-01-17
' some edits of game posted 2018-01-17, better quit code with level
' more debug code removed

'from: sudoku mod bplus.bas SmallBASIC 0.12.11 (B+=MGA) 2018-01-06
' add whole new makeGrid (maybe faster) and hideCells code (not so random)

'Sudoku Game from SB.bas SmallBASIC 0.12.9 (B+=MGA) 2018-01-04
' fix color at start so can see the grid!
' add solved function!!! and loop around when solved
' removed cell notes, to store in corners

randomize
const TextSize = textwidth("9")
const CellSize = TextSize * 5
const xMinBoard = CellSize
const yMinBoard = CellSize
const xMaxBoard = xMinBoard + 9 * CellSize
const yMaxBoard = yMinBoard + 9 * CellSize
const xMidBoard = xMinBoard + (xMaxBoard - xMinBoard)/2
const yMidBoard = yMinBoard + (yMaxBoard - yMinBoard)/2
const xMinKeyPad = xMinBoard - .5 * CellSize
const xMaxKeyPad = xMinKeyPad + CellSize * 10
const yMinKeyPad = yMaxBoard + 10
const yMaxKeyPad = yMinKeyPad + CellSize

'main loop sets up game puzzle,
'when solved it flashes that fact and then sets up another puzzle
while 1
  'get desired level of difficulty set
  cls
  LOCATE 5, 5: PRINT "Welcome to SB version of Sudoku Game by bplus"
  LOCATE 9, 5: PRINT "To begin, please enter a level of difficulty."
  LOCATE 10, 8: PRINT "A level of 1 will hide 1 cell in every box,"
  LOCATE 12, 14: PRINT "4 will hide 4 in every box."
  LOCATE 14, 9: PRINT "Levels 1 to 3 are good for developing"
  LOCATE 15, 12: PRINT "'flash card' automatic skills."
  LOCATE 17, 9: PRINT "Levels 4, 5 and 6 are easy standard for:"
  LOCATE 18, 5: PRINT "beginner, intermediate, and difficult puzzles."
  LOCATE 22, 12: INPUT "Enter 0 to 9 any else quits "; level
  IF instr("0123456789", level) then level = val(level) else CLS: END
  'test robustness of algo for hiding should work to hiding 9 cells in box! YES!!!
  'globals
  bx = 0 : by = 0  'current highlighted location on board
  key = 1          'current key highlighted on keyPad, key = 0 clears cell
  update = 1       'when to show game board
  dim grid(8,8)    '9x9 board positive values come from puzzle creation
  '0 and negative values are cells blanked out to make puzzle

  makeGrid
  hideCells
  'game loop will continue to respond to mouse clicks until puzzle is solved
  while solved() = 0
    'cls screen display puzzle catch mouse and handle it
    if update then showGrid
    if pen(3) then
      mx = pen(4) : my = pen(5)
      while pen(3)
        mx = pen(4) : my = pen(5)
      wend
      'clicked inside Board
      if xMinBoard <= mx and mx <= xMaxBoard and yMinBoard <= my and my <= yMaxBoard then
        bx = int((mx - xMinBoard)/CellSize) : by = int((my-yMinBoard)/CellSize)
        if grid(bx, by) < 1 then
          if key = 0 then grid(bx, by) = 0 else grid(bx, by) = -key
        fi
        update = 1
      fi
      'clicked inside KeyPad
      if xMinKeyPad <= mx and mx <= xMaxKeyPad and yMinKeyPad <= my and my <= yMaxKeyPad then
        key = int((mx - xMinKeyPad) / CellSize)
        update = 1
      fi
      if xMidBoard - 3 * CellSize <= mx and mx <= xMidBoard + 3 * CellSize then
        if yMaxKeyPad + CellSize <= my and my <= yMaxKeyPad + 2 * CellSize then xit = 1 : exit loop
      fi
    fi
    delay 50  'save fan from running
  wend
  IF xit THEN
    xit = 0
  ELSE
    BEEP
    t = TIMER
    WHILE (TIMER - t < 6)
      showGrid
      DELAY 900
      COLOR 15, 0
      CLS
      at xMidBoard - 7 * TextSize, yMidBoard - .5 * TextSize : ? "Puzzle solved!"
      DELAY 300
    WEND
  END IF
wend

' add solved function
func solved()
  local n, col, row, cell, cellrow, cellcol, found
  solved = 0 'n must be found in every column, row and 3x3 cell
  FOR n = 1 TO 9
    'check columns for n
    FOR col = 0 TO 8
      found = 0
      FOR row = 0 TO 8
        IF abs(grid(col, row)) = n THEN found = 1: EXIT FOR
      NEXT
      IF found = 0 THEN EXIT FUNC
    NEXT
    'check rows for n
    FOR row = 0 TO 8
      found = 0
      FOR col = 0 TO 8
        IF abs(grid(col, row)) = n THEN found = 1: EXIT FOR
      NEXT
      IF found = 0 THEN EXIT FUNC
    NEXT
    'check 3x3 cells for n
    FOR cell = 0 TO 8
      cellcol = cell MOD 3
      cellrow = INT(cell / 3)
      found = 0
      FOR col = 0 TO 2
        FOR row = 0 TO 2
          IF abs(grid(cellcol * 3 + col, cellrow * 3 + row)) = n THEN found = 1: EXIT FOR
        NEXT
        IF found = 1 THEN EXIT FOR
      NEXT
      IF found = 0 THEN EXIT FUNC
    NEXT
  NEXT
  solved = 1
end

' displays the game grid, mainly as Chris with more constants
sub showGrid()
  update = 0 'global calls for this display
  local x, y, i, j, b
  b = rgb(0, 0, 40)
  color 15, b : cls
  locate 1, 21 : ? "Sudoku Level ";level
  rect xMidBoard - 3 * CellSize, yMaxKeyPad + CellSize, xMidBoard + 3 * CellSize, yMaxKeyPad + 2 * CellSize, 12 filled
  at xMidBoard - 2 * TextSize, yMaxKeyPad + CellSize + TextSize + 4
  color 7, 12
  ? "EXIT"
  'draw line segments
  i = xMinBoard
  for x = 0 to 9
    line i,yMinBoard,i,yMaxBoard,13
    i += CellSize
  next x
  j = yMinBoard
  for y = 0 to 9
    line xMinBoard,j,xMaxBoard,j,13
    j += CellSize
  next y
  'draw heavy 3x3 cell borders
  rect xMinBoard+1,yMinBoard+1,xMaxBoard+1,yMaxBoard+1,15
  i = xMinBoard+(CellSize*3)+1
  line i,yMinBoard,i,yMaxBoard,15
  i = xMinBoard+(CellSize*6)+1
  line i,yMinBoard,i,yMaxBoard,15
  j = yMinBoard+(CellSize*3)+1
  line xMinBoard,j,xMaxBoard,j,15
  j = yMinBoard+(CellSize*6)+1
  line xMinBoard,j,xMaxBoard,j,15
  for y = 0 to 8
    for x = 0 to 8
      'highlite?
      if x = bx and y = by then
        color b, 10
        rect xMinBoard+x*CellSize+3, yMinBoard+y*CellSize+3 step CellSize-5, CellSize-5, 10 filled
      else
        if grid(x, y) > 0 then color 9, b else color 7, b
      end if
      if grid(x,y) <> 0 then
        at xMinBoard+(x*CellSize)+(TextSize*2), yMinBoard+(y*CellSize)+TextSize+4
        ? abs(grid(x,y))
      fi
    next
  next
  'show a keypad key with highlite
  i = xMinKeyPad
  for x = 0 to 9
    if x = key then
      rect i+3,yMinKeyPad+3 step CellSize-5, CellSize-5, 10 filled
      color b, 10
    else
      color 11, b
    fi
    line i,yMinKeyPad,i,yMaxKeyPad,7
    at i+(TextSize*2),yMinKeyPad+TextSize+4
    ? x
    i += CellSize
  next
  rect xMinKeyPad, yMinKeyPad, xMaxKeyPad, yMaxKeyPad, 7
end

func loadCell(n, cellBlock)
  local xoff, yoff, xstop, ystop, list, x, y
  local xx, yy, available, i, pointer, cell, r
 
  xoff = 3 * (cellBlock MOD 3): yoff = 3 * INT(cellBlock / 3)
  IF xoff > 0 THEN xstop = xoff - 1 ELSE xstop = 0
  IF yoff > 0 THEN ystop = yoff - 1 ELSE ystop = 0
  'filling the cells in order so all the ones before n are done
  'make a list of free cells in cellblock
  dim list(8)
  for y = 0 to 2  'make list of cells available
    for x = 0 to 2 'find open cell in cellBlock first
      if grid(xoff + x, yoff + y) = 0 then 'open
        bad = 0
        'check rows and columns before this cell block
        for yy = 0 to ystop 'rows
          if grid(xoff + x,  yy) = n  then
            bad = 1
            exit for
          fi
        next
        if bad = 0 then
          for xx = 0 to xstop
            if grid(xx, yoff + y) = n then
              bad = 1
              exit for
            fi
          next
        fi
        if bad = 0 then available++ : list(3*y + x) = 1
      end if
    next
  next
  if available = 0 then
    loadCell = 0
    exit func
  fi
  dim cell(1 to available) : pointer = 1
  for i = 0 to 8
    if list(i) then cell(pointer) = i : pointer ++
  next
  'OK our list has cells available to load, pick one randomly
  if available > 1 then 'shuffle cells
    for i = available to 2 step -1
      r = int(rnd * i) + 1
      swap cell(i), cell(r)
    next
  fi
  'load the first one listed
  grid(xoff + (cell(1) mod 3), yoff + int(cell(1) / 3)) = n
  loadCell = 1
end

sub makeGrid
  local n, cellBlock, i, cnt, startOver, temp, wait
  'this version requires the assistance of loadCell sub routine
  ' debug by stepping through process with showGrid sub
  repeat
    dim grid(8, 8) : startOver = 0
    for n = 1 to 9
      temp = grid : cnt = 0
      repeat
        for i = 1 to 9
          cellBlock = val(mid("013246578", i , 1))
          success = loadCell(n, cellBlock)
          if success = 0 then
            cnt = cnt + 1
            if cnt >= 20 then startOver = 1 : exit for
            grid = temp
            exit for
          fi
        next
        if startOver then exit loop
      until success
      if startOver then exit for
    next
  until startOver = 0
end

sub hideCells
  local copyGrid, success, box, cBase, rBase, m, bx, by, dx, dy, dm, test, r, c, i, cnt
  copyGrid = grid
  while success = 0
    for box = 0 to 8
      cBase = (box mod 3) * 3
      rBase = int(box / 3) * 3
      dx = int(rnd*2) + 1 : dy = int(rnd*2) + 1
      if rnd <.5 then dm = -1 else dm = 1
      bx = int(rnd*3) : by = int(rnd*3)
      for m = 0 to level-1
        grid(cBase + ((bx + m * dx) mod 3) , rBase + (by + m * dy + int(m/3) * dm) mod 3) = 0
      next
    next
    showGrid
    dim test(9)
    for box = 0 to 8
      cBase = (box mod 3) * 3
      rBase = int(box / 3) * 3
      for r = 0 to 2
        for c = 0 to 2
          test(grid(cBase + c, rBase + r)) = 1
        next
      next
    next
    success = 1
    for i = 1 to 9
      if test(i) = 0 then success = 0
    next
    if success = 0 then
      cnt = cnt + 1
      if cnt > 20 then
        success = 1 : beep 'when all numbers aren't there
      else
        grid = copyGrid
      fi
    fi
  wend
end


2
General questions and discussions / Re: Sudoku
« on: 14. January 2018, 15:59:51 »
I am pleased to announce that last night I found the formula / recipe to distribute the hidden cells homogeneously throughout the puzzle grid that guarantees leaving each box row, col with a cell which guarantees each cell and row of the whole grid has a 3 cells not hidden (in the hardest level of play that leaves only 3 cells per box.).

My conjecture is that such an arrangement is most likely to keep a puzzle to the original solution devised at the start (which I will explore when I start playing with Solvers again).

Code: [Select]
' Make #3 Board Test Hiding.bas SmallBASIC 0.12.11 (B+=MGA) 2018-01-12

'from make #2 Board Maker, now test hiding cells
'aha! I have defined levels well for myself at least!

randomize
dim grid(8, 8) 'global access to use between calls to functions using them

while 1
  cls
  'get desired level of difficulty set
  locate 6, 27 : ? "Welcome to the game called Sudoku!"
  locate 7, 20 : ? "To begin, please enter a level of difficulty."
  locate 9, 10 : ? "A level of 1 will hide 1 cell in every box, 4 will hide 4 in every box."
  locate 11, 10 : ? "Levels 1 to 3 are good for developing 'flash card' automatic skills."
  locate 12, 10 : ? "Levels 4, 5 and 6 are your standard but on easy side for:"
  locate 13, 10 : ? "beginner, intermediate, and difficult puzzles."
  locate 15, 10  : input "Enter 1 for very easy up to 6 for very hard! any else quits ";level
  if level < 0 or level > 10 then end
  'test robustness of algo for hiding should work to hiding 9 cells in box! YES!!!

    'test grids have solutions for Sudoku Game
  'while 1
  tCount = 0 : tStartOver = 0
  makeGrid
  showGrid
  ? : ? "Grid solve-able ? answer: ";solved()
  ? "Total cellBlock redo's ";tCount
  ? "      Total StartOvers ";tStartOver
  input "OK press enter to see the Hide...";more
  hideCells
  showGrid
  print "That was level ";level
  input "Press enter for another set, any else quits ";more
  if len(more) then end
wend

sub hideCells
  'global level
  local box, cBase, rBase, m, bx, by, dx, dy, dm
  for box = 0 to 8
    cBase = (box mod 3) * 3
    rBase = int(box / 3) * 3
    bx = int(rnd*3) : by = int(rnd*3)
    dx = int(rnd*2) + 1 : dy = int(rnd*2) + 1
    if rnd <.5 then dm = -1 else dm = 1
    for m = 0 to level-1
      grid(cBase + ((bx + m * dx) mod 3) , rBase + (by + m * dy + int(m/3) * dm) mod 3) = 0
    next
  next
end

'this will either put the number in the grid's cellBlock or return 0 for failure
func loadCell(n, cellBlock)
  local xoff, yoff, xstop, ystop, list, x, y
  local xx, yy, available, i, pointer, cell, r
  local wait

  'grid
  ' 0 1 2  3 4 5  6 7 8
  '
  'cell block numbers
  ' 0 1 2
  ' 3 4 5
  ' 6 7 8

  select case cellBlock
    case 0 : xoff = 0 : yoff = 0 : xstop = 0 : ystop = 0
    case 1 : xoff = 3 : yoff = 0 : xstop = 2 : ystop = 0
    case 2 : xoff = 6 : yoff = 0 : xstop = 5 : ystop = 0

    case 3 : xoff = 0 : yoff = 3 : xstop = 0 : ystop = 2
    case 4 : xoff = 3 : yoff = 3 : xstop = 2 : ystop = 2
    case 5 : xoff = 6 : yoff = 3 : xstop = 5 : ystop = 2

    case 6 : xoff = 0 : yoff = 6 : xstop = 0 : ystop = 5
    case 7 : xoff = 3 : yoff = 6 : xstop = 2 : ystop = 5
    case 8 : xoff = 6 : yoff = 6 : xstop = 5 : ystop = 5
  end select
  'filling the cells in order so all the ones before n are done
  'make a list of free cells in cellblock
  dim list(8)
  for y = 0 to 2  'make list of cells available
    for x = 0 to 2 'find open cell in cellBlock first
      if grid(xoff + x, yoff + y) = 0 then 'open

        bad = 0
        'check rows and columns before this cell block
        for yy = 0 to ystop 'rows
          if grid(xoff + x,  yy) = n  then
            bad = 1
            exit for
          fi
        next
        if bad = 0 then
          for xx = 0 to xstop
            if grid(xx, yoff + y) = n then
              bad = 1
              exit for
            fi
          next
        fi
        if bad = 0 then available++ : list(3*y + x) = 1
      end if

    next
  next

  '? : ? "Number of Cells available ";available
  'for i = 0 to 8 : ? list(i); : next : ?
  'input "OK, press enter... ";wait
  'delay 20

  if available = 0 then
    '? "error: no cells available for: "; n;" in cellBlock ";cellBlock : delay 1500
    loadCell = 0
    exit func
  fi
  dim cell(1 to available) : pointer = 1
  for i = 0 to 8
    if list(i) then cell(pointer) = i : pointer ++
  next

  'OK our list has cells available to load, pick one randomly
  if available > 1 then 'shuffle cells
    for i = available to 2 step -1
      r = int(rnd * i) + 1
      swap cell(i), cell(r)
    next
  fi
  'load the first one listed
  grid(xoff + (cell(1) mod 3), yoff + int(cell(1) / 3)) = n
  loadCell = 1
end

'the master sub for which loadCell function was designed
sub makeGrid
  local n, cellBlock, i, cnt, startOver, temp, wait
  'this version requires the assistance of loadCell sub routine
  ' debug by stepping through process with showGrid sub

  repeat
    dim grid(8, 8) : startOver = 0
    for n = 1 to 9
      temp = grid : cnt = 0
      repeat
        for cellBlock  = 0 to 8
          success = loadCell(n, cellBlock)
          if success = 0 then
            cnt = cnt + 1
            tCount++
            if cnt >= 20 then startOver = 1 : tStartOver++ : exit for
            grid = temp
            exit for
          fi
          'showGrid
          'input  " OK, press enter..."; wait
          'delay 200
        next
        if startOver then exit loop
      until success
      if startOver then exit for
    next
  until startOver = 0
end

sub showGrid
  local r, c
  cls
  for r = 0 to 8
    for c = 0 to 8
      locate int(r/3) + r + 2 , int(c/3) * 2 + (c + 2) * 3,  : ? grid(c, r)
    next
  next
  ?
end

' add solved function
func solved()
  local n, col, row, cell, cellrow, cellcol, found
  solved = 0 'n must be found in every column, row and 3x3 cell
  FOR n = 1 TO 9
    'check columns for n
    FOR col = 0 TO 8
      found = 0
      FOR row = 0 TO 8
        IF abs(grid(col, row)) = n THEN found = 1: EXIT FOR
      NEXT
      IF found = 0 THEN EXIT FUNC
    NEXT
    'check rows for n
    FOR row = 0 TO 8
      found = 0
      FOR col = 0 TO 8
        IF abs(grid(col, row)) = n THEN found = 1: EXIT FOR
      NEXT
      IF found = 0 THEN EXIT FUNC
    NEXT
    'check 3x3 cells for n
    FOR cell = 0 TO 8
      cellcol = cell MOD 3
      cellrow = INT(cell / 3)
      found = 0
      FOR col = 0 TO 2
        FOR row = 0 TO 2
          IF abs(grid(cellcol * 3 + col, cellrow * 3 + row)) = n THEN found = 1: EXIT FOR
        NEXT
        IF found = 1 THEN EXIT FOR
      NEXT
      IF found = 0 THEN EXIT FUNC
    NEXT
  NEXT
  solved = 1
end


4 days to get a dozen lines of code, sheeze!

3
General questions and discussions / Re: Sudoku
« on: 11. January 2018, 18:54:48 »
Hi Rick,

Good to see you are still alive and kicking!

Yes! I have started with 6 base board solutions and shuffled columns and rows within boxes and then shuffled vertical or horizontal blocks of boxes and then randomly changed all the numbers as one does with code a = s, b = y, c = f, ....

This leaves a board who's solution is too easy to find because permutation of the same 3 sets of numbers are repeated in every box eg

one box is
148
923
576

so all the other boxes are variations

481
392
657

814
239
765

all you need to see is 18x   and you know x = 4
all you need to see is x4y   and you know x or y = 8 and the other is 4

This is for every box in the puzzle...

hmm... but maybe if you had a better, more random puzzle to start with... yes that would be better!

4
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? ;-))

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

6
Offtopic / Re: The Joyful Programmer's Forum
« on: 25. December 2017, 17:04:56 »
Hey Aurel!

That's a pretty legit list of liabilities but don't forget assets:
+ Unlimited posting of attachments including exe's with public access, no membership required to read posts and download.
+ Talk of other PL's encouraged not forbidden or taboo or frowned upon.
+ I think, Walter really believes in hobby programming with learning and participates often in forum, welcoming new members (when they post).

I think QB64 as base PL (flavor of Basic) provides a common ground for members for strong overlapping interests.
For me, QB64 is nice complement to SmallBASIC. (For some reason FreeBasic did not "take", I think I needed a forum like Walter's for shallow end of pool in learning that flavor PL by comparing and contrasting with SB.)

I am finding past posts at forums easier than in my own files, plus it's easier to remember background setting, state of mind when I was creating code with the help of others comments and ideas. Ha, sometimes it's shocking the difference between my memory and what was written.
It is becoming a better backup system than my own monthly thing.

So for final plus:
+ Multi-forum participation provides backup for personal files and documentation (sort of) AND covers the case we loose a forum like BP.org or one goes down like The Joyful Programmer or QB64.net


7
Offtopic / Re: The Joyful Programmer's Forum
« on: 25. December 2017, 00:58:07 »
Hi Cybermonkey,

Forum Pioneer: Walter, THE Joyful Programmer, is at it again with forum updates and experiments.

He put up a warning a day or two ago, but I doubt many saw it. It is possible an experiment went bad, he is changing site name to
http://qb64.thejoyfulprogrammer.com/showthread.php?tid=1195&pid=5661&rndtime=15141382611416121033#pid5661

notice the site name is different, more explanation in link, if you missed it.

I am glad to know I am not the only one not able to Log-in.

Merry Christmas!

8
Offtopic / Re: Merry Christmas !
« on: 25. December 2017, 00:53:10 »
 ;D  Well I guess it pays to log-in once and awhile!

Merry Christmas Aurel!

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

10
Code and examples / Re: PhotoMapping
« on: 22. December 2017, 01:06:34 »
To All, Merry Christmas!

Galileo, Nice graphic effect. :)

11
Code and examples / Re: Anagrams
« on: 13. December 2017, 07:06:09 »
Steve McNeil has Anagrams running very fast with QB64.

3rd page @ http://www.qb64.net/forum/index.php?topic=14622.30

12
Hi D, any progress?

13
Code and examples / Re: Anagrams
« on: 08. December 2017, 22:39:41 »
Criminy!
Code: [Select]
_TITLE "Rosetta Code Anagrams: mod #4.1 by bplus 2017-12-08"
'anagrams4_1 oh hey integers and other exact types
'anagrams4 the word coding has also been shortened again!
'GET file in one gulp = buf$ and then find words
'Multiple IF's reduced to IF THEN ELSEIF ELSE where ever possible.
'No calls to subs or functions except the recursive QSort routine.
'FOR... NEXT replaced with WHILE... WEND
DEFINT A-Z
DIM SHARED w$(25100)
index = 0: t! = TIMER
OPEN "unixdict.txt" FOR BINARY AS #1
fl& = LOF(1): buf$ = SPACE$(fl&)
GET #1, , buf$
CLOSE #1
p& = 1
WHILE p& < fl&
    np& = INSTR(p&, buf$, CHR$(10))
    wd$ = MID$(buf$, p&, np& - p&)
    IF LEN(wd$) > 2 THEN
        REDIM a(26): flag = 0: i = 1
        WHILE i <= LEN(wd$)
            ac = ASC(MID$(wd$, i, 1)) - 96
            IF 0 < ac AND ac < 27 THEN a(ac) = a(ac) + 1 ELSE flag = 1: EXIT WHILE
            i = i + 1
        WEND
        'don't code and store a word unless all letters, no digits or apostrophes
        IF flag = 0 THEN
            b$ = "": i = 1
            WHILE i < 27
                IF a(i) <> 0 THEN b$ = b$ + STRING$(a(i), CHR$(96 + i))
                i = i + 1
            WEND
            index = index + 1
            w$(index) = b$ + "!" + wd$
        END IF
    END IF
    IF np& THEN p& = np& + 1 ELSE p& = fl&
WEND
QSort 0, index
flag = 0
WHILE i < index
    IF MID$(w$(i), 1, INSTR(w$(i), "!") - 1) <> MID$(w$(i + 1), 1, INSTR(w$(i + 1), "!") - 1) THEN
        IF cnt > 4 THEN PRINT b$
        cnt = 0: b$ = "": flag = 0
    ELSEIF flag THEN
        b$ = b$ + ", " + MID$(w$(i + 1), INSTR(w$(i + 1), "!") + 1): cnt = cnt + 1
    ELSE
        b$ = MID$(w$(i), INSTR(w$(i), "!") + 1) + ", " + MID$(w$(i + 1), INSTR(w$(i + 1), "!") + 1): cnt = 2: flag = -1
    END IF
    i = i + 1
WEND
PRINT "Done !!! "; TIMER - t!

SUB QSort (Start, Finish)
    i = Start: j = Finish: x$ = w$(INT((i + j) / 2))
    WHILE i <= j
        WHILE w$(i) < x$: i = i + 1: WEND
        WHILE w$(j) > x$: j = j - 1: WEND
        IF i <= j THEN
            a$ = w$(i): w$(i) = w$(j): w$(j) = a$
            i = i + 1: j = j - 1
        END IF
    WEND
    IF j > Start THEN QSort Start, j
    IF i < Finish THEN QSort i, Finish
END SUB

14
Code and examples / Re: Anagrams
« on: 08. December 2017, 03:46:10 »
OK well under a sec! and pretending not to know there aren't any large 3 letter word sets (with 5 or 6 permutations that are words), ie taking the time to test all words that could have 4 or more anagrams.
Code: [Select]
_TITLE "Rosetta Code Anagrams: mod #4 by bplus 2017-12-07"
'anagrams4 the word coding has also been shortened again!
'GET file in one gulp = buf$ and then find words
'Multiple IF's reduced to IF THEN ELSEIF ELSE where ever possible.
'No calls to subs or functions except the recursive QSort routine.
'FOR... NEXT replaced with WHILE... WEND
DIM SHARED w$(25100)
index = 0: t = TIMER
OPEN "unixdict.txt" FOR BINARY AS #1
fl = LOF(1): buf$ = SPACE$(fl)
GET #1, , buf$
CLOSE #1
p = 1
WHILE p < fl
    np = INSTR(p, buf$, CHR$(10))
    wd$ = MID$(buf$, p, np - p)
    IF LEN(wd$) > 2 THEN
        REDIM a(26): flag = 0: i = 1
        WHILE i <= LEN(wd$)
            ac = ASC(MID$(wd$, i, 1)) - 96
            IF 0 < ac AND ac < 27 THEN a(ac) = a(ac) + 1 ELSE flag = 1: EXIT WHILE
            i = i + 1
        WEND
        'don't code and store a word unless all letters, no digits or apostrophes
        IF flag = 0 THEN
            b$ = "": i = 1
            WHILE i < 27
                IF a(i) <> 0 THEN b$ = b$ + STRING$(a(i), CHR$(96 + i))
                i = i + 1
            WEND
            index = index + 1
            w$(index) = b$ + "!" + wd$
        END IF
    END IF
    IF np THEN p = np + 1 ELSE p = fl
WEND
QSort 0, index
flag = 0
WHILE i < index
    IF MID$(w$(i), 1, INSTR(w$(i), "!") - 1) <> MID$(w$(i + 1), 1, INSTR(w$(i + 1), "!") - 1) THEN
        IF cnt > 4 THEN PRINT b$
        cnt = 0: b$ = "": flag = 0
    ELSEIF flag THEN
        b$ = b$ + ", " + MID$(w$(i + 1), INSTR(w$(i + 1), "!") + 1): cnt = cnt + 1
    ELSE
        b$ = MID$(w$(i), INSTR(w$(i), "!") + 1) + ", " + MID$(w$(i + 1), INSTR(w$(i + 1), "!") + 1): cnt = 2: flag = -1
    END IF
    i = i + 1
WEND
PRINT "Done !!! "; TIMER - t

SUB QSort (Start, Finish)
    i = Start: j = Finish: x$ = w$(INT((i + j) / 2))
    WHILE i <= j
        WHILE w$(i) < x$: i = i + 1: WEND
        WHILE w$(j) > x$: j = j - 1: WEND
        IF i <= j THEN
            a$ = w$(i): w$(i) = w$(j): w$(j) = a$
            i = i + 1: j = j - 1
        END IF
    WEND
    IF j > Start THEN QSort Start, j
    IF i < Finish THEN QSort i, Finish
END SUB

15
Code and examples / Re: Anagrams
« on: 07. December 2017, 02:28:43 »
Quote
It's only a matter of time before someone notices a particular cheat and gets sufficiently excited with righteous anger to motivate the site moderators to ban the intoxicated cheater applicant. ;)

 ::) Oh good lord!

Shaved some time of my last best:
Code: [Select]
_TITLE "Searching for large sets of Anagrams with same characters, loading data..."
'anagrams3 is starting to adapt to data,
'there are no 5 set anagrams of 3 letters nor of digits or apostrophes
'so they are not added to the word list to sort.
'The word coding has also been shortened.
'Multiple IF's reduced to IF THEN ELSEIF ELSE where ever possible.
'No calls to subs or functions except the recursive QSort routine.
DIM SHARED w$(24200)
index = 0: t = TIMER
OPEN "unixdict.txt" FOR INPUT AS #1
WHILE NOT (EOF(1))
    INPUT #1, wd$
    'don't bother with 3 letter words even though possibe to have 6 permutations there are none of 5 or more
    IF LEN(wd$) > 3 THEN
        REDIM a(26): flag = 0
        FOR i = 1 TO LEN(wd$)
            ac = ASC(MID$(wd$, i, 1)) - 96
            IF 0 < ac AND ac < 27 THEN a(ac) = a(ac) + 1 ELSE flag = 1: EXIT FOR
        NEXT
        'don't code and store a word unless all letters, no digits or apostrophes
        IF flag = 0 THEN
            b$ = "": zc = 0
            'zc zero counts replaces strings of 0's with a letter according to how many in string
            'this shortens the strings considerably before the sort
            FOR i = 1 TO 26
                IF a(i) = 0 THEN
                    zc = zc + 1
                ELSE
                    IF zc > 0 THEN b$ = b$ + CHR$(96 + zc): zc = 0
                    b$ = b$ + LTRIM$(STR$(a(i)))
                END IF
            NEXT
            index = index + 1
            w$(index) = b$ + "!" + wd$
        END IF
    END IF
WEND
CLOSE #1
QSort 0, index
flag = 0
FOR i = 1 TO index - 1
    IF MID$(w$(i), 1, INSTR(w$(i), "!") - 1) <> MID$(w$(i + 1), 1, INSTR(w$(i + 1), "!") - 1) THEN
        IF cnt > 4 THEN PRINT b$
        cnt = 0: b$ = "": flag = 0
    ELSEIF flag THEN
        b$ = b$ + ", " + MID$(w$(i + 1), INSTR(w$(i + 1), "!") + 1): cnt = cnt + 1
    ELSE
        b$ = MID$(w$(i), INSTR(w$(i), "!") + 1) + ", " + MID$(w$(i + 1), INSTR(w$(i + 1), "!") + 1): cnt = 2: flag = -1
    END IF
NEXT
PRINT "Done !!! "; TIMER - t

SUB QSort (Start, Finish)
    i = Start: j = Finish: x$ = w$(INT((i + j) / 2))
    WHILE i <= j
        WHILE w$(i) < x$: i = i + 1: WEND
        WHILE w$(j) > x$: j = j - 1: WEND
        IF i <= j THEN
            a$ = w$(i): w$(i) = w$(j): w$(j) = a$
            i = i + 1: j = j - 1
        END IF
    WEND
    IF j > Start THEN QSort Start, j
    IF i < Finish THEN QSort i, Finish
END SUB

Oh hey! the new word coding has the list in alpha order again!  8)

Pages: [1] 2 3 ... 31