Board Logo
« Search Results »

Welcome Guest. Please Login or Register.
Jan 21st, 2018, 4:30pm


Conforums Terms of Service | Membership Rules | Home | Search | Recent Posts | Notification | Format Your Message | Installation FAQ


Search Results

Total results: 10


 1   JB Programming Discussions / Re: Sudoku  on: Today at 1:33pm
Started by bplus | Post by bplus
Sudoku Solver starter:
Code:
'Sudoku Solve Experiment.bas for JB v2.0 b 2018-01-21 (B+=MGA)
' experiment with another Solver after reading Sudoku.org.uk discussion with code in JS

'recursive Solver? who needs that? ;-))  I do! For Solvers that handle ambiguity.

'A solver starter... Level 4 OK, level 5 very shaky, level 6 doubt it!

'globals
global level
dim grid(8, 8), copy(8, 8), copy2(8, 8)

lastPuzzle = 3  '3 puzzles to read through data
while 1
    scan
    puzzle = puzzle + 1
    if puzzle <= lastPuzzle then 'read in puzzle
        read puzzleSource$
        for row = 0 to 8
            for col = 0 to 8
                read digit
                grid(col, row) = digit
                copy2(col, row) = digit
            next
        next
    else  'make up a puzzle now!
        cls
        call cp 5, "*** Puzzle Maker for Sudoku ***"
        call cp 7, "To begin, please enter a level of difficulty."
        call cp 9, "A level of 1 will hide 1 cell in every box,"
        call cp 10, "4 will hide 4 in every box."
        call cp 12, "Levels 1 to 3 are good for developing"
        call cp 13, "'flash card' automatic skills."
        call cp 15, "Levels 4, 5 and 6 are easy standard for:"
        call cp 16, "beginner, intermediate, and difficult puzzles."
        call cp 18, "Enter a level 0 to 9, any other to quits. "
        locate 40, 19 : input " "; quit$
        if quit$ <> "" then
            if instr("0123456789", quit$) then level = val(quit$) else print : print space$(35);"Goodbye!" : end
        else
            print : print space$(35);"Goodbye!" : end
        end if
        puzzleSource$ = "Puzzle #";puzzle;" provided hot off the press by bplus code for puzzle making!."
        call makeGrid
        call hideCells
        call copyGrid2
    end if

    'attempt to solve it
    result = CompleteGrid()
    if 0 < result and result < 65 then
        s$ = "solved in ";result;" rounds!"
    else
        if 0 > result then
            s$ = "Puzzle failed to change after round ";-1 * result;"."
        else
            s$ = "Went full ";result - 1;" rounds and still incomplete! (not likely to see this report)"
        end if
    end if

    'show off
    cls
    print puzzleSource$
    for row = 0 to 8  'how far did we get?
        for col = 0 to 8
            locate col * 3 + 1, row + 3  : print right$("   ";copy2(col, row), 3);
            locate col * 3 + 30, row + 3 : print right$("   ";grid(col, row), 3);
        next
        print
    next
    print : print "CompleteGrid function reports: ";s$
    print
    input "Press enter for next puzzle."; LookSee$
wend

' Puzzle Making  ================================================

function loadBox(n, box)
    'this one uses aok function to help load boxes

    xoff = 3 * (box mod 3) : yoff = 3 * int(box / 3)
    '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 aok(n, xoff + x, yoff + y) then available = available + 1 : list(3 * y + x) = 1
        next
    next
    if available = 0 then exit function

    dim cell(available) : pointer = 1
    for i = 0 to 8
        if list(i) then cell(pointer) = i : pointer = pointer + 1
    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(0) * i) + 1
            t = cell(i) : cell(i) = cell(r) : cell(r) = t
        next
    end if

    'load the first one listed
    grid(xoff + (cell(1) mod 3), yoff + int(cell(1) / 3)) = n
    loadBox = 1 ' we are golden
end function

sub copyGrid
    for r = 0 to 8
        for c = 0 to 8
            scan
            copy(r, c) = grid(r, c)
        next
    next
end sub

sub copyCopy
    for r = 0 to 8
        for c = 0 to 8
            scan
            grid(r, c) = copy(r, c)
        next
    next
end sub

sub copyGrid2
    for r = 0 to 8
        for c = 0 to 8
            scan
            copy2(r, c) = grid(r, c)
        next
    next
end sub


