Show Posts

This section allows you to view all posts made by this member. Note that you can only see posts made in areas you currently have access to.


Topics - bplus

Pages: 1 2 [3] 4 5 ... 21
31
Programs / ArcRings
« on: December 23, 2021, 01:33:08 pm »
I saw on Discord today someone wanted Thick Circles, I call them Rings soon you will want thick Arcs too. We'll do ArcRings you will have both and they will work with transparent colors too.

Well here's all that, for raStart and raEnd, ra stands for Radian Angle (not degrees) Radian Angles are expressed in fractions of Pi eg Pi = 180 degrees and whole circle is 2*Pi so 1/10 of circle is 2*pi / 10 equivalent to 36 degrees.

Now I use Basic trig Sin(RadianAngle) and Cos(RadianAngle) that go around circle Clockwise as Radian Angle increases unlike Basic's Circle which goes opposite. So between the trig mention and Radian Angle mention I have probably lost most my audience ;-))

Anyway, it will be handy if you want a transparent color arc or ring and you understand what I am calling raStart and raEnd, I hope the rest is self explanatory:
Code: QB64: [Select]
  1. _Title "ArcRings  test" 'B+ 2019-02-21  for Raceman Sequence graphing
  2. ' 2021-12-23 reviewed remove confusing comments and test code then rewrote again for Option _Explicit
  3.  
  4. Screen _NewImage(1000, 700, 32)
  5. _ScreenMove 180, 20
  6.  
  7. While _KeyDown(27) = 0
  8.     i = i + 1
  9.     If i Mod 50 = 0 Then Cls: i = 0
  10.     ro = Rnd * 100 + 50: ri = ro - ro * Rnd - 10
  11.     ArcRing Rnd * 800 + 100, Rnd * 500 + 100, ro, ri, Rnd * _Pi(2), Rnd * _Pi(2), _RGBA32(255 * Rnd, 255 * Rnd, 255 * Rnd, 255 * Rnd)
  12.     _Display
  13.     _Limit 10
  15.  
  16. Sub ArcRing (x0, y0, outerR, innerR, raStart, raEnd, colr As _Unsigned Long)
  17.     Dim Pi2, Pi32, PiH, P, raS, raE, ck1, y, x, d, ra
  18.     Pi2 = _Pi(2)
  19.     Pi32 = _Pi(1.5)
  20.     PiH = _Pi(.5)
  21.     P = _Pi
  22.     raS = raStart ' checking raStart and raEnd to behave as expected
  23.     While raS >= Pi2
  24.         raS = raS - Pi2
  25.     Wend
  26.     While raS < 0
  27.         raS = raS + Pi2
  28.     Wend
  29.     raE = raEnd
  30.     While raE < 0
  31.         raE = raE + Pi2
  32.     Wend
  33.     While raE >= Pi2
  34.         raE = raE - Pi2
  35.     Wend
  36.     If raE > raS Then ck1 = -1
  37.     For y = y0 - outerR To y0 + outerR
  38.         For x = x0 - outerR To x0 + outerR
  39.             d = Sqr((x - x0) * (x - x0) + (y - y0) * (y - y0))
  40.             If d >= innerR And d <= outerR Then 'within 2 radii
  41.                 'angle of x, y to x0, y0
  42.                 If x - x0 <> 0 And y - y0 <> 0 Then
  43.                     ra = _Atan2(y - y0, x - x0)
  44.                     If ra < 0 Then ra = ra + Pi2
  45.                 ElseIf x - x0 = 0 Then
  46.                     If y >= y0 Then ra = _Pi / 2 Else ra = Pi32
  47.                 ElseIf y - y0 = 0 Then
  48.                     If x >= x0 Then ra = 0 Else ra = PI
  49.                 End If
  50.                 If ck1 Then 'raEnd > raStart
  51.                     If ra >= raS And ra <= raE Then
  52.                         PSet (x, y), colr
  53.                     End If
  54.                 Else 'raEnd < raStart, raEnd is falls before raStart clockwise so fill through 2 * PI
  55.                     If ra >= raS And ra < Pi2 Then
  56.                         PSet (x, y), colr
  57.                     Else
  58.                         If ra >= 0 And ra <= raE Then
  59.                             PSet (x, y), colr
  60.                         End If
  61.                     End If
  62.                 End If
  63.             End If
  64.         Next
  65.     Next
  67.  

 
ArcRing Test.PNG

32
Programs / Graphics Test #3D - are you certifiable?
« on: December 19, 2021, 11:53:34 am »
3D very popular these days, try a cube of cubes:
 
3D render #3 Cube of cubes step 1.PNG

 
3D render #3 Cube of cubes step 2.PNG

33
Programs / ❅ Snowflake Design
« on: December 04, 2021, 08:05:45 pm »
Needs some improvements:

