Text Only | Text with Attachments

QB64.org Forum

Active Forums => QB64 Discussion => Topic started by: xra7en on November 08, 2021, 05:44:06 pm

Title: ISO simple ASCII procedural terrain
Post by: xra7en on November 08, 2021, 05:44:06 pm
I tried this for a few years, but I just cannot grasp the concept of "noise" "Parlin noise" or at least how to implement it in qb64.
Everything I try comes out too random.

looking for something as simple as this.
https://i.imgur.com/NunOIhN.png

do not need anything more 7 tilesets

so if anyone has a starter sample, or a link that explains how this is done (in english LOL) - found lots of resources for 3d like Minecraft etc.. but 2d ascii does not seem to exist.
thansk

Title: Re: ISO simple ASCII procedural terrain
Post by: bplus on November 08, 2021, 07:05:22 pm
When I think of 2D landscape I think of this:
Code: QB64: [Select]
  1. _Title "Drawlandscape Demo" ' b+ 2021-11-08
  2. Const Xmax = 800, Ymax = 600
  3. Screen _NewImage(Xmax, Ymax, 32)
  4. _ScreenMove 200, 50
  6.     drawLandscape
  7.     _Limit .5
  9.  
  10. Sub drawLandscape
  11.     'needs midInk, irnd
  12.  
  13.     Dim i As Long, startH As Single, rr As Long, gg As Long, bb As Long
  14.     Dim mountain As Long, Xright As Single, y As Single, upDown As Single, range As Single
  15.     Dim lastx As Single, X As Long
  16.     'the sky
  17.     For i = 0 To Ymax
  18.         midInk 0, 0, 128, 128, 128, 200, i / Ymax
  19.         Line (0, i)-(Xmax, i)
  20.     Next
  21.     'the land
  22.     startH = Ymax - 200
  23.     rr = 70: gg = 70: bb = 90
  24.     For mountain = 1 To 6
  25.         Xright = 0
  26.         y = startH
  27.         While Xright < Xmax
  28.             ' upDown = local up / down over range, change along Y
  29.             ' range = how far up / down, along X
  30.             upDown = (Rnd * .8 - .35) * (mountain * .5)
  31.             range = Xright + irnd&(15, 25) * 2.5 / mountain
  32.             lastx = Xright - 1
  33.             For X = Xright To range
  34.                 y = y + upDown
  35.                 Color _RGB(rr, gg, bb)
  36.                 Line (lastx, y)-(X, Ymax), , BF 'just lines weren't filling right
  37.                 lastx = X
  38.             Next
  39.             Xright = range
  40.         Wend
  41.         rr = irnd&(rr - 15, rr): gg = irnd&(gg - 15, gg): bb = irnd&(bb - 25, bb)
  42.         If rr < 0 Then rr = 0
  43.         If gg < 0 Then gg = 0
  44.         If bb < 0 Then bb = 0
  45.         startH = startH + irnd&(5, 20)
  46.     Next
  48.  
  49. Function irnd& (n1, n2) 'return an integer between 2 numbers
  50.     Dim l%, h%
  51.     If n1 > n2 Then l% = n2: h% = n1 Else l% = n1: h% = n2
  52.     irnd& = Int(Rnd * (h% - l% + 1)) + l%
  54.  
  55. Sub midInk (r1%, g1%, b1%, r2%, g2%, b2%, fr##)
  56.     Color _RGB32(r1% + (r2% - r1%) * fr##, g1% + (g2% - g1%) * fr##, b1% + (b2% - b1%) * fr##)
  58.  
  59.  

Then I thought of this:
Code: QB64: [Select]
  1. _Title "Drawlandscape Parallax test" 'started 2019-03-27
  2. 'test if can get end of landscape level to start for big looping background
  3. '2019-03-27 a more gentle adjustment back to Mountain starting height for
  4. 'more seamless connect of back end to front
  5. '2019-03-27 start this file with parallax drawing test
  6.  
  7.  
  9. Screen _NewImage(800, 600, 32)
  10. _ScreenMove 100, 20
  11. Type parallaxType
  12.     handle As Long
  13.     rate As Single 'number of pixels per frame added to le (leading edge)
  14.     le As Single
  17. nLevels = 6
  18. Dim Shared para(1 To nLevels) As parallaxType
  19.  
  20. Dim Shared scape&
  21. LoadLandscape
  22. scapeWidth = _Width(para(1).handle)
  23. scapeHeight = _Height(para(1).handle)
  24.  
  25. While t < 6000
  26.     Cls
  27.     For i = 1 To nLevels
  28.         If para(i).le + 800 > scapeWidth Then
  29.             te = scapeWidth - para(i).le
  30.             _PutImage (0, 0)-(te, scapeHeight), para(i).handle, 0, (scapeWidth - te, 0)-(scapeWidth, scapeHeight)
  31.             _PutImage (te, 0)-(800, scapeHeight), para(i).handle, 0, (0, 0)-(800 - te, scapeHeight)
  32.  
  33.         Else
  34.             _PutImage (0, 0)-(800, scapeHeight), para(i).handle, 0, (para(i).le, 0)-(para(i).le + 800, scapeHeight)
  35.         End If
  36.  
  37.         para(i).le = para(i).le - para(i).rate
  38.         If para(i).le < 0 Then para(i).le = scapeWidth
  39.     Next
  40.     t = t + 1
  41.     _Display
  42.     _Limit 120
  44.  
  45. Sub LoadLandscape
  46.     cur& = _Dest
  47.     xmax = 800 * 3.25: ymax = 600
  48.     hdl& = 1
  49.     para(hdl&).handle = _NewImage(xmax, ymax, 32)
  50.     _Dest para(hdl&).handle
  51.  
  52.     For i = 0 To ymax
  53.         midInk 0, 0, 128, 128, 128, 200, i / ymax
  54.         Line (0, i)-(xmax, i)
  55.     Next
  56.     'the land
  57.     startH = ymax - 200
  58.     rr = 70: gg = 70: bb = 90
  59.     For mountain = 1 To nLevels
  60.         If mountain > 1 Then
  61.             para(mountain).handle = _NewImage(xmax, ymax, 32)
  62.             _Dest para(mountain).handle
  63.         End If
  64.         Xright = 0
  65.         y = startH
  66.         Color _RGB(rr, gg, bb)
  67.         While Xright < xmax - 50
  68.             ' upDown = local up / down over range, change along Y
  69.             ' range = how far up / down, along X
  70.             upDown = (Rnd * .8 - .4) * (mountain * .5)
  71.             range = Xright + rand%(15, 25) * 2.5 / mountain
  72.             If range > xmax - 50 Then range = xmax - 50
  73.             lastx = Xright - 1
  74.             For x = Xright To range 'need less flat tops
  75.                 test = y + upDown
  76.                 test2 = y - upDown
  77.                 If Abs(test - startH) < .13 * startH Then y = test Else y = test2: upDown = -upDown
  78.                 Line (lastx, y)-(x, ymax), , BF 'just lines weren't filling right
  79.                 lastx = x
  80.             Next
  81.             Xright = range
  82.         Wend
  83.         x = lastx + 1
  84.         dy = (startH - y) / 50 'more gentle adjustment back to start of screen
  85.         While x <= xmax
  86.             y = y + dy
  87.             Line (lastx, y)-(x, ymax), , BF 'just lines weren't filling right
  88.             lastx = x
  89.             x = x + 1
  90.         Wend
  91.         rr = rand%(rr - 15, rr): gg = rand%(gg - 15, gg): bb = rand%(bb - 25, bb)
  92.         If rr < 0 Then rr = 0
  93.         If gg < 0 Then gg = 0
  94.         If bb < 0 Then bb = 0
  95.         startH = startH + mountain * rand%(2, 10)
  96.         para(mountain).le = xmax - 800
  97.         para(mountain).rate = mountain * .5
  98.     Next
  99.     _Dest cur&
  101.  
  102. Function rand% (lo%, hi%)
  103.     rand% = Int(Rnd * (hi% - lo% + 1)) + lo%
  105.  
  106. Sub midInk (r1%, g1%, b1%, r2%, g2%, b2%, fr##)
  107.     Color _RGB(r1% + (r2% - r1%) * fr##, g1% + (g2% - g1%) * fr##, b1% + (b2% - b1%) * fr##)
  109.  
  110.  

Sure that could be reduced to ASCII?
Title: Re: ISO simple ASCII procedural terrain
Post by: xra7en on November 08, 2021, 08:04:17 pm
Love those
what I am trying to do (as in the image) is do a top down ascii style -
think dwarf fortress, but not that elaborate - just 5 or 6 tiles - I think DF has like 100 tiles LOL
Title: Re: ISO simple ASCII procedural terrain
Post by: xra7en on November 10, 2021, 06:09:43 pm
So I put this request up in 2012 in a game dev site, did not get many responses. I thought it was strange that a ascii top down terrain gen would be difficult (so at least I am not the only one LOL)
Many of the responses were like this - 3D models that were not land types.

So I'll take another stab at what I can do, post it here and see if someone can improve on it.

Team work
Title: Re: ISO simple ASCII procedural terrain
Post by: bplus on November 10, 2021, 06:51:38 pm
@xra7en would you have images you would like converted, photos of something?
Title: Re: ISO simple ASCII procedural terrain
Post by: johnno56 on November 10, 2021, 08:26:48 pm
... like an ASCII rpg?

ASCII. Old school. But cool.
Title: Re: ISO simple ASCII procedural terrain
Post by: xra7en on November 10, 2021, 08:38:01 pm
Quote from: bbplus
@xra7en would you have images you would like converted, photos of something?


O I've done that before - looks cool, but what I want is a procedurally generated one.

The first style I used to do for small games - and it served its purpose
Code: QB64: [Select]
  1. Dim tile(5) As String
  2. tile(1) = "T"
  3. tile(2) = "."
  4. tile(3) = "="
  5. tile(4) = "~"
  6. tile(5) = " "
  7.  
  8.  
  9. For i = 1 To 10
  10.     For j = 1 To 10
  11.         Print " "; tile(Int(Rnd * 5) + 1); " ";
  12.     Next
  13.     Print

but as I started looking at modern indi games, their land "made sense"  - like Minecraft, everything worked. This is too random, no clumping of areas


Title: Re: ISO simple ASCII procedural terrain
Post by: xra7en on November 10, 2021, 08:39:01 pm
Quote from: johnno56 on November 10, 2021, 08:26:48 pm
... like an ASCII rpg?

ASCII. Old school. But cool.

yup, have a simple one in mind, but want to have a large map that displays only a small portion where the player is at live.

easy to make, just obsessing over the random generator
Title: Re: ISO simple ASCII procedural terrain
Post by: bplus on November 10, 2021, 09:08:58 pm
I think you could paint a map with a mouse, click an ascii on one screen maybe pick a color too then on the map screen paint it with a mouse, mouse down paints until mouse up.
Title: Re: ISO simple ASCII procedural terrain
Post by: bplus on November 10, 2021, 09:34:03 pm
Code: QB64: [Select]
  1. Dim tile(9) As String
  2. tile(0) = " "
  3. tile(1) = "T"
  4. tile(2) = "."
  5. tile(3) = "="
  6. tile(4) = "~"
  7. tile(5) = "b"
  8. tile(6) = "+"
  9. tile(7) = "M"
  10. tile(8) = Chr$(1)
  11. tile(9) = Chr$(3)
  12.  
  14.     k$ = InKey$
  15.     If k$ <> "" Then
  16.         If Asc(k$) >= 48 And Asc(k$) <= 57 Then kp = Asc(k$) - 48
  17.         Locate 1, 1: Print tile(kp);
  18.     End If
  20.     mx = _MouseX: my = _MouseY: mb1 = _MouseButton(1)
  21.     If my < 25 Then 'dang scrolling
  22.         If mb1 Then Locate my, mx: Print tile(kp);
  23.     End If
  25.  

  [ This attachment cannot be displayed inline in 'Print Page' view ]  
Title: Re: ISO simple ASCII procedural terrain
Post by: xra7en on November 10, 2021, 09:49:56 pm
very clever!! lol
At first look I was like WOW, smaller script than mine, then I saw the inkey$.
but the END RESULT is what i am looking for as procedural

working on one right now - I think I am on to something :-)
I'll post it here later.
Title: Re: ISO simple ASCII procedural terrain
Post by: bplus on November 10, 2021, 10:00:59 pm
I have added code to save to file with s keypress: (Had to start a Project Folder to save maps.)

Code: QB64: [Select]
  1. Dim tile(9) As String
  2. tile(0) = " "
  3. tile(1) = "T"
  4. tile(2) = "."
  5. tile(3) = "="
  6. tile(4) = "~"
  7. tile(5) = "b"
  8. tile(6) = "+"
  9. tile(7) = "M"
  10. tile(8) = Chr$(1)
  11. tile(9) = Chr$(3)
  12.  
  14.     k$ = InKey$
  15.     If k$ <> "" Then
  16.         If Asc(k$) >= 48 And Asc(k$) <= 57 Then
  17.             kp = Asc(k$) - 48: Locate 1, 1: Print tile(kp);
  18.         ElseIf k$ = "s" Then 'save pic
  19.             Open "Save Map.txt" For Output As #1
  20.             For y = 1 To 25
  21.                 b$ = ""
  22.                 For x = 1 To 80
  23.                     b$ = b$ + Chr$(Screen(y, x))
  24.                 Next
  25.                 Print #1, b$
  26.             Next
  27.             Close #1
  28.         End If
  29.     End If
  31.     mx = _MouseX: my = _MouseY: mb1 = _MouseButton(1)
  32.     If my < 25 Then 'dang scrolling
  33.         If mb1 Then Locate my, mx: Print tile(kp);
  34.     End If
  36.  

Here is sample of map (Save Map.txt) :
Code: QB64: [Select]
  1. +                                                                              
  2.                                                                                
  3.                                                              +++++              
  4.                                                             +++++++            
  5.                            bbbbb                            ++++++              
  6.                         b bb  bbbbbbbbbbbbbbb                ++ ++              
  7.                         bbbbbbb            bbb      ++++++++++++++++++++++      
  8.                           bbbbbbb          bbbb    ++++++++++++++++++++++++    
  9.                           b bbb             bbbb    +++++++++++++++++++++      
  10.                           b bb              bbbb             ++++              
  11.                           b bb              bb              +++++++            
  12.                           b bb            bbb               +++++++            
  13.                           bbb          bbbb                   +++              
  14.                           bbb          bbbbbbbb                                
  15.                           bb              bbbbbbbb                              
  16.                           bbb               bbbb b                              
  17.                           bbb                b bbb                              
  18.                           bbb              bbbbb                                
  19.                        bbbbbbbbbbbbbbbbbbbbbbb                                  
  20.                        bbbbbbbbbbbbbbbbbbbbbb                                  
  21.                           b   bbbbbbbbbbbbb                                    
  22.                              bb                                                
  23.                                                                                
  24.                                                                                
  25.                                                                              
  26.  

If you like it, save it under a new name otherwise it will just be written over with next drawing.
Title: Re: ISO simple ASCII procedural terrain
Post by: xra7en on November 10, 2021, 10:03:09 pm
ok try this-
closer to what im shooting for

yes yes yes. redundant code (easy to clean up later)

currently just using squares.. but may change this to diamonds mix
Code: QB64: [Select]
  2.  
  3. Dim tile(5) As String
  4. Dim area(75, 20) As Integer
  5.  
  6. tile(1) = "T"
  7. tile(2) = "."
  8. tile(3) = "="
  9. tile(4) = "~"
  10. tile(5) = " "
  11.  
  12. '// Clear the map
  13. For i = 1 To 75: For j = 1 To 20: area(i, j) = 0: Next: Next
  14.  
  15. '// lets try some random squares
  16. For i = 1 To 30 ' <-- bigger number more dense
  17.     x = r(72)
  18.     y = r(18)
  19.     For k = y - 1 To y + 1
  20.         For j = x - 5 To x + 5
  21.             If j > 0 And j < 76 And k > 0 And k < 21 Then
  22.                 area(j, k) = 1
  23.             End If
  24.  
  25.         Next
  26.     Next
  28.  
  29. For i = 1 To 15 ' <-- bigger number more dense
  30.     x = r(72)
  31.     y = r(18)
  32.     For k = y - 1 To y + 1
  33.         For j = x - 5 To x + 5
  34.             If j > 0 And j < 76 And k > 0 And k < 21 Then
  35.                 area(j, k) = 2
  36.             End If
  37.  
  38.         Next
  39.     Next
  41.  
  42. For i = 1 To 7 ' <-- bigger number more dense
  43.     x = r(72)
  44.     y = r(18)
  45.     For k = y - 1 To y + 1
  46.         For j = x - 5 To x + 5
  47.             If j > 0 And j < 76 And k > 0 And k < 21 Then
  48.                 area(j, k) = 3
  49.             End If
  50.  
  51.         Next
  52.     Next
  54.  
  55. For i = 1 To 7 ' <-- bigger number more dense
  56.     x = r(72)
  57.     y = r(18)
  58.     For k = y - 1 To y + 1
  59.         For j = x - 5 To x + 5
  60.             If j > 0 And j < 76 And k > 0 And k < 21 Then
  61.                 area(j, k) = 4
  62.             End If
  63.  
  64.         Next
  65.     Next
  67.  
  68.  
  69.  
  70.  
  71.  
  73.  
  74.  
  75. For j = 1 To 20
  76.     For i = 1 To 75
  77.  
  78.         Select Case area(i, j)
  79.             Case 0: Print " ";
  80.             Case 1: Print "T";
  81.             Case 2: Print "#";
  82.             Case 3: Print ".";
  83.             Case 4: Print ".";
  84.  
  85.         End Select
  86.     Next
  87.  
  88.     Print
  90.  
  91.  
  93.     r = Int(Rnd * num) + 1
  95.  
Title: Re: ISO simple ASCII procedural terrain
Post by: bplus on November 10, 2021, 10:06:28 pm
When you are ready to alter the look of the characters, I have a Character Editor.
Title: Re: ISO simple ASCII procedural terrain
Post by: xra7en on November 10, 2021, 10:12:25 pm
Quote from: bplus on November 10, 2021, 10:06:28 pm
When you are ready to alter the look of the characters, I have a Character Editor.

thank you.. !!

for simplicity I'll keep it in the extended table for now..

is your editor similar to the DF characters?
Title: Re: ISO simple ASCII procedural terrain
Post by: bplus on November 10, 2021, 10:15:08 pm
Don't know what DF characters are?

Char Editor is for 8 X16 Font and I was modifying for 8x8 font I think.
Title: Re: ISO simple ASCII procedural terrain
Post by: bplus on November 10, 2021, 10:27:56 pm
Code: QB64: [Select]
  1. _Title "8X16 ASCII Character Editor"
  2. 'started 2018-08-27 by bplus
  3. 'QB64 X 64 version 1.2 20180228/86  from git b301f92
  4. ' 2020-09-18 modified to coexist with the 8X8 Character Editor in the same Folder
  5.  
  6. '========================== Instructions: =================================
  7. '
  8. ' Arrow keys move the highlighter around, spacebar toggles tile on/off
  9. ' or just click with mouse to do the same.
  10.  
  11. ' Click buttons to either
  12. ' 1. Enter an ascii by number to edit.
  13. ' 2. Enter a character by pressing the key(s) from which the ascii number is taken.
  14. ' 3. Save a modified character.
  15. ' 4. Save all edits made to file called "Character Set.DAT".
  16. ' Note: If want to work with more sets, just rename Character Set.DAT
  17. '       If that file isn't found, this app will start from scratch.
  18. '
  19. '==========================================================================
  20. Const cFile$ = "8X16 Character Set.DAT"
  21. Const CW = 8
  22. Const CH = 16
  23. Const SQ = 25
  24. Const XOFF = 60
  25. Const YOFF = 80
  26. Const WW = 800
  27. Const WH = 600
  28. Screen _NewImage(WW, WH, 32)
  29. _ScreenMove (1280 - WW) / 2 + 30, (760 - WH) / 2
  30. Dim Shared AN%, CX, CY, BLK As _Unsigned Long, WHT As _Unsigned Long, SAVED
  31. Dim Shared MAP(CW + 2, CH + 2) As String * 1
  32. Dim Shared CS(256) As String * 128
  33. WHT = _RGB32(255, 255, 255)
  34. BLK = _RGB32(0, 0, 0)
  35.  
  36. '==============================   main
  37.  
  38. 'see if there is a file in the works to load else start from scratch
  40.     Open cFile$ For Input As #1
  41.     For i = 1 To 256
  42.         Input #1, CS(i - 1)
  43.     Next
  44.     Close #1
  45.     SAVED = -1
  47.     For a = 0 To 255
  48.         Cls
  49.         _PrintString (0, 0), Chr$(a)
  50.         b$ = ""
  51.         For y = 0 To CH - 1
  52.             For x = 0 To CW - 1
  53.                 If Point(x, y) <> BLK Then b$ = b$ + "1" Else b$ = b$ + "0"
  54.             Next
  55.         Next
  56.         CS(a) = b$
  57.     Next
  58.     SAVED = 0
  60.  
  61. For i = 1 To 128
  62.     Print Mid$(CS(1), i, 1);
  63.     If i Mod CW = 0 Then Print
  65. 'END
  66. 'sample B for starters
  67. AN% = 66
  68. load AN%
  69. CX = 1: CY = 1
  73.         mx = _MouseX
  74.         my = _MouseY
  75.         _Delay .2
  76.         'ascii #  to edit
  77.         If mx > 500 And mx < 700 And my > 50 And my < 100 Then
  78.             Color WHT, 0
  79.             Line (500, 50)-(700, 100), BLK, BF
  80.             Locate 5, 67: Input "Ascii # "; a%
  81.             If a% >= 0 And a% <= 255 Then AN% = a%: load AN%
  82.         End If
  83.         'chr$  to edit
  84.         If mx > 500 And mx < 700 And my > 110 And my < 160 Then
  85.             Color WHT, 0
  86.             Line (500, 110)-(700, 160), BLK, BF
  87.             Locate 9, 67: Input "Enter Chr$ "; char$
  88.             a% = Asc(char$)
  89.             If a% >= 0 And a% <= 255 Then AN% = a%: load AN%
  90.         End If
  91.         'save character edit
  92.         If mx > 500 And mx < 700 And my > 170 And my < 220 Then
  93.             b$ = ""
  94.             For y = 1 To CH
  95.                 For x = 1 To CW
  96.                     b$ = b$ + MAP(x, y)
  97.                 Next
  98.             Next
  99.             CS(AN%) = b$
  100.             Color WHT, 0
  101.             Line (500, 170)-(700, 220), BLK, BF
  102.             Locate 13, 67: Print " Character recorded. "
  103.             SAVED = 0
  104.             _Display
  105.             _Delay 1.5
  106.         End If
  107.         'file character set
  108.         If mx > 500 And mx < 700 And my > 230 And my < 280 Then
  109.             Color WHT, 0
  110.             Line (500, 230)-(700, 280), BLK, BF
  111.             Open cFile$ For Output As #1
  112.             For a = 0 To 255
  113.                 Print #1, CS(a)
  114.             Next
  115.             Close #1
  116.             Locate 16, 65: Print cFile$
  117.             Locate 17, 71: Print "File Saved"
  118.             SAVED = -1
  119.             _Display
  120.             _Delay 1.5
  121.         End If
  122.  
  123.         'mouse over edit box, toggle tiles and update cursor
  124.         tx = (mx - XOFF) \ SQ: ty = (my - YOFF) \ SQ
  125.         If tx >= 1 And tx <= CW And ty >= 1 And ty <= CH Then
  126.             CX = tx: CY = ty
  127.             If MAP(CX, CY) = "1" Then MAP(CX, CY) = "0" Else MAP(CX, CY) = "1"
  128.         End If
  129.     End If
  130.     KH& = _KeyHit
  131.     Select Case KH&
  132.         Case 32 'space bar
  133.             If MAP(CX, CY) = "1" Then MAP(CX, CY) = "0" Else MAP(CX, CY) = "1"
  134.         Case 18432 'up
  135.             If CY - 1 >= 1 Then CY = CY - 1
  136.         Case 20480 'down
  137.             If CY + 1 <= CH Then CY = CY + 1
  138.         Case 19200 'left
  139.             If CX - 1 >= 1 Then CX = CX - 1
  140.         Case 19712 'right
  141.             If CX + 1 <= CW Then CX = CX + 1
  142.     End Select
  143.  
  144.     If _KeyDown(27) Then End
  145.     update
  146.     _Display
  147.     _Limit 60
  149.  
  150. Sub load (asci)
  151.     For i = 1 To 128
  152.         y = i \ CW + 1
  153.         x = i Mod CW: If x = 0 Then x = 8: y = y - 1
  154.         MAP(x, y) = Mid$(CS(asci), i, 1)
  155.     Next
  157.  
  158. Sub update
  159.     Color WHT, _RGB32(100, 110, 100): Cls
  160.     drwBtn 500, 50, "Load map with Ascii"
  161.     drwBtn 500, 110, "Load map with Chr$"
  162.     drwBtn 500, 170, "Save Character Edit"
  163.     drwBtn 500, 230, "File Character Set"
  164.     Color _RGB32(250, 225, 255), _RGB32(100, 110, 100)
  165.     _PrintString (398, 400), "Current Ascii% =" + Str$(AN%) + " or CHR$(" + LTrim$(Str$(AN%)) + ") = " + Chr$(AN%)
  166.     If SAVED Then s$ = " Saved." Else s$ = " not Saved yet."
  167.     _PrintString (398, 440), "File: " + cFile$ + s$
  168.     Line (XOFF - 1, YOFF - 1)-Step((CW + 2) * SQ + 2, (CH + 2) * SQ + 2), _RGB32(255, 255, 0), B
  169.     Line (XOFF + 1, YOFF + 1)-Step((CW + 2) * SQ, (CH + 2) * SQ), BLK, B
  170.     Line (XOFF, YOFF)-Step((CW + 2) * SQ, (CH + 2) * SQ), _RGB32(255, 80, 0), BF
  171.     For y = 1 To CH
  172.         For x = 1 To CW
  173.             If MAP(x, y) = "1" Then c& = _RGB32(200, 200, 200) Else c& = _RGB32(0, 0, 0)
  174.             Line ((x) * SQ + XOFF, (y) * SQ + YOFF)-Step(SQ - 2, SQ - 2), c&, BF
  175.         Next
  176.     Next
  177.     ' let's see actual size!
  178.     Color _RGB32(255, 255, 0), _RGB32(100, 110, 100)
  179.     For i = 1 To 4
  180.         drwChar XOFF + 16 * (i * 2), .5 * YOFF - (16 * i) / 2, AN%, i
  181.     Next
  182.     'highlight sqr
  183.     Line (CX * SQ - 1 + XOFF, CY * SQ - 1 + YOFF)-Step(SQ, SQ), WHT, B
  184.  
  186.  
  187. Sub drwBtn (x, y, s$)
  188.     th = 16: tw = 8 * Len(s$): gray& = _RGB32(190, 190, 190)
  189.     Line (x, y)-Step(200, 50), _RGB32(0, 0, 0), BF
  190.     Line (x, y)-Step(197, 47), _RGB32(255, 255, 255), BF
  191.     Line (x + 1, y + 1)-Step(197, 47), gray&, BF
  192.     Color _RGB32(0, 0, 0), gray&
  193.     _PrintString (x + 100 - 4 * Len(s$), y + 17), s$
  195.  
  196. Sub drwChar (x0, y0, ascn, size) 'what ever the present color is set at
  197.     For y = 0 To CH - 1
  198.         For x = 0 To CW - 1
  199.             i = i + 1
  200.             If Mid$(CS(ascn), i, 1) = "1" Then Line (x0 + x * size, y0 + y * size)-Step(size - 1, size - 1), , BF
  201.         Next
  202.     Next
  204.  

It will use custom charaacter set in this file: "8X16 Character Set.DAT"
if it finds it in the folder of the .exe otherwise it will start that file and when you slect save file it will make your character set with custom changes.

If you want several custom sets just change name of file, and change it back to "8X16 Character Set.DAT" to edit that one again.

Of course, you will need some routines for using these characters in you game file. I think I have a test demo somewhere.

Also looks like 8 x 8 editor is done too.
  [ This attachment cannot be displayed inline in 'Print Page' view ]  

Wow over 3 years ago!
Title: Re: ISO simple ASCII procedural terrain
Post by: xra7en on November 10, 2021, 10:50:04 pm
Quote from: bplus on November 10, 2021, 10:15:08 pm
Don't know what DF characters are?

Char Editor is for 8 X16 Font and I was modifying for 8x8 font I think.

dwarf fortress (one of the hardest games ever created - even has an O'Reilly book on how to play - Im like seriously - ofc I bought it LOL)
https://i.pinimg.com/originals/96/3d/4f/963d4f5d54e5d0e90ee6d7b23d140bff.jpg
https://www.amazon.com/Getting-Started-Dwarf-Fortress-complex/dp/1449314945

Title: Re: ISO simple ASCII procedural terrain
Post by: xra7en on November 10, 2021, 10:51:39 pm
Yes! I would be interested in that. It is almost like a modern THEDRAW program!
or more precisely TDFONTS program.
Title: Re: ISO simple ASCII procedural terrain
Post by: xra7en on November 10, 2021, 10:53:13 pm
OK end result it actually accpetable. Obviously clean up the code.
will prob add a routine to add a river, maybe one or two lakes. and a range of hardcore mountains!

add color and poof
Code: QB64: [Select]
  1.  
  2.  
  4.  
  5. Dim tile(5) As String
  6. Dim area(75, 20) As Integer
  7.  
  8. tile(1) = "T"
  9. tile(2) = "."
  10. tile(3) = "="
  11. tile(4) = "~"
  12. tile(5) = " "
  13.  
  14. '// Clear the map
  15. For i = 1 To 75: For j = 1 To 20: area(i, j) = 0: Next: Next
  16.  
  17. '// lets try some random squares
  18. For i = 1 To 40 ' <-- bigger number more dense
  19.     x = r(75)
  20.     y = r(20)
  21.     For k = y - 1 To y + 1
  22.         For j = x - 5 To x + 5
  23.             If j > 0 And j < 76 And k > 0 And k < 21 Then
  24.                 area(j, k) = 1
  25.             End If
  26.  
  27.         Next
  28.     Next
  30.  
  31. For i = 1 To 20 ' <-- bigger number more dense
  32.     x = r(72)
  33.     y = r(18)
  34.     For k = y - 1 To y + 1
  35.         For j = x - 5 To x + 5
  36.             If j > 0 And j < 76 And k > 0 And k < 21 Then
  37.                 area(j, k) = 2
  38.             End If
  39.  
  40.         Next
  41.     Next
  43.  
  44. For i = 1 To 10 ' <-- bigger number more dense
  45.     x = r(72)
  46.     y = r(18)
  47.     For k = y - 1 To y + 1
  48.         For j = x - 5 To x + 5
  49.             If j > 0 And j < 76 And k > 0 And k < 21 Then
  50.                 area(j, k) = 3
  51.             End If
  52.  
  53.         Next
  54.     Next
  56.  
  57. For i = 1 To 5 ' <-- bigger number more dense
  58.     x = r(72)
  59.     y = r(18)
  60.     For k = y - 1 To y + 1
  61.         For j = x - 5 To x + 5
  62.             If j > 0 And j < 76 And k > 0 And k < 21 Then
  63.                 area(j, k) = 4
  64.             End If
  65.  
  66.         Next
  67.     Next
  69.  
  70. For y = 1 To 20
  71.     For x = 1 To 75
  72.         If area(x, y) = 0 Then area(x, y) = 247
  73.     Next
  75.  
  76.  
  77.  
  78.  
  80.  
  81.  
  82. For j = 1 To 20
  83.     For i = 1 To 75
  84.  
  85.         Select Case area(i, j)
  86.             Case 0: Print " ";
  87.             Case 1: Print "T";
  88.             Case 2: Print "#";
  89.             Case 3: Print ".";
  90.             Case 4: Print ".";
  91.             Case 247: Print Chr$(area(i, j));
  92.  
  93.         End Select
  94.     Next
  95.  
  96.     Print
  98.  
  99.  
  101.     r = Int(Rnd * num) + 1
  103.  
Title: Re: ISO simple ASCII procedural terrain
Post by: bplus on November 10, 2021, 11:32:06 pm
Oh hey, rndRect!
Code: QB64: [Select]
  1. _Title "RndRect - zzz... press any, esc to quit"
  4.     For i = 1 To 250
  5.         rndRect
  6.     Next
  7.     Sleep
  9.  
  10. Sub rndRect
  11.     c$ = Chr$(Int(Rnd * 200) + 32)
  12.     x = Int(Rnd * 80) + 1
  13.     y = Int(Rnd * 25) + 1
  14.     w = Int(Rnd * 30) + 1
  15.     h = Int(Rnd * 8) + 1
  16.     For row = y To y + h
  17.         For col = x To x + w
  18.             If row <= 25 And col <= 80 Then
  19.                 Locate row, col: Print c$;
  20.             End If
  21.         Next
  22.     Next
  24.  
Title: Re: ISO simple ASCII procedural terrain
Post by: bplus on November 10, 2021, 11:37:16 pm
Colorized version
Code: QB64: [Select]
  1. _Title "RndRect - zzz... press any, esc to quit"
  4.     For i = 1 To 250
  5.         rndRect
  6.     Next
  7.     Sleep
  9.  
  10. Sub rndRect
  11.     c$ = Chr$(Int(Rnd * 200) + 32)
  12.     x = Int(Rnd * 80) + 1
  13.     y = Int(Rnd * 25) + 1
  14.     w = Int(Rnd * 30) + 1
  15.     h = Int(Rnd * 8) + 1
  16.     Color Int(Rnd * 15) + 1 '  Int(Rnd * 15) + 1
  17.     For row = y To y + h
  18.         For col = x To x + w
  19.             If row <= 25 And col <= 80 Then
  20.                 Locate row, col: Print c$;
  21.             End If
  22.         Next
  23.     Next
  25.  
Title: Re: ISO simple ASCII procedural terrain
Post by: bplus on November 10, 2021, 11:42:58 pm
With limited tile() set:
Code: QB64: [Select]
  1. _Title "RndRect - zzz... press any, esc to quit"
  2.  
  4. tile(1) = "T"
  5. tile(2) = "."
  6. tile(3) = "="
  7. tile(4) = "~"
  8. tile(5) = " "
  9.  
  12.     For i = 1 To 250
  13.         rndRect
  14.     Next
  15.     Sleep
  17.  
  18. Sub rndRect
  19.     c$ = tile(Int(Rnd * 5) + 1)
  20.     x = Int(Rnd * 80) + 1
  21.     y = Int(Rnd * 25) + 1
  22.     w = Int(Rnd * 30) + 1
  23.     h = Int(Rnd * 8) + 1
  24.     'Color Int(Rnd * 15) + 1 '  Int(Rnd * 15) + 1   ' Color or Not ?
  25.     For row = y To y + h
  26.         For col = x To x + w
  27.             If row <= 25 And col <= 80 Then
  28.                 Locate row, col: Print c$;
  29.             End If
  30.         Next
  31.     Next
  33.  
Title: Re: ISO simple ASCII procedural terrain
Post by: xra7en on November 11, 2021, 12:12:53 am
nice - but grouping is off (something I am still struggling with)

trees should be surrounded by bushes, surrounded by maybe grass, and plains, and clearing near body of water.
so far we have random blocks, but not making sense LOL

cept now its late,,, will tackle tomorrow at work (i have my own hours hahhaaha)

Title: Re: ISO simple ASCII procedural terrain
Post by: bplus on November 11, 2021, 12:28:42 am
Here is Font 8 so I can add round circles:
Code: QB64: [Select]
  1. _Title "RndRect - zzz... press any, esc to quit"
  2.  
  4. tile(1) = "T"
  5. tile(2) = "."
  6. tile(3) = "="
  7. tile(4) = "~"
  8. tile(5) = "#"
  9.  
  11. Width 80, 80
  14.     For i = 1 To 50
  15.         rndRect
  16.     Next
  17.     Sleep
  19.  
  20. Sub rndRect
  21.     c$ = tile(Int(Rnd * 5) + 1)
  22.     x = Int(Rnd * _Width) + 1
  23.     y = Int(Rnd * _Height) + 1
  24.     w = Int(Rnd * 15) + 1
  25.     h = Int(Rnd * 15) + 1
  26.     'Color Int(Rnd * 15) + 1 '  Int(Rnd * 15) + 1   ' Color or Not ?
  27.  
  28.     If Rnd < .5 Then
  29.         For row = y To y + h
  30.             For col = x To x + w
  31.                 If row <= _Height And col <= _Width Then
  32.                     Locate row, col: Print c$;
  33.                 End If
  34.             Next
  35.         Next
  36.     Else
  37.         For row = y - h To y + h
  38.             For col = x - h To x + h
  39.                 If row >= 1 And row <= _Height Then
  40.                     If col > 1 And col <= _Width Then
  41.                         If Sqr(((col - x) ^ 2) + (row - y) ^ 2) <= h Then
  42.                             Locate row, col: Print c$;
  43.                         End If
  44.                     End If
  45.                 End If
  46.             Next
  47.         Next
  48.  
  49.     End If

Circles look more natural but what we really need is plasma!
Title: Re: ISO simple ASCII procedural terrain
Post by: SMcNeill on November 11, 2021, 12:49:21 am
Here's my first shot at this:

Code: QB64: [Select]
  1. Const XSize = 200, YSize = 200
  2. Dim Shared As Long Grid(XSize, YSize)
  3.  
  4. DisplayScreen = MaxScreen
  5. Screen MaxScreen
  7.  
  10.  
  12.     InitializeMap
  13.     Rivers Int(Rnd * 10) + 1, Int(Rnd * 100) - 100, -3
  14.     GenerateTerrain
  15.  
  16.     DrawMap
  17.     Sleep
  19.  
  20. Sub InitializeMap
  21.     For x = 0 To XSize
  22.         For y = 0 To YSize
  23.             Grid(x, y) = -999 'default blank part of map
  24.         Next
  25.     Next
  27.  
  28.  
  29. Sub DrawMap
  30.     Dim kolor As _Unsigned Long
  31.     xscale = _Width / XSize
  32.     yscale = _Height / YSize
  33.     For x = 0 To XSize
  34.         For y = 0 To YSize
  35.             Select Case Grid(x, y)
  36.                 Case -3: kolor = DarkBlue 'Deep Water
  37.                 Case -2: kolor = Blue 'Water
  38.                 Case -1: kolor = SkyBlue 'Shallow Water
  39.                 Case 0: kolor = Tann 'beach/sand
  40.                 Case 1: kolor = Green 'grassland
  41.                 Case 2: kolor = DarkGreen 'forest
  42.                 Case 3: kolor = Pink 'hills
  43.                 Case 4: kolor = Purple 'mountains
  44.                 Case 5 TO 99: kolor = Red
  45.                 Case Else: kolor = Black
  46.             End Select
  47.             Line (x * xscale, y * yscale)-Step(xscale, yscale), kolor, BF
  48.     Next y, x
  50.  
  51.  
  52. Sub GenerateTerrain
  53.     Height = -3
  54.     Do Until finished
  55.         finished = -1
  56.         For x = 0 To XSize
  57.             For y = 0 To YSize
  58.                 If Grid(x, y) = Height Then Fill x, y, Height + 1: finished = 0
  59.             Next
  60.         Next
  61.         Height = Height + 1
  62.     Loop
  63.  
  65.  
  66. Sub Fill (x, y, height)
  67.     Select Case height
  68.         Case Is < 0: RepeatChance = 33 'water repeat
  69.         Case Is = 0: RepeatChance = 25 'beach repeat
  70.         Case Is = 1: RepeatChance = 55 'grassland
  71.         Case Is = 2: RepeatChance = 55 'forest
  72.         Case Is = 3: RepeatChance = 40 ' hills
  73.         Case Is = 4: RepeatChance = 33 'mountains
  74.         Case Else
  75.             RepeatChance = 50 - 3 * height
  76.             If RepeatChance < 10 Then RepeatChance = 10
  77.     End Select
  78.     CurrentX = x
  79.     If CurrentX > 0 Then
  80.         If Grid(CurrentX - 1, y) = -999 Then
  81.             Grid(CurrentX - 1, y) = height
  82.             If Int(Rnd * 100) < RepeatChance Then Fill CurrentX - 1, y, height
  83.         End If
  84.     End If
  85.     CurrentX = x
  86.     If CurrentX < XSize Then
  87.         If Grid(CurrentX + 1, y) = -999 Then
  88.             Grid(CurrentX + 1, y) = height
  89.             If Int(Rnd * 100) < RepeatChance Then Fill CurrentX + 1, y, height
  90.         End If
  91.     End If
  92.     CurrentY = y
  93.     If CurrentY > 0 Then
  94.         If Grid(x, CurrentY - 1) = -999 Then
  95.             Grid(x, CurrentY - 1) = height
  96.             If Int(Rnd * 100) < RepeatChance Then Fill x, CurrentY - 1, height
  97.         End If
  98.     End If
  99.     CurrentY = y
  100.     If CurrentY < YSize Then
  101.         If Grid(x, CurrentY + 1) = -999 Then
  102.             Grid(x, y + 1) = height
  103.             If Int(Rnd * 100) < RepeatChance Then Fill x, CurrentY + 1, height
  104.         End If
  105.     End If
  107.  
  108. Sub Rivers (Number, Meander, Deep)
  109.     For i = 1 To Number
  110.         flip1 = Int(Rnd * 2): flip2 = Int(Rnd * 2)
  111.         If flip1 Then 'entry point is on top
  112.             x1 = Int(Rnd * XSize): y1 = 0
  113.         Else 'entry point is on left
  114.             x1 = 0: y1 = Int(Rnd * YSize)
  115.         End If
  116.         If flip2 Then 'exit point is on bottom
  117.             x2 = Int(Rnd * XSize): y2 = YSize
  118.         Else 'exit point is on right
  119.             x2 = XSize: y2 = Int(Rnd * YSize)
  120.         End If
  121.  
  122.         Grid(x1, y1) = Deep: Grid(x2, y2) = Deep
  123.         StartX = x1: StartY = y1: EndX = x2: EndY = y2 'just to preserve our original values, if needed.
  124.         Do Until StartX = EndX And StartY = EndY
  125.             CoinToss = Int(Rnd * 100) 'Coin toss to move left/right or up/down, to go towards exit, or wander a bit.
  126.             Meander = 10
  127.             If CoinToss Mod 2 Then 'even or odd, so we only walk vertical or hortizontal and not diagional
  128.                 If CoinToss < 100 - Meander Then 'Lower values meander less and go directly to the target.
  129.                     XChange = Sgn(EndX - StartX) '-1,0,1, drawn always towards the mouse
  130.                     Ychange = 0
  131.                 Else
  132.                     XChange = Int(Rnd * 3) - 1 '-1, 0, or 1, drawn in a random direction to let the lightning wander
  133.                     Ychange = 0
  134.                 End If
  135.             Else
  136.                 If CoinToss < 100 - Meander Then 'Lower values meander less and go directly to the target.
  137.                     Ychange = Sgn(EndY - StartY)
  138.                     XChange = 0
  139.                 Else
  140.                     Ychange = Int(Rnd * 3) - 1
  141.                     XChange = 0
  142.                 End If
  143.             End If
  144.             StartX = StartX + XChange
  145.             StartY = StartY + Ychange
  146.             If StartX < 0 Then StartX = 0 'Make certain we move inside the bounds of our map dimensions
  147.             If StartY < 0 Then StartY = 0
  148.             If StartX > XSize Then StartX = XSize
  149.             If StartY > YSize Then StartY = YSize
  150.             Grid(StartX, StartY) = Deep 'place a river where we moved to
  151.         Loop
  152.     Next
  154.  
  155.  
  156.  
  157.  
  158.  
  159. Function MaxScreen
  160.     DH = _DesktopHeight: DW = _DesktopWidth
  161.     TBH = TaskbarHeight: TBW = TaskbarWidth
  162.     TH = TitleBarHeight: BW = BorderWidth
  163.     If TBH = DH Then TBH = 0 'Users taskbar is configured vertical, not hortizonal.
  164.     If TBW = DW Then TBW = 0
  165.     MaxScreen = _NewImage(DW - TBW - 2 * BW, DH - TBH - TH - BW * 2, 32)
  167.  
  168. Sub ScreenMove (x, y)
  169.     Do Until _Width <> 0 And _ScreenExists = -1: Loop
  170.     _ScreenMove x - BorderWidth, y - BorderWidth - TitleBarHeight
  172.  
  173. Sub ScreenMove_Middle
  174.     Do Until _Width <> 0 And _ScreenExists = -1: Loop
  175.     _ScreenMove (_DesktopWidth - _Width - BorderWidth) / 2 + 1, (_DesktopHeight - _Height - BorderWidth) / 2 - TitleBarHeight + 1
  177.  
  178. Function TaskbarHeight
  179.     Do Until _Width <> 0 And _ScreenExists = -1: Loop
  180.  
  181.     $If WIN Then
  182.         $If TASKBARDEC = UNDEFINED Then
  183.             $Let TASKBARDEC = TRUE
  184.             Declare Library "taskbar"
  185.                 Function taskbar_height& ()
  186.                 Function taskbar_width& ()
  187.             End Declare
  188.         $End If
  189.         TaskbarHeight = taskbar_height&
  190.     $Else
  191.         TaskbarHeight = 0 'no function to get the value for Linux/Mac, so return 0 instead of an error
  192.     $End If
  194.  
  195. Function TaskbarWidth
  196.     Do Until _Width <> 0 And _ScreenExists = -1: Loop
  197.     $If WIN Then
  198.         $If TASKBARDEC = UNDEFINED Then
  199.             $Let TASKBARDEC = TRUE
  200.  
  201.             Declare Library "taskbar"
  202.             Function taskbar_height& ()
  203.             Function taskbar_width& ()
  204.             End Declare
  205.         $End If
  206.         TaskbarWidth = taskbar_width&
  207.     $Else
  208.         TaskbarWidth = 0 'no function to get the value for Linux/Mac, so return 0 instead of an error
  209.     $End If
  211.  
  212.  
  213. Function TitleBarHeight
  214.     Do Until _Width <> 0 And _ScreenExists = -1: Loop
  215.     $If BORDERDEC = UNDEFINED Then
  216.         $Let BORDERDEC = TRUE
  217.         Declare Library
  218.             Function glutGet& (ByVal what&)
  219.         End Declare
  220.     $End If
  221.     TitleBarHeight = glutGet(507)
  223.  
  224. Function BorderWidth
  225.     Do Until _Width <> 0 And _ScreenExists = -1: Loop
  226.     $If BORDERDEC = UNDEFINED Then
  227.         $Let BORDERDEC = TRUE
  228.         Declare Library
  229.         Function glutGet& (ByVal what&)
  230.         End Declare
  231.     $End If
  232.     BorderWidth = glutGet(506)

We start by building some rivers across the screen, which would be the lowest point on the map, and then we rise up to build terrain from that point outwards...    beach, plain, forest, hill, mountain, impassable mountains!

Some things to play around with here:

Rivers Int(Rnd * 10) + 1, Int(Rnd * 100) - 100, -3   -- First value is the number of rivers, second is how much they meander across the map, and the third is their starting depth.  Note that I haven't set any colors for a depth < -3.

In the fill sub, there's a section which you can play around with to increase density of various features:

    Select Case height
        Case Is < 0: RepeatChance = 33 'water repeat
        Case Is = 0: RepeatChance = 25 'beach repeat
        Case Is = 1: RepeatChance = 55 'grassland
        Case Is = 2: RepeatChance = 55 'forest
        Case Is = 3: RepeatChance = 40 ' hills
        Case Is = 4: RepeatChance = 33 'mountains
        Case Else
            RepeatChance = 50 - 3 * height
            If RepeatChance < 10 Then RepeatChance = 10
    End Select

The higher the numbers here, the more of the feature your map is going to have...

There's no Ocean on these maps, nor is there any lakes (I think lakes would be a nice addition, rather than just forcing multiple rivers to define the low points of the map), but I think this goes to show how I'd work on generating a map like this.   I'd start at the lowest point and then just expand outwards and upwards to my mountains.  ;)

  [ This attachment cannot be displayed inline in 'Print Page' view ]  

NOTE: Grab the taskbar header file for proper sizing from here: https://www.qb64.org/forum/index.php?topic=1020.msg138058#msg138058
Title: Re: ISO simple ASCII procedural terrain
Post by: bplus on November 11, 2021, 01:27:44 am
Here I am building Contours about Random Points:
Code: QB64: [Select]
  1. _Title "Build Contours about Rnd Pts - zzz... press any, esc to quit"
  2. _ScreenMove 400, 60
  4. tile(1) = "."
  5. tile(2) = "~"
  6. tile(3) = "="
  7. tile(4) = "o"
  8. tile(5) = "#"
  9.  
  11. Width 80, 80
  13.  
  15.     Cls
  16.     nP = Rnd * 7 + 3
  17.     ReDim pX(1 To nP), pY(1 To nP)
  18.     For i = 1 To nP
  19.         pX(i) = Rnd * _Width * .9 + .05 * _Width
  20.         pY(i) = Rnd * _Height * .9 + .05 * _Height
  21.     Next
  22.  
  23.     For level = 1 To 5
  24.         For i = 1 To nP
  25.             If Rnd < .5 Then dir = -1 Else dir = 1
  26.             x = pX(i) + dir * (Rnd * (6 - level) * 2)
  27.             If Rnd < .5 Then dir = -1 Else dir = 1
  28.             y = pY(i) + dir * (Rnd * (6 - level) * 2)
  29.             r = (Rnd * (6 - level) * 3) + 5 * (6 - level)
  30.             For row = y - r To y + r
  31.                 For col = x - r To x + r
  32.                     If row >= 1 And row <= _Height Then
  33.                         If col > 1 And col <= _Width Then
  34.                             If Sqr(((col - x) ^ 2) + (row - y) ^ 2) <= r Then
  35.                                 Locate row, col: Print tile(level);
  36.                             End If
  37.                         End If
  38.                     End If
  39.                 Next
  40.             Next
  41.  
  42.         Next
  43.     Next
  44.     Sleep
  46.  
  47.  
  48.  

  [ This attachment cannot be displayed inline in 'Print Page' view ]  
Title: Re: ISO simple ASCII procedural terrain
Post by: bplus on November 11, 2021, 01:31:53 am
Nice job Steve! but where is the Ascii? ;-))
Title: Re: ISO simple ASCII procedural terrain
Post by: bplus on November 11, 2021, 01:57:57 am
@SMcNeill

Here's feedback on where your screen ended up in my screen, the left side under my taskbar and the right side showing what's underneath about the width of the taskbar, beautiful image, your farm?

Title: Re: ISO simple ASCII procedural terrain
Post by: SMcNeill on November 11, 2021, 02:37:40 am
Quote from: bplus on November 11, 2021, 01:31:53 am
Nice job Steve! but where is the Ascii? ;-))