sub makeGrid
    'this version requires the assistance of LoadBox function and subs copyGrid, copyCopy
    do
        scan
        redim grid(8, 8) : startOver = 0
        for n = 1 to 9
            scan
            call copyGrid
            cnt = 0
            do
                scan
                for box = 0 to 8
                    scan
                    success = loadBox(n, box)
                    if success = 0 then
                        cnt = cnt + 1
                        if cnt >= 20 then startOver = 1 : exit for
                        call copyCopy
                        exit for
                    end if
                next
                if startOver then exit do
            loop until success
            if startOver then exit for
        next
    loop until startOver = 0
end sub

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

function aok(a, c, r) 'check to see if a is OK to place at (c, r)
  if grid(c, r) = 0 then 'check cell empty
     for i = 0 to 8 'check row and column for n
       if abs(grid(i, r)) = a or abs(grid(c, i)) = a then exit function
     next
     cbase = c - c mod 3 : rbase = r - r mod 3 'check box for n
     for rr = 0 to 2
        for cc = 0 to 2
           if abs(grid(cbase + cc, rbase + rr)) = a then exit function
        next
     next
     aok = 1  'otherwise function will return 0 on exit
  end if
end function

'======== end of Grid Making stuff, Start of Solver stuff, aok(a, c, r) used with both!

function CompleteGrid()  'by trying to Solve it
    for round = 1 to 65 '17 clues from 81 cells = 64 maximum rounds to make, add 1 for good measure
        NoChange = 1  'no sense waiting in suspense if nothing is getting changed in puzzle
        gridIsDone = 1
        for n = 1 to 9
            for r = 0 to 8
                for c = 0 to 8
                    scan
                    if aok(n, c, r) then ' (c, r) is empty and n works there
                        gridIsDone = 0  'still a space left in grid

                        'is n the only number that works here in row?
                        only = 1  'only n works here
                        for nn = 1 to 9
                            scan
                            if nn <> n then
                                if aok(nn, c, r) then only = 0 : exit for
                            end if
                        next
                        if only then
                            grid(c, r) = -1 * n  'ID fill-ins with neg numbers to tell from clues
                            NoChange = 0
                        end if
                    end if 'Grid = 0
                next
            next
        next
        if gridIsDone then
            CompleteGrid = round 'successful completion in round numbers
            exit function
        else
            if NoChange then 'bug out!
                CompleteGrid = -1 * round
                exit function
            end if
        end if
    next
    CompleteGrid = round 'last round still failed to complete
end function

sub cp row, ps$
    locate (80-len(ps$))/2, row : print ps$
end sub

data "puzzle test 1 from Sudoku.org.uk tutorial in JS using recursive technique"
' (which I couldn't get a proper translation to work!)
data 0, 0, 0, 7, 0, 8, 0, 3, 0
data 0, 0, 0, 2, 4, 0, 9, 1, 0
data 0, 0, 4, 0, 9, 0, 0, 7, 8
data 4, 0, 0, 3, 5, 0, 0, 0, 2
data 0, 0, 2, 1, 6, 4, 7, 0, 0
data 9, 0, 0, 0, 0, 0, 3, 0, 0
data 6, 4, 9, 0, 0, 1, 0, 2, 3
data 0, 0, 0, 9, 0, 0, 5, 0, 0
data 3, 7, 0, 0, 8, 0, 0, 0, 1

data "puzzle test 2 from PD 2018-01-19 Level 4 (Most difficult!)"
' OK THAT WAS TOO HARD! not a single cell resolved!
data  0,  9,  0,  4,  0,  2,  0,  0,  0
data  0,  4,  0,  0,  9,  0,  2,  0,  0
data  0,  3,  0,  0,  0,  8,  0,  7,  4
data  0,  0,  8,  0,  6,  0,  0,  0,  0
data  2,  0,  0,  9,  0,  1,  0,  0,  8
data  0,  0,  0,  0,  0,  0,  6,  0,  0
data  3,  7,  0,  8,  0,  0,  0,  2,  0
data  0,  0,  6,  0,  3,  0,  0,  8,  0
data  0,  0,  0,  5,  0,  9,  0,  3,  0