Code: QB64: [Select]
  1. _Title "Snow Flake Design 1, click points inside triangle, e expand, c clear" ' B+ started 2018-12-07 for QB64
  2. Const XMAX = 700
  3. Const YMAX = 700
  4. Const white = &HFFFFFFFF
  5. Const black = &H0
  6. Const red = &HFFFF0000
  7. Screen _NewImage(XMAX, YMAX, 32)
  8. _ScreenMove 250, 20
  9. Dim Shared xc, yc, r, d6, datIndex, maxPoints
  10. xc = XMAX / 2: yc = YMAX / 2: r = .5 * YMAX * .025: d6 = _Pi(.166666666): maxPoints = 500
  11. Dim Shared aDat(1 To maxPoints), dDat(maxPoints)
  12. drawArea
  13. While _KeyDown(27) = 0
  14.     mx = -1: my = -1: q = 0
  15.     getClick mx, my, q
  16.     If q <> 0 Then
  17.         If Chr$(q) = "e" Then
  18.             Cls
  19.             For i = 0 To 5
  20.                 For j = 1 To datIndex
  21.                     x1 = xc + dDat(j) * YMAX * Cos(i * 2 * d6 + aDat(j))
  22.                     y1 = yc + dDat(j) * YMAX * Sin(i * 2 * d6 + aDat(j))
  23.                     fcirc x1, y1, r
  24.                     x1 = xc + dDat(j) * YMAX * Cos(i * 2 * d6 - aDat(j))
  25.                     y1 = yc + dDat(j) * YMAX * Sin(i * 2 * d6 - aDat(j))
  26.                     fcirc x1, y1, r
  27.                 Next
  28.             Next
  29.         ElseIf Chr$(q) = "q" Then
  30.             End
  31.         ElseIf Chr$(q) = "c" Then
  32.             Cls
  33.             drawArea
  34.             datIndex = 0
  35.         End If
  36.     Else
  37.         'clicked mx, my
  38.         a = _Atan2(my - yc, mx - xc)
  39.         If a >= 0 And a < d6 Then
  40.             scaleDist = (((mx - xc) ^ 2 + (my - yc) ^ 2) ^ .5) / YMAX
  41.             datIndex = datIndex + 1
  42.             aDat(datIndex) = a
  43.             dDat(datIndex) = scaleDist
  44.             fcirc xc + dDat(datIndex) * YMAX * Cos(aDat(datIndex)), yc + dDat(datIndex) * YMAX * Sin(aDat(datIndex)), r
  45.         End If
  46.     End If
  47.     _Display
  48.     _Limit 60
  50.  
  51. Sub drawArea
  52.     x1 = xc + .45 * YMAX * Cos(0)
  53.     y1 = yc + .45 * YMAX * Sin(0)
  54.     x2 = xc + .45 * YMAX * Cos(d6)
  55.     y2 = yc + .45 * YMAX * Sin(d6)
  56.     Line (xc, yc)-(x1, y1), red
  57.     Line (xc, yc)-(x2, y2), red
  58.     Line (x2, y2)-(x1, y1), red
  60.  
  61. Sub getClick (mx, my, q)
  62.     While _MouseInput: Wend ' clear previous mouse activity
  63.     mx = -1: my = -1: q = 0
  64.     Do While mx = -1 And my = -1
  65.         q = _KeyHit
  66.         If q = 27 Or (q > 31 And q < 126) Then Exit Sub
  67.         i = _MouseInput: mb = _MouseButton(1)
  68.         If mb Then
  69.             Do While mb 'wait for release
  70.                 q = _KeyHit
  71.                 If q = 27 Or (q > 31 And q < 126) Then Exit Sub
  72.                 i = _MouseInput: mb = _MouseButton(1): mx = _MouseX: my = _MouseY
  73.                 _Limit 1000
  74.             Loop
  75.             Exit Sub
  76.         End If
  77.         _Limit 1000
  78.     Loop
  80.  
  81. Sub fcirc (CX As Long, CY As Long, R As Long)
  82.     Dim subRadius As Long, RadiusError As Long
  83.     Dim X As Long, Y As Long
  84.  
  85.     subRadius = Abs(R)
  86.     RadiusError = -subRadius
  87.     X = subRadius
  88.     Y = 0
  89.  
  90.     If subRadius = 0 Then PSet (CX, CY): Exit Sub
  91.  
  92.     ' Draw the middle span here so we don't draw it twice in the main loop,
  93.     ' which would be a problem with blending turned on.
  94.     Line (CX - X, CY)-(CX + X, CY), , BF
  95.  
  96.     While X > Y
  97.         RadiusError = RadiusError + Y * 2 + 1
  98.         If RadiusError >= 0 Then
  99.             If X <> Y + 1 Then
  100.                 Line (CX - Y, CY - X)-(CX + Y, CY - X), , BF
  101.                 Line (CX - Y, CY + X)-(CX + Y, CY + X), , BF
  102.             End If
  103.             X = X - 1
  104.             RadiusError = RadiusError - X * 2
  105.         End If
  106.         Y = Y + 1
  107.         Line (CX - X, CY - Y)-(CX + X, CY - Y), , BF
  108.         Line (CX - X, CY + Y)-(CX + X, CY + Y), , BF
  109.     Wend
  111.  
  112.  

Step 1: dot triangle with ice molecules
 
step 1.PNG


Step 2: press e to expand
 
step 2 press e to expand.PNG



34
Programs / Graphics Test #2 - are you certifiable?
« on: November 29, 2021, 08:37:35 am »
Can you write code for this?
 
Globe - 2 branching.PNG