It's just a grid of a few various heights.  Map it to whatever ASCII colors/characters you want.  I used graphics so I could display it all.  ;)
Title: Re: ISO simple ASCII procedural terrain
Post by: SMcNeill on November 11, 2021, 02:40:10 am
Quote from: bplus on November 11, 2021, 01:57:57 am
@SMcNeill

Here's feedback on where your screen ended up in my screen, the left side under my taskbar and the right side showing what's underneath about the width of the taskbar, beautiful image, your farm?

I don't detect which border you have your taskbar snapped to, so just drag the screen right a bit for your display.  At least it seems properly sized right for everything.  ;)
Title: Re: ISO simple ASCII procedural terrain
Post by: SMcNeill on November 11, 2021, 07:21:07 am
Added Lakes into the mix.

Code: QB64: [Select]
  1. Const XSize = 200, YSize = 200
  2. Dim Shared As Long Grid(XSize, YSize)
  3.  
  4. DisplayScreen = MaxScreen
  5. Screen MaxScreen
  7.  
  10.  
  12.     InitializeMap
  13.     Lakecount = Int(Rnd * 4)
  14.     Lakes Lakecount, 400 - Lakecount * 100, 1000 - Lakecount * 300
  15.     Rivers Int(Rnd * 5) + 1, Int(Rnd * 100) - 100, -3
  16.  
  17.     GenerateTerrain
  18.  
  19.     DrawMap
  20.     Sleep
  22.  
  23. Sub InitializeMap
  24.     For x = 0 To XSize
  25.         For y = 0 To YSize
  26.             Grid(x, y) = -999 'default blank part of map
  27.         Next
  28.     Next
  30.  
  31.  
  32. Sub DrawMap
  33.     Dim kolor As _Unsigned Long
  34.     xscale = _Width / XSize
  35.     yscale = _Height / YSize
  36.     For x = 0 To XSize
  37.         For y = 0 To YSize
  38.             Select Case Grid(x, y)
  39.                 Case -3: kolor = DarkBlue 'Deep Water
  40.                 Case -2: kolor = Blue 'Water
  41.                 Case -1: kolor = SkyBlue 'Shallow Water
  42.                 Case 0: kolor = Tann 'beach/sand
  43.                 Case 1: kolor = Green 'grassland
  44.                 Case 2: kolor = DarkGreen 'forest
  45.                 Case 3: kolor = Gold 'hills
  46.                 Case 4: kolor = Purple 'mountains
  47.                 Case 5 TO 99: kolor = Red
  48.                 Case Else: kolor = Black
  49.             End Select
  50.             Line (x * xscale, y * yscale)-Step(xscale, yscale), kolor, BF
  51.     Next y, x
  53.  
  54.  
  55. Sub GenerateTerrain
  56.     Height = -3
  57.     Do Until finished
  58.         finished = -1
  59.         For x = 0 To XSize
  60.             For y = 0 To YSize
  61.                 If Grid(x, y) = Height Then Fill x, y, Height + 1: finished = 0
  62.             Next
  63.         Next
  64.         Height = Height + 1
  65.     Loop
  66.  
  68.  
  69. Sub Fill (x, y, height)
  70.     Select Case height
  71.         Case Is = -2: RepeatChance = 50 'water repeat
  72.         Case Is = -1: RepeatChance = 30 'shallow water repeat
  73.         Case Is = 0: RepeatChance = 25 'beach repeat
  74.         Case Is = 1: RepeatChance = 55 'grassland
  75.         Case Is = 2: RepeatChance = 55 'forest
  76.         Case Is = 3: RepeatChance = 50 ' hills
  77.         Case Is = 4: RepeatChance = 50 'mountains
  78.         Case Else
  79.             RepeatChance = 50 - 3 * height
  80.             If RepeatChance < 10 Then RepeatChance = 10
  81.     End Select
  82.     CurrentX = x
  83.     If CurrentX > 0 Then
  84.         If Grid(CurrentX - 1, y) = -999 Then
  85.             Grid(CurrentX - 1, y) = height
  86.             If Int(Rnd * 100) < RepeatChance Then Fill CurrentX - 1, y, height
  87.         End If
  88.     End If
  89.     CurrentX = x
  90.     If CurrentX < XSize Then
  91.         If Grid(CurrentX + 1, y) = -999 Then
  92.             Grid(CurrentX + 1, y) = height
  93.             If Int(Rnd * 100) < RepeatChance Then Fill CurrentX + 1, y, height
  94.         End If
  95.     End If
  96.     CurrentY = y
  97.     If CurrentY > 0 Then
  98.         If Grid(x, CurrentY - 1) = -999 Then
  99.             Grid(x, CurrentY - 1) = height
  100.             If Int(Rnd * 100) < RepeatChance Then Fill x, CurrentY - 1, height
  101.         End If
  102.     End If
  103.     CurrentY = y
  104.     If CurrentY < YSize Then
  105.         If Grid(x, CurrentY + 1) = -999 Then
  106.             Grid(x, y + 1) = height
  107.             If Int(Rnd * 100) < RepeatChance Then Fill x, CurrentY + 1, height
  108.         End If
  109.     End If
  111.  
  112. Sub Lakes (Number, MinSize, MaxSize)
  113.     For i = 1 To Number
  114.         x = Int(Rnd * XSize): y = Int(Rnd * YSize)
  115.         LakeSize = Int(Rnd * (MaxSize - MinSize)) + MinSize
  116.         LakeBuilt = 0
  117.         Do Until LakeBuilt >= LakeSize
  118.             xchange = 0: ychange = 0
  119.             Do
  120.                 Do
  121.                     xchange = Int(Rnd * 3) - 1
  122.                 Loop Until x + xchange > 0 And x + xchange < XSize
  123.                 Do
  124.                     ychange = Int(Rnd * 3) - 1
  125.                 Loop Until y + ychange > 0 And y + ychange < YSize
  126.             Loop Until xchange <> 0 And ychange <> 0
  127.             repeat:
  128.             If x + xchange < 0 Or x + xchange > XSize Then xchange = -xchange
  129.             If y + ychange < 0 Or y + ychange > YSize Then ychange = -ychange
  130.             If Grid(x + xchange, y + ychange) = -999 Then
  131.                 Grid(x + xchange, y + ychange) = -3
  132.                 LakeBuilt = LakeBuilt + 1
  133.                 x = x + xchange: y = y + ychange
  134.             Else
  135.                 flip = Int(Rnd * 2)
  136.                 If flip Then xchange = xchange * 2 Else ychange = ychange * 2
  137.                 GoTo repeat
  138.             End If
  139.         Loop
  140.     Next
  142.  
  143. Sub Rivers (Number, Meander, Deep)
  144.     For i = 1 To Number
  145.         flip1 = Int(Rnd * 2): flip2 = Int(Rnd * 2)
  146.         If flip1 Then 'entry point is on top
  147.             x1 = Int(Rnd * XSize): y1 = 0
  148.         Else 'entry point is on left
  149.             x1 = 0: y1 = Int(Rnd * YSize)
  150.         End If
  151.         If flip2 Then 'exit point is on bottom
  152.             x2 = Int(Rnd * XSize): y2 = YSize
  153.         Else 'exit point is on right
  154.             x2 = XSize: y2 = Int(Rnd * YSize)
  155.         End If
  156.  
  157.         Grid(x1, y1) = Deep: Grid(x2, y2) = Deep
  158.         StartX = x1: StartY = y1: EndX = x2: EndY = y2 'just to preserve our original values, if needed.
  159.         Do Until StartX = EndX And StartY = EndY
  160.             CoinToss = Int(Rnd * 100) 'Coin toss to move left/right or up/down, to go towards exit, or wander a bit.
  161.             Meander = 10
  162.             If CoinToss Mod 2 Then 'even or odd, so we only walk vertical or hortizontal and not diagional
  163.                 If CoinToss < 100 - Meander Then 'Lower values meander less and go directly to the target.
  164.                     XChange = Sgn(EndX - StartX) '-1,0,1, drawn always towards the mouse
  165.                     Ychange = 0
  166.                 Else
  167.                     XChange = Int(Rnd * 3) - 1 '-1, 0, or 1, drawn in a random direction to let the lightning wander
  168.                     Ychange = 0
  169.                 End If
  170.             Else
  171.                 If CoinToss < 100 - Meander Then 'Lower values meander less and go directly to the target.
  172.                     Ychange = Sgn(EndY - StartY)
  173.                     XChange = 0
  174.                 Else
  175.                     Ychange = Int(Rnd * 3) - 1
  176.                     XChange = 0
  177.                 End If
  178.             End If
  179.             StartX = StartX + XChange
  180.             StartY = StartY + Ychange
  181.             If StartX < 0 Then StartX = 0 'Make certain we move inside the bounds of our map dimensions
  182.             If StartY < 0 Then StartY = 0
  183.             If StartX > XSize Then StartX = XSize
  184.             If StartY > YSize Then StartY = YSize
  185.             Grid(StartX, StartY) = Deep 'place a river where we moved to
  186.         Loop
  187.     Next
  189.  
  190.  
  191.  
  192.  
  193.  
  194. Function MaxScreen
  195.     DH = _DesktopHeight: DW = _DesktopWidth
  196.     TBH = TaskbarHeight: TBW = TaskbarWidth
  197.     TH = TitleBarHeight: BW = BorderWidth
  198.     If TBH = DH Then TBH = 0 'Users taskbar is configured vertical, not hortizonal.
  199.     If TBW = DW Then TBW = 0
  200.     MaxScreen = _NewImage(DW - TBW - 2 * BW, DH - TBH - TH - BW * 2, 32)
  202.  
  203. Sub ScreenMove (x, y)
  204.     Do Until _Width <> 0 And _ScreenExists = -1: Loop
  205.     _ScreenMove x - BorderWidth, y - BorderWidth - TitleBarHeight
  207.  
  208. Sub ScreenMove_Middle
  209.     Do Until _Width <> 0 And _ScreenExists = -1: Loop
  210.     _ScreenMove (_DesktopWidth - _Width - BorderWidth) / 2 + 1, (_DesktopHeight - _Height - BorderWidth) / 2 - TitleBarHeight + 1
  212.  
  213. Function TaskbarHeight
  214.     Do Until _Width <> 0 And _ScreenExists = -1: Loop
  215.  
  216.     $If WIN Then
  217.         $If TASKBARDEC = UNDEFINED Then
  218.             $Let TASKBARDEC = TRUE
  219.             Declare Library "taskbar"
  220.                 Function taskbar_height& ()
  221.                 Function taskbar_width& ()
  222.             End Declare
  223.         $End If
  224.         TaskbarHeight = taskbar_height&
  225.     $Else
  226.         TaskbarHeight = 0 'no function to get the value for Linux/Mac, so return 0 instead of an error
  227.     $End If
  229.  
  230. Function TaskbarWidth
  231.     Do Until _Width <> 0 And _ScreenExists = -1: Loop
  232.     $If WIN Then
  233.         $If TASKBARDEC = UNDEFINED Then
  234.             $Let TASKBARDEC = TRUE
  235.  
  236.             Declare Library "taskbar"
  237.             Function taskbar_height& ()
  238.             Function taskbar_width& ()
  239.             End Declare
  240.         $End If
  241.         TaskbarWidth = taskbar_width&
  242.     $Else
  243.         TaskbarWidth = 0 'no function to get the value for Linux/Mac, so return 0 instead of an error
  244.     $End If
  246.  
  247.  
  248. Function TitleBarHeight
  249.     Do Until _Width <> 0 And _ScreenExists = -1: Loop
  250.     $If BORDERDEC = UNDEFINED Then
  251.         $Let BORDERDEC = TRUE
  252.         Declare Library
  253.             Function glutGet& (ByVal what&)
  254.         End Declare
  255.     $End If
  256.     TitleBarHeight = glutGet(507)
  258.  
  259. Function BorderWidth
  260.     Do Until _Width <> 0 And _ScreenExists = -1: Loop
  261.     $If BORDERDEC = UNDEFINED Then
  262.         $Let BORDERDEC = TRUE
  263.         Declare Library
  264.         Function glutGet& (ByVal what&)
  265.         End Declare
  266.     $End If
  267.     BorderWidth = glutGet(506)

  [ This attachment cannot be displayed inline in 'Print Page' view ]  

  [ This attachment cannot be displayed inline in 'Print Page' view ]  