data "puzzle test 3 from PD 2018-01-18 Level Intermediate"
' well solver didn't get too far with that one either, but got a couple...
data  0,  0,  0,  0,  8,  0,  0,  0,  0
data  9,  5,  1,  0,  0,  0,  6,  0,  0
data  0,  0,  7,  5,  4,  0,  0,  9,  0
data  0,  0,  0,  0,  0,  0,  0,  2,  0
data  0,  0,  0,  0,  5,  4,  7,  0,  0
data  0,  9,  0,  2,  0,  0,  0,  0,  3
data  0,  0,  0,  0,  0,  0,  4,  8,  0
data  3,  0,  0,  0,  0,  0,  0,  0,  2
data  4,  0,  0,  7,  9,  0,  5,  0,  0

 



 
  Reply Quote Notify of replies

 2   Games and Graphics / Re: SWORD ART ONLINE 4.95  on: Jan 19th, 2018, 2:13pm
Started by atomose | Post by atomose
A Very large upgrade with city part add, anti-cheat system, fight animation, game balanced, better graphisms, hot fixe and a lot of adds.

DOWNLOAD THE UPGRADE HERE
 
  Reply Quote Notify of replies

 3   General Board / Ugly webserver...  on: Jan 18th, 2018, 12:15pm
Started by code | Post by code
Hi,

If you want some text displayed in your browser(for example Firefox) then compile the code below on https://www.compilejava.net/(This will be the webserver...)

Code:
import java.io.*;
import java.net.*;
import java.util.Date;
public class basic {
    public static void main(String args[]){

        ServerSocket ser = null;
        String ld;
        DataInputStream dis;
        PrintStream ps;
        Socket cs = null;

        try {ser = new ServerSocket(80);}
        catch (IOException e) {}   

      while(true){
      
    try {
           cs = ser.accept();
           dis = new DataInputStream(cs.getInputStream());
           ps = new PrintStream(cs.getOutputStream());
           Date d = new Date();
           
             //ld = dis.readLine();
             ps.println("Justbasic... "+d.toString()); 
           cs.close();
          
        }   
    catch (IOException e) {
           
    }}
    }
}


 


To start it open a 'DOS-window' ,go to the directory where basic.class is unzipped... and run it with the command:
'C:\adir\java basic' (not java basic.class just :java basic).

Then open a browser and type: http://localhost and enter.
Now you may see the text :Justbasic

To see the 'website' from over the world , you have to do:
port forwarding... like: http://467.245.67.89 search for a video who explains it.

Goodluck !


 
  Reply Quote Notify of replies

 4   General Board / Re: interesting game-programming site  on: Jan 17th, 2018, 4:08pm