35
Programs / Turkey Day is around the corner
« on: November 24, 2021, 09:41:19 pm »
Code: QB64: [Select]
  1. _Title "Turkey Run" ' b+ mod 2021-11-24
  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.  
  8. Screen _NewImage(800, 600, 32)
  9. _ScreenMove 100, 20
  10.  
  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. tr = _LoadImage("turkey run.jpg")
  25. _ClearColor Point(10, 10), tr
  26. dir = 1.25
  27. While _KeyDown(27) = 0 't < 6000
  28.     Cls
  29.     For i = 1 To nLevels
  30.         If para(i).le + 800 > scapeWidth Then
  31.             te = scapeWidth - para(i).le
  32.             _PutImage (0, 0)-(te, scapeHeight), para(i).handle, 0, (scapeWidth - te, 0)-(scapeWidth, scapeHeight)
  33.             _PutImage (te, 0)-(800, scapeHeight), para(i).handle, 0, (0, 0)-(800 - te, scapeHeight)
  34.  
  35.         Else
  36.             _PutImage (0, 0)-(800, scapeHeight), para(i).handle, 0, (para(i).le, 0)-(para(i).le + 800, scapeHeight)
  37.         End If
  38.  
  39.         para(i).le = para(i).le - para(i).rate
  40.         If para(i).le < 0 Then para(i).le = scapeWidth
  41.     Next
  42.     _PutImage (350, 500 + down)-Step(111, 93), tr, 0, (0, 0)-(_Width(tr), _Height(tr) - 30)
  43.     t = t + 1
  44.     down = down + dir
  45.     If down > 37 Then down = 37: dir = -dir
  46.     If down < 13 Then down = 13: dir = -dir
  47.     _Display
  48.     _Limit 120
  50.  
  51. Sub LoadLandscape
  52.     cur& = _Dest
  53.     xmax = 800 * 3.25: ymax = 600
  54.     hdl& = 1
  55.     para(hdl&).handle = _NewImage(xmax, ymax, 32)
  56.     _Dest para(hdl&).handle
  57.  
  58.     For i = 0 To ymax
  59.         midInk 0, 0, 128, 128, 128, 200, i / ymax
  60.         Line (0, i)-(xmax, i)
  61.     Next
  62.     'the land
  63.     startH = ymax - 250
  64.     rr = 70: gg = 70: bb = 90
  65.     For mountain = 1 To nLevels
  66.         If mountain > 1 Then
  67.             para(mountain).handle = _NewImage(xmax, ymax, 32)
  68.             _Dest para(mountain).handle
  69.         End If
  70.         Xright = 0
  71.         y = startH
  72.         Color _RGB(rr, gg, bb)
  73.         While Xright < xmax - 50
  74.             ' upDown = local up / down over range, change along Y
  75.             ' range = how far up / down, along X
  76.             upDown = (Rnd * .8 - .4) * (mountain * .5)
  77.             range = Xright + rand%(15, 25) * 2.5 / mountain
  78.             If range > xmax - 50 Then range = xmax - 50
  79.             lastx = Xright - 1
  80.             For x = Xright To range 'need less flat tops
  81.                 test = y + upDown
  82.                 test2 = y - upDown
  83.                 If Abs(test - startH) < .13 * startH Then y = test Else y = test2: upDown = -upDown
  84.                 Line (lastx, y)-(x, ymax), , BF 'just lines weren't filling right
  85.                 lastx = x
  86.             Next
  87.             Xright = range
  88.         Wend
  89.         x = lastx + 1
  90.         dy = (startH - y) / 50 'more gentle adjustment back to start of screen
  91.         While x <= xmax
  92.             y = y + dy
  93.             Line (lastx, y)-(x, ymax), , BF 'just lines weren't filling right
  94.             lastx = x
  95.             x = x + 1
  96.         Wend
  97.         rr = rand%(rr + 50, rr + 30): gg = rand%(gg + 50, gg + 30): bb = rand%(bb + 50, bb + 30)
  98.         If rr < 0 Then rr = 0
  99.         If gg < 0 Then gg = 0
  100.         If bb < 0 Then bb = 0
  101.         startH = startH + mountain * rand%(2, 10)
  102.         para(mountain).le = xmax - 800
  103.         para(mountain).rate = mountain * .5
  104.     Next
  105.     _Dest cur&
  107.  
  108. Function rand% (lo%, hi%)
  109.     rand% = Int(Rnd * (hi% - lo% + 1)) + lo%
  111.  
  112. Sub midInk (r1%, g1%, b1%, r2%, g2%, b2%, fr##)
  113.     Color _RGB(r1% + (r2% - r1%) * fr##, g1% + (g2% - g1%) * fr##, b1% + (b2% - b1%) * fr##)
  115.  
  116.  

You will need the image in the zip:

36
Programs / Graphics Test #1 Are You Certifiable?
« on: November 21, 2021, 01:32:26 pm »
Create this Pattern:
 
Cert Test #1.PNG


Too easy? Here's 2 mods:
 
Shrinking Chess Patterns.PNG

37
Programs / Even Better Stars
« on: November 18, 2021, 04:33:17 pm »
Souping up some old SdlBasic code:
Code: QB64: [Select]
  1. _Title "Even Better Stars" 'b+ 2021-11-18 trans of
  2. 'Better Stars.sdlbas (B+=MGA) 2016-05-16
  3. ' odd or even number of point, fat or skinny, better fills
  4.  
  5. Const Pi = _Acos(-1) 'cute way to get pi
  6. 'Print (Pi) 'check pi
  7. 'End
  8. Const Radians = Pi / 180 'to convert an angle measured in degrees to and angle measure in radians, just mutiply by this
  9. Const Xmax = 700
  10. Const Ymax = 700
  11. Const Cx = Xmax / 2
  12. Const Cy = Ymax / 2
  13.  
  14. 'setdisplay(xmax, ymax, 32, 1)
  15. Screen _NewImage(Xmax, Ymax, 32)
  16. _ScreenMove 300, 40
  17. 'setcaption("Better Stars demo")
  18. 'autoback(-2)
  19.  
  20. 'main
  21. Const NS = 100
  22. Dim Shared x(NS), y(NS), dx(NS), dy(NS), ri(NS), ro(NS), p(NS), a(NS), turn(NS), fill(NS), c(NS) As _Unsigned Long
  23. loopcounter = 0
  24. For i = 0 To NS
  25.     NewStar i
  27. While _KeyDown(27) = 0
  28.     Line (0, 0)-(Xmax, Ymax), _RGB32(0, 0, 0, 30), BF
  29.     For i = 0 To NS
  30.         If x(i) > 0 And x(i) < Xmax And y(i) > 0 And y(i) < Ymax Then
  31.             'ink(colr(c(i)))
  32.             Color c(i)
  33.             Star x(i), y(i), ri(i), ro(i), p(i), a(i), fill(i)
  34.             x(i) = x(i) + dx(i)
  35.             y(i) = y(i) + dy(i)
  36.             ri(i) = 1.015 * ri(i)
  37.             ro(i) = 1.015 * ro(i)
  38.             a(i) = a(i) + turn(i)
  39.         Else
  40.             NewStar i
  41.         End If
  42.     Next
  43.     'screenswap
  44.     _Display
  45.     _Limit 100
  46.     'wait(50)
  47.     loopcounter = loopcounter + 1
  49.  
  50.  
  51. Sub NewStar (nxt)
  52.     angle = Rnd * 2 * Pi
  53.     r = Rnd * 6 + 1
  54.     dx(nxt) = r * Cos(angle)
  55.     dy(nxt) = r * Sin(angle)
  56.     r = Rnd * 300
  57.     x(nxt) = Cx + r * dx(nxt)
  58.     y(nxt) = Cy + r * dy(nxt)
  59.     ri(nxt) = Rnd
  60.     ro(nxt) = ri(nxt) + 1 + Rnd
  61.     p(nxt) = 3 + Int(Rnd * 9)
  62.     a(nxt) = Rnd * 2 * Pi
  63.     turn(nxt) = Rnd * 6 - 3
  64.     fill(nxt) = Int(Rnd * 2)
  65.     c(nxt) = rndColor~&
  67.  
  68. Function rndColor~& ()
  69.     rndColor~& = _RGB32(Rnd * 255, Rnd * 255, Rnd * 255)
  71.  
  72. Sub Star (x, y, rInner, rOuter, nPoints, angleOffset, TFfill)
  73.     ' x, y are same as for circle,
  74.     ' rInner is center circle radius
  75.     ' rOuter is the outer most point of star
  76.     ' nPoints is the number of points,
  77.     ' angleOffset = angle offset IN DEGREES, it will be converted to radians in sub
  78.     ' this is to allow us to spin the polygon of n sides
  79.     ' TFfill filled True or False (1 or 0)
  80.     p_angle = Radians * (360 / nPoints): rad_angle_offset = Radians * angleOffset
  81.     x1 = x + rInner * Cos(rad_angle_offset)
  82.     y1 = y + rInner * Sin(rad_angle_offset)
  83.     For i = 0 To nPoints - 1
  84.         x2 = x + rOuter * Cos(i * p_angle + rad_angle_offset + .5 * p_angle)
  85.         y2 = y + rOuter * Sin(i * p_angle + rad_angle_offset + .5 * p_angle)
  86.         x3 = x + rInner * Cos((i + 1) * p_angle + rad_angle_offset)
  87.         y3 = y + rInner * Sin((i + 1) * p_angle + rad_angle_offset)
  88.         Line (x1, y1)-(x2, y2)
  89.         Line (x2, y2)-(x3, y3)
  90.         x1 = x3: y1 = y3
  91.     Next
  92.     If TFfill Then
  93.         'Circle (x, y), 2, &HFFFFFFFF
  94.         Paint (x, y), _DefaultColor, _DefaultColor
  95.     End If
  97.  
  98.  

38
Programs / Contour Plot
« on: November 16, 2021, 08:52:56 pm »
Ah, found some Contour plot code from SdlBasic which turns out started at Q B 6 4 .net [abandoned, outdated and now likely malicious qb64 dot net website - don’t go there] by Mrwhy.

Here's how I found it SdlBasic Forum:
Code: [Select]
        ' Contour plot using Data Points by Mrwhy
       'ref: SdlBasic forum, AndyA, 9-13-2016  http://sdlbasic.epizy.com/showthread.php?tid=302

'http://www.[abandoned, outdated and now likely malicious qb64 dot net website - don’t go there]/forum/index.php?topic=3714.msg37019#msg37019
'https://en.wikipedia.org/wiki/Richard_V._Southwell
'https://en.wikipedia.org/wiki/Relaxation_(iterative_method)

Option QBASIC
Common sw, sh
'============================
' change size of output screen here
'============================
smallPlot = 1
'============================
If smallPlot = 1 Then
    'take about 25 secs to calc
    sw = 240 : sh = 240
Else
    'large plot takes over 2 minutes to calc
    sw = 640 : sh = 480
End If

SetDisplay(sw, sh, 32, 1)
SetCaption("Contour Map")

Dim pal[23], x[50], y[50], z[100], E[50], h[sw, sh]

'red to yellow palette
pal[0]  = 0        : pal[1]  = 0x800000
pal[2]  = 0xA00000 : pal[3]  = 0xC00000
pal[4]  = 0xD00000 : pal[5]  = 0xFF0000
pal[6]  = 0xFF2000 : pal[7]  = 0xFF4000
pal[8]  = 0xFF6000 : pal[9]  = 0xFF8000
pal[10] = 0xFFA000 : pal[11] = 0xFFC000
pal[12] = 0xFFE000 : pal[13] = 0xFFFF00
pal[14] = 0xFFFF20 : pal[15] = 0xFFFF40

'============================================
' number of height/potential points in data
'============================================
numPoints = 16
'============================================

If smallPlot = 1 Then
    x[1]  = 161 : y[1]  = 120 : z[1]  = 11
    x[2]  =  80 : y[2]  =  80 : z[2]  =  9
    x[3]  =  40 : y[3]  =  40 : z[3]  =  6
    x[4]  = 122 : y[4]  =  20 : z[4]  =  3
    x[5]  = 117 : y[5]  =  72 : z[5]  =  4
    x[6]  = 178 : y[6]  = 124 : z[6]  =  7
    x[7]  = 140 : y[7]  = 173 : z[7]  =  9
    x[8]  = 194 : y[8]  =  38 : z[8]  = 13
    x[9]  =  65 : y[9]  =  65 : z[9]  = 12
    x[10] = 135 : y[10] =  60 : z[10] =  9
    x[11] = 180 : y[11] = 160 : z[11] =  8
    x[12] =  70 : y[12] = 135 : z[12] = 11
    x[13] = 165 : y[13] = 150 : z[13] =  6
    x[14] = 225 : y[14] =  90 : z[14] =  2
    x[15] = 190 : y[15] = 178 : z[15] = 12
    x[16] = 135 : y[16] = 135 : z[16] = 10
Else
    x[1]  = 279: y[1]  = 220: z[1]  = 11    '1
    x[2]  = 160: y[2]  = 160: z[2]  =  9    '2
    x[3]  =  80: y[3]  =  80: z[3]  =  6    '3
    x[4]  = 144: y[4]  =  40: z[4]  =  7    '4
    x[5]  = 350: y[5]  = 158: z[5]  =  4    '5
    x[6]  = 356: y[6]  = 248: z[6]  =  7    '6
    x[7]  = 280: y[7]  = 347: z[7]  =  9    '7
    x[8]  = 370: y[8]  =  39: z[8]  = 13    '8
    x[9]  = 130: y[9]  = 230: z[9]  = 12    '9
    x[10] = 270: y[10] = 120: z[10] =  9    '10
    x[11] = 360: y[11] = 320: z[11] =  8    '11
    x[12] = 140: y[12] = 270: z[12] = 11    '12
    x[13] = 530: y[13] = 300: z[13] =  6    '13
    x[14] = 458: y[14] = 143: z[14] =  2    '14
    x[15] = 380: y[15] = 370: z[15] = 12    '15
    x[16] = 270: y[16] = 270: z[16] = 10    '16
End If

ztot = 0
'display height or potential data points on screen
For i = 1 To numPoints
    Ink (pal[z[i]])
   FillCircle (x[i], sh - y[i], 3)
   ztot = ztot + z[i]
Next

Ink(0xFFFF40)
Text(48,2,12,"Calculating contour map")
Box(40, 1, 212, 16)
WaitVBL

'initialize some variables
zmean = ztot / numPoints
wo = sw * sh / numPoints
w = wo / 2.0

'generate initial Error estimates
For i = 1 To numPoints
   E[i] = z[i] - zmean
Next
Legend()
WaitVBL

'begin Relaxation (iterative method)
For jj = 1 To 9 * numPoints 'find max error point
   emax = 0
   For i = 1 To numPoints
       If Abs(E[i]) > emax Then
            emax = Abs(E[i])
            ii = i
        End If
       k = E[ii]
   Next
   'fixit
   For i = 1 To numPoints
       dx = x[i] - x[ii]
       dy = y[i] - y[ii]
       dsq = dx * dx + dy * dy
       E[i] = E[i] - k * Exp(-(dsq / w))
       IF i = ii Then
            'update map with revised height or potential estimates for each pixel
           For fy = 1 To (sh-1)
               For fx = 1 To (sw-1)
                   dx = fx - x[ii]
                   dy = fy - y[ii]
                   dsq2 = dx * dx + dy * dy
                    dy = sh-fy
                   h[fx, dy] = h[fx, dy] + k * Exp(-(dsq2 / w))
               Next
           Next
       End If
   Next
Next

'Draw calculated contour map
Ink(pal[h[1,1]+zmean])
Line(0,0,sw-1,0)
Line(0,0,0,sh-1)
For fy = 1 To sh-1
   For fx = 1 To sw-1
       clr = pal[h[fx, fy] + zmean]
       Plot (fx, fy, clr)
   Next
Next

'display height or potential data points on contour map
For i = 1 To numPoints
    clr = pal[z[i]]
    Ink(0)
   FillCircle (x[i], sh - y[i], 3)
    Ink(clr)
    FillCircle (x[i], sh - y[i], 2)
Next
Legend()

Waitkey(27)
End

'show height or potential value for each color in map
Sub Legend()
Ink(0xFFFF40)
Text(5, 45, 10, "Key")
posy = 58
For nn = 1 To 15
    Ink(0xFFFF40)
    Text(0, posy, 10, Str$(nn))
    Ink(0)
   Bar(14, posy + 3, 30, posy + 9)
    Ink(pal[nn])
   Bar (16, posy + 5, 28, posy + 7)
   posy = posy + 12
Next
End Sub


And my QB64 translation, mostly changing the Legend:
Code: QB64: [Select]
  1. _Title "Contour Map" 'b+ trans from SdlBasic to QB64, original from [abandoned, outdated and now likely malicious qb64 dot net website - don’t go there]
  2.  
  3. ' Contour plot using Data Points by Mrwhy
  4. 'ref: SdlBasic forum, AndyA, 9-13-2016  http://sdlbasic.epizy.com/showthread.php?tid=302
  5. ' AndyA ref:
  6. 'http://www.[abandoned, outdated and now likely malicious qb64 dot net website - don’t go there]/forum/index.php?topic=3714.msg37019#msg37019
  7. 'https://en.wikipedia.org/wiki/Richard_V._Southwell
  8. 'https://en.wikipedia.org/wiki/Relaxation_(iterative_method)
  9.  
  10. Dim Shared sw, sh
  11. '============================
  12. ' change size of output screen here
  13. '============================
  14. smallPlot = 0
  15. '============================
  16. If smallPlot = 1 Then
  17.     'take about 25 secs to calc
  18.     sw = 240: sh = 240
  20.     'large plot takes over 2 minutes to calc
  21.     sw = 640: sh = 480
  23.  
  24. Screen _NewImage(sw, sh, 32)
  25. _ScreenMove 300, 100
  26.  
  27. Dim Shared pal(23) As _Unsigned Long, x(50), y(50), z(100), E(50), h(sw, sh)
  28.  
  29. 'red to yellow palette
  30. pal(0) = &HFF000000: pal(1) = &HFF800000
  31. pal(2) = &HFFA00000: pal(3) = &HFFC00000
  32. pal(4) = &HFFD00000: pal(5) = &HFFFF0000
  33. pal(6) = &HFFFF2000: pal(7) = &HFFFF4000
  34. pal(8) = &HFFFF6000: pal(9) = &HFFFF8000
  35. pal(10) = &HFFFFA000: pal(11) = &HFFFFC000
  36. pal(12) = &HFFFFE000: pal(13) = &HFFFFFF00
  37. pal(14) = &HFFFFFF20: pal(15) = &HFFFFFF40
  38.  
  39. '============================================
  40. ' number of height/potential points in data
  41. '============================================
  42. numPoints = 16
  43. '============================================
  44.  
  45. If smallPlot = 1 Then
  46.     x(1) = 161: y(1) = 120: z(1) = 11
  47.     x(2) = 80: y(2) = 80: z(2) = 9
  48.     x(3) = 40: y(3) = 40: z(3) = 6
  49.     x(4) = 122: y(4) = 20: z(4) = 3
  50.     x(5) = 117: y(5) = 72: z(5) = 4
  51.     x(6) = 178: y(6) = 124: z(6) = 7
  52.     x(7) = 140: y(7) = 173: z(7) = 9
  53.     x(8) = 194: y(8) = 38: z(8) = 13
  54.     x(9) = 65: y(9) = 65: z(9) = 12
  55.     x(10) = 135: y(10) = 60: z(10) = 9
  56.     x(11) = 180: y(11) = 160: z(11) = 8
  57.     x(12) = 70: y(12) = 135: z(12) = 11
  58.     x(13) = 165: y(13) = 150: z(13) = 6
  59.     x(14) = 225: y(14) = 90: z(14) = 2
  60.     x(15) = 190: y(15) = 178: z(15) = 12
  61.     x(16) = 135: y(16) = 135: z(16) = 10
  63.     x(1) = 279: y(1) = 220: z(1) = 11 '1
  64.     x(2) = 160: y(2) = 160: z(2) = 9 '2
  65.     x(3) = 80: y(3) = 80: z(3) = 6 '3
  66.     x(4) = 144: y(4) = 40: z(4) = 7 '4
  67.     x(5) = 350: y(5) = 158: z(5) = 4 '5
  68.     x(6) = 356: y(6) = 248: z(6) = 7 '6
  69.     x(7) = 280: y(7) = 347: z(7) = 9 '7
  70.     x(8) = 370: y(8) = 39: z(8) = 13 '8
  71.     x(9) = 130: y(9) = 230: z(9) = 12 '9
  72.     x(10) = 270: y(10) = 120: z(10) = 9 '10
  73.     x(11) = 360: y(11) = 320: z(11) = 8 '11
  74.     x(12) = 140: y(12) = 270: z(12) = 11 '12
  75.     x(13) = 530: y(13) = 300: z(13) = 6 '13
  76.     x(14) = 458: y(14) = 143: z(14) = 2 '14
  77.     x(15) = 380: y(15) = 370: z(15) = 12 '15
  78.     x(16) = 270: y(16) = 270: z(16) = 10 '16
  80.  
  81. ztot = 0
  82. 'display height or potential data points on screen
  83. For i = 1 To numPoints
  84.     fcirc x(i), sh - y(i), 3, pal(z(i))
  85.     ztot = ztot + z(i)
  87.  
  88. Color &HFFFFFF40
  90.  
  91. s$ = "Calculating Contour Map"
  92. x = (_Width - _PrintWidth(s$)) / 2
  93. _PrintString (x, _Height - 14), s$
  94. Line (x - 4, _Height - 18)-(x + _PrintWidth(s$) + 2, _Height - 2), , B
  95.  
  96. 'initialize some variables
  97. zmean = ztot / numPoints
  98. wo = sw * sh / numPoints
  99. w = wo / 2.0
  100.  
  101. 'generate initial Error estimates
  102. For i = 1 To numPoints
  103.     E(i) = z(i) - zmean
  105. Legend
  106.  
  107. 'begin Relaxation (iterative method)
  108. For jj = 1 To 9 * numPoints 'find max error point
  109.     emax = 0
  110.     For i = 1 To numPoints
  111.         If Abs(E(i)) > emax Then
  112.             emax = Abs(E(i))
  113.             ii = i
  114.         End If
  115.         k = E(ii)
  116.     Next
  117.     'fixit
  118.     For i = 1 To numPoints
  119.         dx = x(i) - x(ii)
  120.         dy = y(i) - y(ii)
  121.         dsq = dx * dx + dy * dy
  122.         E(i) = E(i) - k * Exp(-(dsq / w))
  123.         If i = ii Then
  124.             'update map with revised height or potential estimates for each pixel
  125.             For fy = 1 To (sh - 1)
  126.                 For fx = 1 To (sw - 1)
  127.                     dx = fx - x(ii)
  128.                     dy = fy - y(ii)
  129.                     dsq2 = dx * dx + dy * dy
  130.                     dy = sh - fy
  131.                     h(fx, dy) = h(fx, dy) + k * Exp(-(dsq2 / w))
  132.                 Next
  133.             Next
  134.         End If
  135.     Next
  137.  
  138. 'Draw calculated contour map
  139. Color pal(h(1, 1) + zmean)
  140. Line (0, 0)-(sw - 1, 0)
  141. Line (0, 0)-(0, sh - 1)
  142. For fy = 1 To sh - 1
  143.     For fx = 1 To sw - 1
  144.         PSet (fx, fy), pal(h(fx, fy) + zmean)
  145.     Next
  147.  
  148. 'display height or potential data points on contour map
  149. For i = 1 To numPoints
  150.     fcirc x(i), sh - y(i), 3, pal(0)
  151.     fcirc x(i), sh - y(i), 2, pal(z(i))
  153. Legend
  156.  
  157. 'show height or potential value for each color in map
  158. Sub Legend
  159.     posy = 20
  160.     ' just draw a balck box where legend is going
  161.     Line (0, 0)-(37, 200), pal(0), BF
  162.     Line (1, 1)-(36, 199), &HFFFFFF40, B
  163.     Color &HFFFFFF40
  164.     _Font 8
  165.     _PrintString (7, 3), "Key"
  166.     For nn = 1 To 15
  167.         Color &HFFFFFF40
  168.         _PrintString (4, posy), Right$(" " + _Trim$(Str$(nn)), 2)
  169.         Line (21, posy + 1)-(32, posy + 5), pal(nn), BF
  170.         posy = posy + 12
  171.     Next
  173.  
  174. Sub fcirc (CX As Long, CY As Long, R As Long, C As _Unsigned Long)
  175.     Dim Radius As Long, RadiusError As Long
  176.     Dim X As Long, Y As Long
  177.     Radius = Abs(R): RadiusError = -Radius: X = Radius: Y = 0
  178.     If Radius = 0 Then PSet (CX, CY), C: Exit Sub
  179.     Line (CX - X, CY)-(CX + X, CY), C, BF
  180.     While X > Y
  181.         RadiusError = RadiusError + Y * 2 + 1
  182.         If RadiusError >= 0 Then
  183.             If X <> Y + 1 Then
  184.                 Line (CX - Y, CY - X)-(CX + Y, CY - X), C, BF
  185.                 Line (CX - Y, CY + X)-(CX + Y, CY + X), C, BF
  186.             End If
  187.             X = X - 1
  188.             RadiusError = RadiusError - X * 2
  189.         End If
  190.         Y = Y + 1
  191.         Line (CX - X, CY - Y)-(CX + X, CY - Y), C, BF
  192.         Line (CX - X, CY + Y)-(CX + X, CY + Y), C, BF
  193.     Wend
  195.  
  196.  

 
Contour Map.PNG

39
Programs / Optical Illusion with Sinc() ?
« on: November 12, 2021, 05:24:49 pm »
Playing around with sinc()...

Code: QB64: [Select]
  1. _Title "Does this light turn yellow?" 'b+ 2021-11-12
  2.  
  3. Screen _NewImage(600, 600, 32)
  4. _ScreenMove 350, 60
  6.     Cls
  7.     For r = 0 To 300
  8.         Circle (300, 300), r, _RGB32(i * Sin(r) / r) ' checking out sinc()
  9.     Next
  10.     i = i + 10
  11.     _Display
  12.     _Limit 60
  14.  

40
Programs / Ascii Plasma!
« on: November 11, 2021, 03:16:00 am »
Look what I found trying to build isobar / contour lines!

Code: QB64: [Select]
  1. _Title  "Ansii Plasma - press spacebar for new set of points, be sure to swirl your mouse in the stuff!"  ' b+ 2021-11-11
  2. _ScreenMove 100, 40
  3.  
  4. Type xy
  5.     x As Single
  6.     y As Single
  7.     dx As Single
  8.     dy As Single
  10.  
  12. Width 150, 80
  14.  
  15. nP = 6
  16. Dim p(1 To nP) As xy, f(6)
  17.  
  18. restart:
  19. For n = 1 To nP
  20.     p(n).x = Rnd * _Width: p(n).y = Rnd * _Height: p(n).dx = .25 * (Rnd * 2 - 1): p(n).dy = 2 * (Rnd * 2 - 1)
  21.     f(n) = n * .015
  23.  
  24. While _KeyDown(27) = 0
  25.     Cls
  26.     If InKey$ = " " Then GoTo restart
  27.     For i = 1 To nP - 1
  28.         p(i).x = p(i).x + p(i).dx
  29.         If p(i).x > _Width - 1 Or p(i).x < 1 Then p(i).dx = -p(i).dx
  30.         If p(i).x < 1 Then p(i).x = 1: If p(i).x > _Width Then p(i).x = _Width
  31.         p(i).y = p(i).y + p(i).dy
  32.         If p(i).y > _Height Or p(i).y < 1 Then p(i).dy = -p(i).dy
  33.         If p(i).y < 1 Then p(i).y = 1: If p(i).y > _Height Then p(i).y = _Height
  34.     Next
  36.     p(nP).x = _MouseX: p(nP).y = _MouseY
  37.     For y = 1 To _Height
  38.         For x = 1 To _Width
  39.             d = 0
  40.             For n = 1 To nP
  41.                 dx = x - p(n).x: dy = y - p(n).y
  42.                 k = Sqr(dx * dx + dy * dy)
  43.                 d = d + (Sin(k * f(n)) + 1) / 2
  44.             Next
  45.             Locate y, x: Print Chr$(Int(d * 20));
  46.         Next
  47.     Next
  48.     _Display
  49.     _Limit 40
  51.  
  52.  
  53.  

41
Programs / Stars (Number guessing program)
« on: November 06, 2021, 11:06:35 pm »
I found this program surfing old Basic code and wondered what it was about:
Code: QB64: [Select]
  1. 10 Print Tab(34); "STARS"
  2. 20 Print Tab(15); "CREATIVE COMPUTING  MORRISTOWN, NEW JERSEY"
  4. 100 Rem *** STARS - PEOPLE'S COMPUTER CENTER, MENLO PARK, CA
  5. 140 Rem *** A IS LIMIT ON NUMBER, M IS NUMBER OF GUESSES
  6. 150 A = 100: M = 7
  7. 170 Input "DO YOU WANT INSTRUCTIONS"; A$
  8. 190 If Left$(A$, 1) = "N" Then 280
  9. 200 Rem *** INSTRUCTIONS ON HOW TO PLAY
  10. 210 Print "I AM THINKING OF A WHOLE NUMBER FROM 1 TO"; A
  11. 220 Print "TRY TO GUESS MY NUMBER.  AFTER YOU GUESS, I"
  12. 230 Print "WILL TYPE ONE OR MORE STARS (*).  THE MORE"
  13. 240 Print "STARS I TYPE, THE CLOSER YOU ARE TO MY NUMBER."
  14. 250 Print "ONE STAR (*) MEANS FAR AWAY, SEVEN STARS (*******)"
  15. 260 Print "MEANS REALLY CLOSE!  YOU GET"; M; "GUESSES."
  16. 270 Rem *** COMPUTER THINKS OF A NUMBER
  17. 280 Print
  18. 290 Print
  19. 300 X = Int(A * Rnd(1) + 1)
  20. 310 Print "OK, I AM THINKING OF A NUMBER, START GUESSING."
  21. 320 Rem *** GUESSING BEGINS, HUMAN GETS M GUESSES
  22. 330 For K = 1 To M
  23.    340 Print
  24.    350 Print "YOUR GUESS";
  25.    360 Input G
  26.    370 If G = X Then 600
  27.    380 D = Abs(G - X)
  28.    390 If D >= 64 Then 510
  29.    400 If D >= 32 Then 500
  30.    410 If D >= 16 Then 490
  31.    420 If D >= 8 Then 480
  32.    430 If D >= 4 Then 470
  33.    440 If D >= 2 Then 460
  34.    450 Print "*";
  35.    460 Print "*";
  36.    470 Print "*";
  37.    480 Print "*";
  38.    490 Print "*";
  39.    500 Print "*";
  40.    510 Print "*";
  41.    520 Print
  42. 530 Next K
  43. 540 Rem *** DID NOT GUESS IN M GUESSES
  44. 550 Print
  45. 560 Print "SORRY, THAT'S"; M; "GUESSES. THE NUMBER WAS"; X
  46. 580 GoTo 650
  47. 590 Rem *** WE HAVE A WINNER
  48. 600 Print: For N = 1 To 79
  49.    610 Print "*";
  50. 620 Next N
  52. 640 Print "YOU GOT IT IN"; K; "GUESSES!!!  LET'S PLAY AGAIN..."
  53. 650 GoTo 280
  54. 660 End
  55.  
  56.  

I translated to more modern Basic and learned a little about LOGs.
Code: QB64: [Select]
  1. _Title "Stars: Guess number 1 to 100, get star rating 1 to 7, get 7 guesses, ...zzz = press any." 'b+ 2021-11-06
  2. 1 Cls: Randomize Timer: GoSub StarChart ' start over
  3. N = Int(100 * Rnd) + 1: nG = 1: Print ' N 'secret number : nG = number of guesses up to 7 allowed
  4. 2 Print " Guess #"; _Trim$(Str$(nG));: Input " enter > ", G
  5. If G = N Then Print "That's it in"; nG; "guesses...zzz": Sleep: GoTo 1
  6. Print " Rating: "; String$(7 - Int(Log(Abs(G - N)) / Log(2)), "* ")
  7. If nG = 7 Then Print "Sorry, that's 7 guesses, the number was"; N; "...zzz": Sleep: GoTo 1
  8. nG = nG + 1: GoTo 2 ' another guess
  9. StarChart: ' number of stars for number you are off
  10. Print Spc(35); "Star Chart:"
  11. For i = 1 To 100 ' this also tests my formula to compare to original game
  12.     If 7 - Int(Log(i) / Log(2)) <> last Then Print Spc(28); "For"; 7 - Int(Log(i) / Log(2)); "Stars, min off ="; i
  13.     last = 7 - Int(Log(i) / Log(2))
  16.  
  17. 'Test code for Star Chart LOG and convert to LOG(2) to convert to Star Rating
  18. 'For p = 0 To 6
  19. '    Print p, Log(2 ^ p) / Log(2) ' yes! When you are of 2 ^ x from number you get 7 - x stars
  20. 'Next
  21.  
  22.  

With the help of the Star Chart (and rewriting the program) it's not hard to pick up the strategy to play the game and usually get the number in 7 guesses.

I should probably reduce the density of the code. It's starting to look like MasterGy's ;-))

