Hexagonal Life

[bplus]

LOL this one is much better! After around 30 seconds or so it filled the entire screen. :) You also might want to add in the _TITLE "Generations: "+g  where g is how many times they multiply. Really cool. Or you can use a different word than Generations.

Good idea Ken, I usually do have generation on screen.

Code: QB64: [Select]

1. OPTION _EXPLICIT 'Bplus started 2019-09-23 from Hex Minesweeper Custom Field
2. '2019-09-25 post with original Life Rules
3. '2019-09-27 OK let's try some more color!
4. '2019-09-28 fix hexagon fills by not using PAINT
5. '2019-09-30 add Generation as suggested by Ken
6.  
7. CONST cellR = 10 ' which makes the following constant
8. CONST xSpacing = 2 * cellR * COS(_D2R(30))
9. CONST ySpacing = cellR * (1 + SIN(_D2R(30)))
10.  
11. TYPE cell
12.     x AS INTEGER
13.     y AS INTEGER
14.     L AS INTEGER
15. END TYPE
16. DIM SHARED k(6) AS _UNSIGNED LONG
17. k(0) = &HFF000000: k(1) = &HFFFFFF88: k(2) = &HFFDDDDFF: k(3) = &HFF550033: k(4) = &HFF005500: k(5) = &HFF000044: k(6) = &HFFFF0000
18. DIM SHARED xmax AS INTEGER, ymax AS INTEGER, Xarrd AS INTEGER, Yarrd AS INTEGER 'set all this in customField sub
19.  
20.  
21. '      note: To preserve symmetry when cells hit boundries with a symmetric seed started in middle:
22. '            y should be odd for 1 center row
23. '            x should be equal to or less than y
24. '            If int(x/2 + .5) is even then the right one of two center cells is marked else the one center cell is marked
25. '
26.  
27. Xarrd = 41 ' the top left cell has been hacked to duplicate the top right cell, to preserve symmetric seeds through a run
28.  
29. Yarrd = 41 'y should always be odd top preserve symmetry of center symmetric seed
30.  
31. xmax = (Xarrd + 2) * xSpacing: ymax = (Yarrd + 2) * ySpacing
32.  
33. SCREEN _NEWIMAGE(xmax, ymax, 32)
34. _SCREENMOVE (1280 - xmax) / 2 + 60, (760 - ymax) / 2
35. RANDOMIZE TIMER
36. DIM SHARED b(0 TO Xarrd + 1, 0 TO Yarrd + 1) AS cell, ng(0 TO Xarrd + 1, 0 TO Yarrd + 1) AS INTEGER 'oversize the board to make it easy to count
37.  
38. DIM x AS INTEGER, y AS INTEGER, xoffset, xStop AS INTEGER, nc AS INTEGER, c AS INTEGER, r AS INTEGER, mb AS INTEGER, kh&, gen AS INTEGER
39.  
40. DO
41.     _TITLE "Hexagon Life: Left Click to Toggle Cells On/Off, Right Click to Start Run, Escape to Quit"
42.     ' set x, y for cells and mark ceter cell(s)
43.     FOR y = 1 TO Yarrd
44.         IF y MOD 2 = 0 THEN
45.             xoffset = .5 * xSpacing: xStop = Xarrd - 1
46.         ELSE
47.             xoffset = 0: xStop = Xarrd
48.         END IF
49.         FOR x = 1 TO xStop
50.             b(x, y).x = x * xSpacing + xoffset + .5 * xSpacing
51.             b(x, y).y = y * ySpacing + .5 * ySpacing
52.             IF x = INT(Xarrd / 2 + .5) AND y = INT(Yarrd / 2 + .5) THEN b(x, y).L = 1 ELSE b(x, y).L = 0 'mark middle cell
53.             showCell x, y, 7
54.         NEXT
55.     NEXT
56.     _DISPLAY
57.  
58.     'setup seed by toggling cells on and off
59.     WHILE mb <> 2
60.         kh& = _KEYHIT
61.         IF kh& = 27 THEN EXIT DO
62.         mb = 0: c = 0: r = 0
63.         getCell c, r, mb
64.         IF mb = 1 THEN
65.             b(c, r).L = 1 - b(c, r).L
66.             showCell c, r, 7
67.         END IF
68.         _DISPLAY
69.         _LIMIT 60
70.     WEND
71.     mb = 0
72.     _TITLE "Hexagon Life: Spacebar to Restart/Reseed, Escape to Quit"
73.     WHILE kh& <> 32 AND kh& <> 27
74.         kh& = _KEYHIT
75.         'count the neighbors
76.         FOR y = 1 TO Yarrd
77.             IF y MOD 2 = 0 THEN
78.                 xoffset = .5 * xSpacing: xStop = Xarrd - 1
79.             ELSE
80.                 xoffset = 0: xStop = Xarrd
81.             END IF
82.             FOR x = 1 TO xStop
83.                 '2 sets of neighbors depending if x offset or not
84.                 IF xoffset > .05 THEN
85.                     nc = b(x, y - 1).L + b(x + 1, y - 1).L + b(x - 1, y).L
86.                     nc = nc + b(x + 1, y).L + b(x, y + 1).L + b(x + 1, y + 1).L
87.                 ELSE
88.                     nc = b(x - 1, y - 1).L + b(x, y - 1).L + b(x - 1, y).L
89.                     nc = nc + b(x + 1, y).L + b(x - 1, y + 1).L + b(x, y + 1).L
90.                 END IF
91.                 'originally tested and posted( 9/25/2019) here only 2 neighbors for birth in Classic Life it takes 3
92.                 'IF (nc = 3 AND b(x, y).L = 1) OR nc = 2 THEN ng(x, y) = 1 ELSE ng(x, y) = 0
93.  
94.                 'TempodiBasic suggested this survival if 1 survival or surviaval and birth for 2 neighbors
95.                 IF (nc = 1 AND b(x, y).L = 1) OR nc = 2 THEN ng(x, y) = 1 ELSE ng(x, y) = 0
96.  
97.                 ' my first test for TempodiBasic, I mistakenly ran this which is good too!
98.                 'IF (nc = 3 AND b(x, y).L = 1) OR nc = 1 THEN ng(x, y) = 1 ELSE ng(x, y) = 0
99.  
100.                 showCell x, y, nc
101.                 IF x = Xarrd AND y = 1 THEN showCell 1, 1, nc
102.             NEXT
103.         NEXT
104.  
105.         'redraw all cells so no CLS
106.         FOR y = 1 TO Yarrd 'transfer data from ng to b().l and show cell
107.             IF y MOD 2 = 0 THEN
108.                 xStop = Xarrd - 1
109.             ELSE
110.                 xStop = Xarrd
111.             END IF
112.             FOR x = 1 TO xStop
113.                 b(x, y).L = ng(x, y)
114.                 'showCell x, y
115.             NEXT
116.             'fix symmetry for top left corner, match x at other end for bi-lat symmetry
117.             b(1, 1).L = b(Xarrd, 1).L
118.             'showCell 1, 1
119.         NEXT
120.         gen = gen + 1
121.         LOCATE 1, 1: PRINT SPACE$(50)
122.         LOCATE 1, 1: PRINT "Generation:"; gen
123.         _DISPLAY
124.         _LIMIT 1
125.     WEND
126.     IF kh& = 27 THEN EXIT DO
127.     kh& = 0
128. LOOP
129.  
130. SUB showCell (c AS INTEGER, r AS INTEGER, kNum AS INTEGER)
131.     DIM clr AS _UNSIGNED LONG
132.     IF r MOD 2 = 0 THEN
133.         IF c < 1 OR c > Xarrd - 1 THEN EXIT SUB
134.     ELSE
135.         IF c < 1 OR c > Xarrd THEN EXIT SUB
136.     END IF
137.     IF r < 1 OR r > Yarrd THEN EXIT SUB
138.     IF kNum = 7 THEN
139.         IF b(c, r).L = 1 THEN clr = &HFFFFFFFF ELSE clr = &HFF000000
140.     ELSE
141.         clr = k(kNum)
142.     END IF
143.     IF kNum < 7 THEN
144.         fHexH b(c, r).x, b(c, r).y, cellR, clr
145.         hexH b(c, r).x, b(c, r).y, cellR, &HFF000000
146.     ELSE
147.         fHexH b(c, r).x, b(c, r).y, cellR, clr
148.         hexH b(c, r).x, b(c, r).y, cellR, &HFF440044
149.     END IF
150. END SUB
151.  
152. SUB getCell (returnCol AS INTEGER, returnRow AS INTEGER, mbNum AS INTEGER)
153.     DIM m, mx, my, mb1, mb2, r AS INTEGER, c AS INTEGER
154.     WHILE _MOUSEINPUT: WEND
155.     mb1 = _MOUSEBUTTON(1): mb2 = _MOUSEBUTTON(2)
156.     IF mb1 THEN mbNum = 1
157.     IF mb2 THEN mbNum = 2
158.     IF mb1 OR mb2 THEN '                      get last place mouse button was down
159.         WHILE mb1 OR mb2 '                    wait for mouse button release as a "click"
160.             m = _MOUSEINPUT: mb1 = _MOUSEBUTTON(1): mb2 = _MOUSEBUTTON(2)
161.             mx = _MOUSEX: my = _MOUSEY
162.             'LOCATE 1, 1: PRINT SPACE$(50)
163.             'LOCATE 1, 1: PRINT mx, my, .5 * xSpacing
164.             _DISPLAY
165.         WEND
166.         FOR r = 1 TO Yarrd
167.             FOR c = 1 TO Xarrd
168.                 IF ((mx - b(c, r).x) ^ 2 + (my - b(c, r).y) ^ 2) ^ .5 < .5 * xSpacing THEN
169.                     'LOCATE 1, 1: PRINT SPACE$(50)
170.                     'LOCATE 1, 1: PRINT c, r
171.                     returnCol = c: returnRow = r: EXIT SUB
172.                 END IF
173.             NEXT
174.         NEXT
175.         mbNum = 0 'still here then clicked wrong
176.     END IF
177. END SUB
178.  
179. 'draw Hexagon Outline that can be packed Horizontally, flat edge to flat edge
180. SUB hexH (xOrigin AS SINGLE, yOrigin AS SINGLE, radius AS SINGLE, c AS _UNSIGNED LONG)
181.     DIM polyAngle AS SINGLE, aOff AS SINGLE, x1 AS SINGLE, y1 AS SINGLE, i AS INTEGER, x2 AS SINGLE, y2 AS SINGLE
182.     polyAngle = _PI(2) / 6: aOff = _PI / 2
183.     x1 = xOrigin + radius * COS(polyAngle + aOff)
184.     y1 = yOrigin + radius * SIN(polyAngle + aOff)
185.     FOR i = 2 TO 7
186.         x2 = xOrigin + radius * COS(i * polyAngle + aOff)
187.         y2 = yOrigin + radius * SIN(i * polyAngle + aOff)
188.         LINE (x1, y1)-(x2, y2), c
189.         x1 = x2: y1 = y2
190.     NEXT
191. END SUB
192.  
193. 'draw filled Hexagon that can be packed Horizontally, flat edge to flat edge
194. 'uses SUB fTri
195. SUB fHexH (xOrigin AS SINGLE, yOrigin AS SINGLE, radius AS SINGLE, c AS _UNSIGNED LONG)
196.     DIM polyAngle AS SINGLE, aOff AS SINGLE, x1 AS SINGLE, y1 AS SINGLE, i AS INTEGER, x2 AS SINGLE, y2 AS SINGLE
197.     polyAngle = _PI(2) / 6: aOff = _PI / 2
198.     x1 = xOrigin + radius * COS(polyAngle + aOff)
199.     y1 = yOrigin + radius * SIN(polyAngle + aOff)
200.     FOR i = 2 TO 7
201.         x2 = xOrigin + radius * COS(i * polyAngle + aOff)
202.         y2 = yOrigin + radius * SIN(i * polyAngle + aOff)
203.         fTri xOrigin, yOrigin, x1, y1, x2, y2, c
204.         x1 = x2: y1 = y2
205.     NEXT
206. END SUB
207.  
208. SUB fTri (x1 AS SINGLE, y1 AS SINGLE, x2 AS SINGLE, y2 AS SINGLE, x3 AS SINGLE, y3 AS SINGLE, K AS _UNSIGNED LONG)
209.     DIM a&
210.     a& = _NEWIMAGE(1, 1, 32)
211.     _DEST a&
212.     PSET (0, 0), K
213.     _DEST 0
214.     _MAPTRIANGLE _SEAMLESS(0, 0)-(0, 0)-(0, 0), a& TO(x1, y1)-(x2, y2)-(x3, y3)
215.     _FREEIMAGE a& '<<< this is important!
216. END SUB
217.  
218.  

Ha! I am finding faces everywhere today (not exactly human but...) ;-))

[TempodiBasic]

Yes you can find so many faces... but too fast to be catched by a screenshot

here more permanent blinker