Author Topic: Hexagonal Life  (Read 6597 times)

0 Members and 1 Guest are viewing this topic.

Marked as best answer by bplus on September 30, 2019, 12:23:56 pm

Offline bplus

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

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


Anchor seed.PNG
* Anchor seed.PNG (Filesize: 3.1 KB, Dimensions: 158x167, Views: 192)
Face from Anchor seed.PNG
* Face from Anchor seed.PNG (Filesize: 41.96 KB, Dimensions: 744x671, Views: 186)
« Last Edit: September 30, 2019, 04:23:31 pm by bplus »

Offline TempodiBasic

  • Forum Resident
  • Posts: 1792
    • View Profile
Re: Hexagonal Life
« Reply #16 on: September 30, 2019, 05:30:01 pm »
Yes you can find so many faces... but too fast to be catched by a screenshot

here more permanent blinker
 
hex blinkers.jpg
Programming isn't difficult, only it's  consuming time and coffee