42
QB64 Discussion / _ScreenMove _Middle
« on: November 05, 2021, 11:22:35 am »
Is _Middle for _ScreenMove based on the assumption that the Tool bar runs at the top edge?

I just tried _ScreenMove _Middle for a 1024 X 740 screen and _Middle leaves room above the title bar and has the screen bottom below the bottom edge of my computer screen. Limit of Height for me is 740 with title bar.

If I do
Code: QB64: [Select]
  1. _ScreenMove somethingX, 0

will that aggravate everyone who has Tool bars at the top of their screen? Or does 0 go below Tool Bar?

43
Programs / Bas Files Count and List by Recursive Algorithm
« on: November 04, 2021, 11:05:25 pm »
Here is something that might actually be useful, temperamental as hell but I finally got results after several compromises:
 
I had to ChDir to the search Directory to get good results from the GetLists Subroutine. I had never noted that before but it turns out I did do that for Oh Interpreter and other places I successfully used the cross platform files retriever. Dang! It's so frustrating to think you've got something nailed down, go to use it 6 months later and stumble into problems.

Then Windows wont let me ChDir in allot of places where _DirExists so I couldn't just start looking from C:\ for bas files nor even from C:\users\me and my stuff! blah!
But it did work OK from my Desktop and my Downloads Folders where I learn tonight over 10,000 bas files reside.

