Deleted
Deleted Member
Posts: 0
|
Post by Deleted on Jul 6, 2021 6:38:37 GMT -5
hello  does anyone knows how to print on a graphical screen in QB64 like it's a text screen? here is a code for Conway's game of life yet on freebasic it used a text screen here i am using a graphical screen... (800,600,32) any help appreciated:
Option _Explicit
'Dim a&
Screen _NewImage(800, 600, 32)
Print _Height / _FontHeight, _Width / _FontWidth
'Screen 19
Dim x1 As Integer, y1 As Integer
Dim Shared As Integer grid(0 To 100, 0 To 37), newgrid(0 To 100, 0 To 37)
Dim As Integer gen, n, nei, was, x, y
Dim As String t, s
x1 = 99
y1 = 36
s = "in memory of JOHN HORTON CONWAY 1937 - 2020"
t = "CONWAY'S GAME OF LIFE"
Randomize Timer
For x = 0 To 100
For y = 0 To 37
grid(x, y) = Int(Rnd * 2)
Next
Next
Align 6, s
Align 8, t
Sleep
Cls
Do
game grid(), was, nei, newgrid()
swap_grid grid(), newgrid()
print_grid grid()
Sleep 100
Loop Until InKey$ = Chr$(27)
Sleep
Sub game (arr() As Integer, was As Integer, nei As Integer, arr2() As Integer)
Dim As Integer n, x, y
For x = 1 To 99
For y = 1 To 36
'IF x-1 < 1 THEN x = 1
'IF x +1 > 99 THEN x = 99
'IF y-1 < 1 THEN y = 1
'IF y +1> 36 THEN y = 36
nei = arr(x - 1, y - 1) + arr(x, y - 1)
nei = nei + arr(x + 1, y - 1)
nei = nei + arr(x - 1, y) + arr(x + 1, y)
nei = nei + arr(x - 1, y + 1)
nei = nei + arr(x, y + 1) + arr(x + 1, y + 1)
was = arr(x, y)
If was = 0 Then
If nei = 3 Then n = 1 Else n = 0
Else
If nei = 3 Or nei = 2 Then n = 1 Else n = 0
End If
arr2(x, y) = n
Next
Next
End Sub
Sub swap_grid (arr1() As Integer, arr2() As Integer)
Dim As Integer x, y
For x = 0 To 100
For y = 0 To 37
arr1(x, y) = arr2(x, y)
Next
Next
End Sub
Sub PRINT_TO_SCREEN (x As Integer, y As Integer, arr() As Integer)
If (arr(x, y)) = 1 Then
Locate y, x: Print Chr$(219);
ElseIf (arr(x, y)) = 0 Then
Locate y, x: Print " ";
End If
End Sub
Sub print_grid (grid() As Integer)
Dim As Integer x, y
For x = 0 To 100
For y = 0 To 37
PRINT_TO_SCREEN x, y, grid()
Next
Next
End Sub
Sub Align (Trow, txt$)
' Dim center&, maxcol As Integer, Tcol As Integer
' center& = _Width(mode&) \ 2 'returns pixels in graphic modes
' maxcol = (center& \ 8) + 1 'screen text width = 8 pixels
' Tcol = maxcol - (Len(txt$) \ 2)
' Color Tcolor: Locate Trow, Tcol: Print txt$;
Locate Trow, (((_Width / _FontWidth) - Len(txt$)) / 2): Print txt$
End Sub
|
|
|
|
Post by bplus on Jul 6, 2021 22:18:47 GMT -5
Hi Ron when you use LOCATE both x and y have to be greater than 0, first row is 1 and first column is 1.
Since 1990's on old GW Basic I've been doing versions on Conway's Life. Here is Quick Demo
_Title "Quick Life trans for QB64 11-06.82 2017-11-11 by bplus"
' From: quick life.bas SmallBASIC (not MS) B+ G7 stripped down to favorite setting
'
' To: the one out there who has checked out Conway's Life the last couple of days.
' For you, a working version (albeit highly modified) of Conway's Life code in QB64.
'
' Quote Rules (from Wiki):
' The universe of the Game of Life is an infinite two-dimensional orthogonal grid of square cells,
' each of which is in one of two possible states, alive or dead, or "populated" or "unpopulated".
' Every cell interacts with its eight neighbours, which are the cells that are horizontally,
' vertically, or diagonally adjacent. At each step in time, the following transitions occur:
' 1) Any live cell with fewer than two live neighbours dies, as if caused by underpopulation.
' 2) Any live cell with two or three live neighbours lives on to the next generation.
' 3) Any live cell with more than three live neighbours dies, as if by overpopulation.
' 4) Any dead cell with exactly three live neighbours becomes a live cell, as if by reproduction.
' The initial pattern constitutes the seed of the system.
' The first generation is created by applying the above rules simultaneously to every cell in the
' seed—births and deaths occur simultaneously, and the discrete moment at which this happens is
' sometimes called a tick (in other words, each generation is a pure function of the preceding one).
' The rules continue to be applied repeatedly to create further generations.
' (End Quote)
' Alas in practical applications we do not have infinite board to play Life, so at boundries rules
' break down as neighbor counts are only 5 max on edge and only 3 max at corners.
'This code is very easy to modify into other tests / demos:
' Try coloring by neighbor counts.
' Try other rules besides Classic 2,3 neighbors = survive, 3 neighbors = birth.
' Try regenration along the borders every other generation, which causes symetric beauties!
' Change an = the number of cells per side, even amounts that divide 700 (pixels per board side) work best.
Const xmax = 700
Const ymax = 700
Screen _NewImage(xmax, ymax, 32)
_ScreenMove 360, 20
'DEFINT A-Z
Dim qb&(15) 'thanks Andy Amaya for use with his sub qColor fore, back
qb&(0) = _RGB(0, 0, 0) ' black
qb&(1) = _RGB(0, 0, 128) ' blue
qb&(2) = _RGB(8, 128, 8) ' green
qb&(3) = _RGB(0, 128, 128) ' cyan
qb&(4) = _RGB(128, 0, 0) ' red
qb&(5) = _RGB(128, 0, 128) ' magenta
qb&(6) = _RGB(128, 64, 32) ' brown
qb&(7) = _RGB(168, 168, 168) ' white
qb&(8) = _RGB(128, 128, 128) ' grey
qb&(9) = _RGB(84, 84, 252) ' light blue
qb&(10) = _RGB(42, 252, 42) ' light green
qb&(11) = _RGB(0, 220, 220) ' light cyan
qb&(12) = _RGB(255, 0, 0) ' light red
qb&(13) = _RGB(255, 84, 255) ' light magenta
qb&(14) = _RGB(255, 255, 0) ' yellow
qb&(15) = _RGB(255, 255, 255) 'bright white
'test colors
'FOR i = 0 TO 15
' PRINT i,
' LINE (100, 100)-(500, 500), qb&(i), BF
' _LIMIT 1
'NEXT
an = 70: s = Int(ymax / an): bigBlock = an * s: g = 0
Dim a(1 To an, 1 To an), ng(1 To an, 1 To an), ls(1 To an, 1 To an)
'seed for Conway's Life Classic
For y = 2 To an - 1
For x = 2 To an - 1
' a(x, y) = INT(RND * 2) 'for random mess
'for symmetric line
If y = an / 2 Or y = an / 2 + 1 Then a(x, y) = 1
Next
Next
While InKey$ <> " "
' Mandala Life regeneration of Mandala like arrays, seeds every other generation along edges
'IF g MOD 2 = 0 THEN
'FOR x = 1 TO an
' a(x, 1) = 1: a(x, an) = 1: a(1, x) = 1: a(an, x) = 1
'NEXT
'END IF
For x = 2 To an - 1
For y = 2 To an - 1
pc = a(x - 1, y - 1) + a(x - 1, y) + a(x - 1, y + 1) + a(x, y - 1) + a(x, y + 1) + a(x + 1, y - 1) + a(x + 1, y) + a(x + 1, y + 1)
ls(x, y) = pc
r$ = Right$(Str$(pc), 1)
If a(x, y) Then 'cell is alive so what is surviveRule
'Bplus favorite Mandala Life Rules for survival and birth
'IF INSTR("2346", r$) THEN ng(x, y) = 1 ELSE ng(x, y) = 0
'Classic Conway's Life Rules
If InStr("23", r$) Then ng(x, y) = 1 Else ng(x, y) = 0
Else 'birth?
'Bplus favorite Mandala Life Rules for survival and birth
'IF INSTR("34", r$) THEN ng(x, y) = 1 ELSE ng(x, y) = 0
'Classic Conway's Life Rules
If InStr("3", r$) Then ng(x, y) = 1 Else ng(x, y) = 0
End If
Next
Next
'Bplus favorite Mandala Life Rules for survival and birth
'LINE (1, 1)-(bigBlock, bigBlock), qb&(0), BF
'Classic Conway's Life Rules
Line (1, 1)-(bigBlock, bigBlock), qb&(1), BF
For y = 1 To an
For x = 1 To an
If a(x, y) Then 'show old a with it's neighbor counts br yellow or black
'Bplus favorite Mandala Life Rules for survival and birth
'LINE ((x - 1) * s + 1, (y - 1) * s + 1)-STEP(s, s), qb&(0), BF
'this separates into individual cells for Classic look
Line ((x - 1) * s + 1, (y - 1) * s + 1)-Step(s - 2, s - 2), qb&(15), BF
'Mandala Life coloring by neighbor counts
'ELSE
' lc = ls(x, y)
' SELECT CASE lc
' CASE 0: cl = 15 ' br white
' CASE 1: cl = 11 ' cyan
' CASE 2: cl = 7 ' low white, br gray
' CASE 3: cl = 10 ' light green
' CASE 4: cl = 9 ' blue
' CASE 5: cl = 13 ' violet
' CASE 6: cl = 12 ' br red
' CASE 7: cl = 4 ' dark red
' CASE 8: cl = 0 ' black
' END SELECT
' LINE ((x - 1) * s + 1, (y - 1) * s + 1)-STEP(s, s), qb&(cl), BF
End If
Next
Next
_Display
For y = 1 To an
For x = 1 To an
a(x, y) = ng(x, y) 'load a() with next generation data
Next
Next
g = g + 1
_Limit 10
Wend
|
|
|
|
Post by bplus on Jul 6, 2021 22:21:48 GMT -5
Another I called Core Life:
Option _Explicit ' by bplus 2019-09-20
DefInt A-Z ' strip Quick Life down to bare essentials
_Title "Core Life: press spacebar when stabilized, esc to quit"
Const xmax = 700, ymax = 700, n = 140, s = 5
Screen _NewImage(xmax, ymax, 32)
_ScreenMove 360, 20
Dim g, x, y, r, nc 'nc is neighbor count
Dim a(0 To n + 1, 0 To n + 1), ng(0 To n + 1, 0 To n + 1) 'a() is Life array, ng() is next generation
Color &HFFFFFF00, &HFF080021: r = 35
Do 'seed for Conway's Life Classic
Cls
g = 0: r = r - 1: If r = 1 Then r = 68
For y = 0 To n + 1
For x = 0 To n + 1 'for symmetric line blocks
If y = n / 2 And x > r And x < (n + 1 - r) Then a(x, y) = 1 Else a(x, y) = 0
Next
Next
While InKey$ <> " " And _KeyDown(27) = 0 'run life until spacebar detected
For x = 1 To n
For y = 1 To n
nc = a(x - 1, y - 1) + a(x - 1, y) + a(x - 1, y + 1) + a(x, y - 1) + a(x, y + 1) + a(x + 1, y - 1) + a(x + 1, y) + a(x + 1, y + 1)
If a(x, y) Then ' a is alive Classic Conway's Life Rules for survival
If nc = 2 Or nc = 3 Then ng(x, y) = 1 Else ng(x, y) = 0
Else 'birth?
If nc = 3 Then ng(x, y) = 1 Else ng(x, y) = 0
End If
Next
Next
Line (0, 0)-Step(xmax, ymax), &H11080021, BF
For y = 1 To n
For x = 1 To n
If a(x, y) Then 'this separates into individual cells for Classic look
Line ((x - 1) * s + 1, (y - 1) * s + 1)-Step(s - 2, s - 2), &HFFFFFFFF, BF
End If
Next
Next
Locate 1, 1: Print "Seed:"; r; " Gen:"; g
_Display
For y = 1 To n
For x = 1 To n
a(x, y) = ng(x, y) 'load a() with next generation data
Next
Next
g = g + 1
_Display
_Limit 10
Wend
Loop Until _KeyDown(27)
Cls: End
|
|
Deleted
Deleted Member
Posts: 0
|
Post by Deleted on Jul 7, 2021 3:59:55 GMT -5
hello bplus thanks for the advice i fixed the x and y for locate command to start from 1 not o and the program works here is the working code again: Option _Explicit
'Dim a&
Screen _NewImage(800, 600, 32)
Print _Height / _FontHeight, _Width / _FontWidth
'Screen 19
Dim x1 As Integer, y1 As Integer
Dim Shared As Integer grid(0 To 100, 0 To 37), newgrid(0 To 100, 0 To 37)
Dim As Integer gen, n, nei, was, x, y
Dim As String t, s
x1 = 99
y1 = 36
s = "in memory of JOHN HORTON CONWAY 1937 - 2020"
t = "CONWAY'S GAME OF LIFE"
Randomize Timer
For x = 0 To 100
For y = 0 To 37
grid(x, y) = Int(Rnd * 2)
Next
Next
Align 6, s
Align 8, t
Sleep
Cls
Do
game grid(), was, nei, newgrid()
swap_grid grid(), newgrid()
print_grid grid()
_Delay 0.1
Loop Until InKey$ = Chr$(27)
Sleep
Sub game (arr() As Integer, was As Integer, nei As Integer, arr2() As Integer)
Dim As Integer n, x, y
For x = 1 To 99
For y = 1 To 36
'IF x-1 < 1 THEN x = 1
'IF x +1 > 99 THEN x = 99
'IF y-1 < 1 THEN y = 1
'IF y +1> 36 THEN y = 36
nei = arr(x - 1, y - 1) + arr(x, y - 1)
nei = nei + arr(x + 1, y - 1)
nei = nei + arr(x - 1, y) + arr(x + 1, y)
nei = nei + arr(x - 1, y + 1)
nei = nei + arr(x, y + 1) + arr(x + 1, y + 1)
was = arr(x, y)
If was = 0 Then
If nei = 3 Then n = 1 Else n = 0
Else
If nei = 3 Or nei = 2 Then n = 1 Else n = 0
End If
arr2(x, y) = n
Next
Next
End Sub
Sub swap_grid (arr1() As Integer, arr2() As Integer)
Dim As Integer x, y
For x = 0 To 100
For y = 0 To 37
arr1(x, y) = arr2(x, y)
Next
Next
End Sub
Sub PRINT_TO_SCREEN (x As Integer, y As Integer, arr() As Integer)
If (arr(x, y)) = 1 Then
Locate y, x: Print Chr$(219);
ElseIf (arr(x, y)) = 0 Then
Locate y, x: Print " ";
End If
End Sub
Sub print_grid (grid() As Integer)
Dim As Integer x, y
For x = 1 To 100
For y = 1 To 37
PRINT_TO_SCREEN x, y, grid()
Next
Next
End Sub
Sub Align (Trow, txt$)
' Dim center&, maxcol As Integer, Tcol As Integer
' center& = _Width(mode&) \ 2 'returns pixels in graphic modes
' maxcol = (center& \ 8) + 1 'screen text width = 8 pixels
' Tcol = maxcol - (Len(txt$) \ 2)
' Color Tcolor: Locate Trow, Tcol: Print txt$;
Locate Trow, (((_Width / _FontWidth) - Len(txt$)) / 2): Print txt$
End Sub
|
|
|
|
Post by bplus on Jul 7, 2021 6:25:13 GMT -5
@ron77 you've got!
You might enjoy the show if you start with symmetric seeds including just lines or boxes of different size.
Also you can play god and change the rules of Life! Some variations go viral (on screen) :-))
PS "Seed" or seeding is the starting condition or setting up the start conditions in first grid here.
|
|