I've got to admit, I think some of these end up looking rather nice.  (Of course, since almost everything is random here, some of these end up looking like complete garbage to me as well.)

Keep in mind, I'm creating massive 200 x 200 world maps with the settings the way I currently have them.  Also note, the actual game would probably be at a much larger scale with only small portions of it viewable by the player at a time.   I also don't know if I'd bother to use so many colors for water... Probably just shallow water (where you can wade in it) and deep water (where a boat travels) would be good enough.  My thinking behind 3 levels of water here was basically ocean ship, canoe/raft/shallow drag boat, and then wading/shallow water.

Anywho...   I'd call this a decent shot at a random terrain generator.  It doesn't follow any basic rules of logic, but it's decent enough I'm not ashamed to share it.  :P

If I was serious about this thing, I'd probably start at my mountains and then flow down to my oceans and not backwards like I did in this attempt, as that seems like it'd generate a more natural water flow from high to low.  I'd also try to work in things like temperature zones for the polar regions, and deserts for places which are too far away from any major source of water and would normally be plains instead.

Enough to showcase the basic idea behind things here, but it can definitely be expanded on if someone was wanting to.  ;D
Title: Re: ISO simple ASCII procedural terrain
Post by: xra7en on November 11, 2021, 11:07:49 pm
still....

you have something there.

gonna tinker with it, and post a couple of images. I think this might work for what I am looking for. Will have to do a little converting to ASCII (piece o cake :P)

wonder how Nox got MC almost perfect generating land! ??
Text Only | Text with Attachments