Takes about 1 sec to do the downloads folder that had 2115 bas files.
Code: QB64: [Select]
  1. _Title "Count BAS files from a start Directory" ' b+ 2021-11-04
  2.  
  3. ' direntry.h needs to be in QB64.exe folder, see below for a commented copy
  5.     Function load_dir& (s As String)
  6.     Function has_next_entry& ()
  7.     Sub close_dir ()
  8.     Sub get_next_entry (s As String, flags As Long, file_size As Long)
  10.  
  11. ReDim Shared BasList$(10000) 'store our Bas pathed Files here
  12. Dim Shared GrandTotal As _Unsigned Long ' ha, ha not that many!
  13.  
  14. FullPathedDir$ = "C:\Users\marka\downloads" ' <<<<<<<<<<<<<  change this line to top directory of your search for
  15. '                                                            best results use places where Windows lets you write bas files.
  16.  
  17. FindAndCountBasFileFrom FullPathedDir$
  18. Print " Grand Total .bas ="; GrandTotal
  19. Open FullPathedDir$ + "\Bas List.txt" For Output As #1
  20. For i = 1 To GrandTotal
  21.     Print #1, BasList$(i)
  24. Print FullPathedDir$ + "\Bas List.txt file is ready."
  25.  
  26.  
  27. Sub FindAndCountBasFileFrom (startDir$)
  28.     If startDir$ <> "." And startDir$ <> ".." And _Trim$(startDir$) <> "" Then
  29.         If Right$(startDir$, 1) <> "\" Then startDir$ = startDir$ + "\"
  30.         If _DirExists(startDir$) Then ChDir startDir$ Else Exit Sub ' >>> There are allot of places where dir exists but cant CD to go!
  31.         'Print "Changing Directory to "; startDir$; ""
  32.         ReDim ds(0) As String, fs(0) As String
  33.         GetLists startDir$, ds(), fs()
  34.         'Print startDir$ + " .bas Files:"
  35.         For i = LBound(fs) To UBound(fs)
  36.             If UCase$(Right$(fs(i), 4)) = ".BAS" Then
  37.                 GrandTotal = GrandTotal + 1
  38.                 Print GrandTotal, startDir$ + fs(i)
  39.                 BasList$(GrandTotal) = startDir$ + fs(i)
  40.                 'If i Mod 20 = 19 Then Print "Press any to cont..": Sleep
  41.             End If
  42.         Next
  43.         'Print
  44.         'Print startDir$ + " Sub-Directories:  zzz...": Sleep
  45.         For j = LBound(ds) To UBound(ds)
  46.             If ds(j) <> "." And ds(j) <> ".." And _Trim$(ds(j)) <> "" Then
  47.                 newD$ = startDir$ + ds(j)
  48.                 'Print "Press any to FindAndCountBasFileFrom " + newD$ + "... zzz": Sleep
  49.                 FindAndCountBasFileFrom newD$
  50.             End If
  51.         Next
  52.         'Print "Press any to cont...": Sleep
  53.     End If
  55.  
  56. Sub GetLists (SearchDirectory As String, DirList() As String, FileList() As String)
  57.  
  58.     '   !!! For this sub to work the _CWD has to be the Search Directory! !!!
  59.  
  60.     ' Thanks SNcNeill ! for a cross platform method to get file and directory lists
  61.     'put this block in main code section of your program close to top
  62.     '' direntry.h needs to be in QB64 folder '<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
  63.     'DECLARE CUSTOMTYPE LIBRARY ".\direntry"
  64.     '    FUNCTION load_dir& (s AS STRING)
  65.     '    FUNCTION has_next_entry& ()
  66.     '    SUB close_dir ()
  67.     '    SUB get_next_entry (s AS STRING, flags AS LONG, file_size AS LONG)
  68.     'END DECLARE
  69.  
  70.     Const IS_DIR = 1
  71.     Const IS_FILE = 2
  72.     Dim flags As Long, file_size As Long, DirCount As Integer, FileCount As Integer, length As Long
  73.     Dim nam$
  74.     ReDim _Preserve DirList(100), FileList(100)
  75.     DirCount = 0: FileCount = 0
  76.  
  77.     If load_dir(SearchDirectory + Chr$(0)) Then
  78.         Do
  79.             length = has_next_entry
  80.             If length > -1 Then
  81.                 nam$ = Space$(length)
  82.                 get_next_entry nam$, flags, file_size
  83.                 If (flags And IS_DIR) Then
  84.                     DirCount = DirCount + 1
  85.                     If DirCount > UBound(DirList) Then ReDim _Preserve DirList(UBound(DirList) + 1000)
  86.                     DirList(DirCount) = nam$
  87.                 ElseIf (flags And IS_FILE) Then
  88.                     FileCount = FileCount + 1
  89.                     If FileCount > UBound(FileList) Then
  90.                         ReDim _Preserve FileList(UBound(FileList) + 1000)
  91.                         'Print Left$(SearchDirectory, Len(searchDiretory) - 1)
  92.                         'getting allot of wierd misfires
  93.                         If Left$(SearchDirectory, Len(searchDiretory) - 1) = "C:\" Then Exit Sub
  94.                     End If
  95.                     FileList(FileCount) = nam$
  96.                 End If
  97.             End If
  98.         Loop Until length = -1
  99.         'close_dir 'move to after end if  might correct the multi calls problem
  100.     Else
  101.     End If
  102.     close_dir 'this  might correct the multi calls problem
  103.  
  104.     ReDim _Preserve DirList(DirCount)
  105.     ReDim _Preserve FileList(FileCount)
  107.  
  108. '  Remove comments below and save as direntry.h
  109. ' in your QB64.exe folder if you don't have it already
  110. '=============================================================
  111.  
  112. '#include <dirent.h>
  113. '#include <sys/stat.h>
  114. '#include <unistd.h>
  115.  
  116. 'const int IS_DIR_FLAG = 1, IS_FILE_FLAG = 2;
  117.  
  118. 'DIR *pdir;
  119. 'struct dirent *next_entry;
  120. 'struct stat statbuf1;
  121.  
  122. 'char current_dir[FILENAME_MAX];
  123. '#ifdef QB64_WINDOWS
  124. '  #define GetCurrentDir _getcwd
  125. '#else
  126. '  #define GetCurrentDir getcwd
  127. '#endif
  128.  
  129. 'int load_dir (char * path) {
  130. '  struct dirent *pent;
  131. '  struct stat statbuf1;
  132. '//Open current directory
  133. 'pdir = opendir(path);
  134. 'if (!pdir) {
  135. 'return 0; //Didn't open
  136. '}
  137. 'return -1;
  138. '}
  139.  
  140. 'int has_next_entry () {
  141. '  next_entry = readdir(pdir);
  142. '  if (next_entry == NULL) return -1;
  143.  
  144. '  stat(next_entry->d_name, &statbuf1);
  145. '  return strlen(next_entry->d_name);
  146. '}
  147.  
  148. 'void get_next_entry (char * nam, int * flags, int * file_size) {
  149. '  strcpy(nam, next_entry->d_name);
  150. '  if (S_ISDIR(statbuf1.st_mode)) {
  151. '    *flags = IS_DIR_FLAG;
  152. '  } else {
  153. '    *flags = IS_FILE_FLAG;
  154. '  }
  155. '  *file_size = statbuf1.st_size;
  156. '  return ;
  157. '}
  158.  
  159. 'void close_dir () {
  160. '  closedir(pdir);
  161. '  pdir = NULL;
  162. '  return ;
  163. '}
  164.  
  165. 'int current_dir_length () {
  166. '  GetCurrentDir(current_dir, sizeof(current_dir));
  167. '  return strlen(current_dir);
  168. '}
  169.  
  170. 'void get_current_dir(char *dir) {
  171. '  memcpy(dir, current_dir, strlen(current_dir));
  172. '  return ;
  173. '}
  174.  
  175.  