Started by tsh73 | Post by Facundo
Cool! Thanks for sharing. I have found those "old" game engines really interesting now I see " new" games using the same concept but with "better and bigger" bells and whistles. Okay, too many """" grin... tongue
 
  Reply Quote Notify of replies

 5   General Board / interesting game-programming site  on: Jan 17th, 2018, 12:39am
Started by tsh73 | Post by tsh73
Have you ever played Nebulus aka Tower Toppler?

It kind of resurfaced (kids found windows version on a computer). So I started to look if I can get tower map so I could try and make tower in JB (just for fun, probably as graphics only - no real game)

And I found this site
The guy do games in spare times - shows sources and explains *how*. With actual pen-on-paper diagrams wink
The only (?) downside that it is JavaScript. On the plus side, you can play it in the browser and see if you like it.

Oh, and he has "How to build a racing game" too.
 
  Reply Quote Notify of replies

 6   JB Programming Discussions / Re: Sudoku  on: Jan 14th, 2018, 10:23am
Started by bplus | Post by bplus
Game design decision:

Levels: (a "box" is one of 9 3x3 cells in the grid, in each of which a whole set of numbers 1 to 9 must fit).
I have designated levels to how many cells to remove from each box. So level 1 is 1 cell from each box and this level is good for "flash card" training, to see and type or click the missing number faster than the mind can think. The same goes for level 2 and 3, trainers for automatic processing without brain slowing you down. Levels 4, 5, 6 are the more familiar equivalent to easy, intermediate and hard: leaving 56% (really easy!), 44% (easy-intermediate) and 33% (easy-hard level) number cells in boxes and grid both.

I am pleased to announce I finally found a formula or recipe for hiding cells that guarantees a cell in every row and column of a box thus guarantees 3 cells in every row and column of the whole grid on the hardest level that is still random. The hardest level removes 6 of 9 cells in every box leaving 33% of cells.

My conjecture is that such a homogeneous distribution of hidden cells will be least likely to generate multiple solutions deviating from the original puzzle devised from the start. This conjecture will be explored when I start playing around with Solvers.

I think I can further target numbered cells for a homogeneous distribution of them when hiding cells. Again this is an effort to reduce the likelihood of multiple solutions from the original puzzle devised.

My goal is to make puzzles where only one number works for each cell that leads to solution that is the same as original puzzle setup.

If any of you can remember way back when you played around with Sudoku Games and have experience in setting up puzzle boards with unique solutions, I hope you share it.
 
  Reply Quote Notify of replies

 7   JB Programming Discussions / tabular data in text file  on: Jan 13th, 2018, 1:10pm
Started by zzz000abc | Post by zzz000abc
hi,
here is program to create table in text file
Code:
        input "enter table name  ";tblnam$
        st0$="enter ":st1$=" col heads ":st2$="row  ":st3$=str$(k)
        maxfdw$="0 0 0":newfdw$=""
      while 1
            if k=0 then st$=st0$+st1$ else st$=st0$+st2$+st3$+" "
            input "";st$;s$
            if s$="" then exit while
            if k=0 then fn=wc(s$)
            newfdw$=fdw$(s$,fn)
            maxfdw$=mxfdw$(newfdw$,maxfdw$,fn)
            l$=l$+s$+";"
            k=k+1:st3$=str$(k) 'record number
      wend
         open "abc.dat"for append as #1
             print space$(20);upper$(tblnam$)
              #1,space$(20);upper$(tblnam$)
         close#1

       for i=1 to k
            if i=1 then hd=1 else hd=0
            n=tp(word$(l$,i,";"),maxfdw$,fn,hd)
      next
      function tp(fdn$,fdw$,fn,hd)
            l$="|"
          for i=1 to fn
                a$(i)=word$(fdn$,i)
                a(i)=int(val(word$(fdw$,i)))+5
          next
          for i=1 to fn
                if len(a$(i)) mod 2=0 then k=(a(i)-len(a$(i)))/2:t=0 else k=(a(i)-len(a$(i))-1)/2:t=1
                a$(i)=space$(k)+a$(i)+space$(k)+space$(t)
                l$=l$+a$(i)+"|"
          next
            tot=0
          for i=1 to fn
                tot=tot+int(val(word$(fdw$,i)))+5
          next
          for j=1 to (tot+fn+1)
                b$=b$+"-"
          next
            open "abc.dat" for append as#1
            if hd=1 then print #1,b$
            print l$
            print #1,l$
            print #1,b$
            close#1
            tp=0
      end function
      function wc(l$)
          while word$(l$,k+1)<>""
                k=k+1
          wend
            wc=k
      end function
      function fdw$(l$,fno)
          for i=1 to fno
                t=len(word$(l$,i))
                t$=t$+str$(t)+chr$(32)
          next
            fdw$=trim$(t$)
      end function
      function mxfdw$(fdw1$,fdw2$,fno)
            t$=""
          for i=1 to fno
              if val(word$(fdw1$,i))>val(word$(fdw2$,i)) then
                    t$=t$+word$(fdw1$,i)+chr$(32)
              else
                    t$=t$+word$(fdw2$,i)+chr$(32)
              end if
          next
            mxfdw$=trim$(t$)
      end function

 

* above code generates a file abc.dat in JB folder
* don't forget to keep Courier font or font name containing mono
 
  Reply Quote Notify of replies

 8   Novice / Re: Run time error  on: Jan 13th, 2018, 11:33am
Started by Kevin34 | Post by tsh73
Post your code, and we'll try to help.
 
  Reply Quote Notify of replies

 9   Novice / Re: Run time error  on: Jan 13th, 2018, 09:26am
Started by Kevin34 | Post by bplus
on Jan 13th, 2018, 09:14am, Kevin34 wrote:
InludesKey - not recognized.

What causes that?


Yep! What the heck is "InludesKey" ? shocked
 
  Reply Quote Notify of replies

 10   Novice / Run time error  on: Jan 13th, 2018, 09:14am
Started by Kevin34 | Post by Kevin34
InludesKey - not recognized.

What causes that?
 
  Reply Quote Notify of replies


Conforums Terms of Service | Membership Rules | Home | Search | Recent Posts | Notification | Format Your Message | Installation FAQ

Just BASIC wiki
Wikispaces

Donate $6.99 for 50,000 Ad-Free Pageviews!

| |

This forum powered for FREE by Conforums ©
Sign up for your own Free Message Board today!
Terms of Service | Privacy Policy | Conforums Support | Parental Controls