Theoretically this is cross platform, would non Windows users verify?

So how many bas files have you got laying around your computer?

Update: This code has nasty error in it and is missing allot of folders.

44
Programs / Recursive Fills (almost)
« on: November 03, 2021, 01:39:42 am »
I almost have it working, it has a little problem getting around circles, looks kind of interesting though. It's pretty fast! see random tests after first screen.
Code: QB64: [Select]
  1. _Title "Recursive Fill" 'b+ 2021-11-03
  2. Screen _NewImage(800, 600, 32)
  3. _Delay .25
  6.  
  7. Line (110, 200)-Step(580, 200), _RGB32(255, 0, 0), B
  8. Circle (400, 300), 280, _RGB32(255, 0, 0)
  9. 'Circle (400, 300), 200.5, _RGB32(255, 0, 0) ' some circle radius leak like radius = 200
  10. 'Circle (400, 300), 201, _RGB32(255, 0, 0)
  11. fill 400, 300, _RGB32(255, 0, 0)
  12. Line (300, 10)-Step(200, 580), _RGB32(255, 0, 0), B
  13. fill 400, 150, _RGB32(255, 0, 0)
  14. fill 400, 450, _RGB32(255, 0, 0)
  16. While _KeyDown(27) = 0
  17.     Cls
  18.     Line (0, 0)-(_Width - 1, _Height - 1), _RGB32(255, 0, 0), B
  19.     doBoxes = Int(Rnd * 2)
  20.     For i = 1 To 10
  21.         If doBoxes Then Line (Rnd * (_Width - 100) + 50, Rnd * (_Height - 100) + 50)-(Rnd * 100, Rnd * 100), _RGB32(255, 0, 0), B
  22.         x = Rnd * _Width: y = Rnd * _Height: r = Rnd * 50 + 10
  23.         Circle (x, y), r, _RGB32(255, 0, 0)
  24.         Circle (x, y), r + .5, _RGB32(255, 0, 0)
  25.         Circle (x, y), r + 1, _RGB32(255, 0, 0)
  26.     Next
  27.     fill 400, 300, _RGB32(255, 0, 0)
  28.     'Beep
  29.     Sleep
  31.  
  32. Function plus (x, y, c As _Unsigned Long)
  33.     If Point(x, y) <> c Then
  34.         For i = x - 1 To 0 Step -1
  35.             If Point(i, y) = c Then xl = i + 1: Exit For
  36.         Next
  37.         'if xl = 0 then xl = 0
  38.         For i = x + 1 To _Width - 1
  39.             If Point(i, y) = c Then xr = i - 1: Exit For
  40.         Next
  41.         If xr = 0 Then xr = _Width - 1
  42.         For i = y - 1 To 0 Step -1
  43.             If Point(x, i) = c Then yu = i + 1: Exit For
  44.         Next
  45.         'if yu = 0 then yu = 0
  46.         For i = y + 1 To _Height - 1
  47.             If Point(x, i) = c Then yd = i - 1: Exit For
  48.         Next
  49.         If yd = 0 Then yd = _Height - 1
  50.         Line (xl, y)-(xr, y), c
  51.         Line (x, yu)-(x, yd), c
  52.         plus = -1
  53.     End If
  55.  
  56. Sub fill (x, y, c As _Unsigned Long)
  57.     If plus(x, y, c) Then
  58.         fill x - 1, y - 1, c
  59.         fill x - 1, y + 1, c
  60.         fill x + 1, y - 1, c
  61.         fill x + 1, y + 1, c
  62.     End If
  64.  
  65.  

45
Programs / How Many Recursive Calls Can Your System Take?
« on: November 02, 2021, 12:01:23 pm »
Find out here!

Code: QB64: [Select]
  1. _Title "About How Many Recursive Calls Can Your Systen Take?" ' b+ 2021-11-02
  2. Screen _NewImage(800, 600, 32)
  3. Dim Shared recurrance
  4. Print "Pausing a second at every 1000."
  5. Line (150, 100)-Step(501, 401), &HFFFFFF00, B
  6. Fill 151, 101, &HFFFFFF00
  7.  
  8. Sub Fill (x, y, kolor As _Unsigned Long)
  9.     recurrance = recurrance + 1
  10.     Locate 3, 1: Print Space$(10)
  11.     Locate 3, 1: Print recurrance
  12.     If recurrance Mod 1000 = 0 Then _Delay 1 Else _Delay .01
  13.     If Point(x, y) <> kolor Then PSet (x, y), kolor
  14.     If Point(x + 1, y) <> kolor Then Fill x + 1, y, kolor
  15.     If Point(x - 1, y) <> kolor Then Fill x - 1, y, kolor
  16.     If Point(x, y + 1) <> kolor Then Fill x, y + 1, kolor
  17.     If Point(x, y - 1) <> kolor Then Fill x, y - 1, kolor
  19.  
  20.  

Mine died at 1810.

No that was 18010 I think 2md time was 18009.

Pages: 1 2 [3] 4 5 ... 21