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.


Messages - Petr

Pages: [1] 2 3 ... 115
1
Programs / Re: Next one Music Visualizer
« on: March 19, 2022, 05:59:34 am »
Quote from: OldMoses on March 18, 2022, 03:38:34 pm
That's an amazing effect. I ran a mp3 song through it and noticed the amplitude of the terrain suddenly increased significantly while the sound remained relatively the same. Must have been picking up something subtle in the encoding...

Yes, this is because it is used to visualize the line every 8192th audio sample. Then the line is moved one step closer in the Z axis (it has a higher coordinate number, the nearest visible one is -1, 0 is no longer invisible and 1 is basically in front of the monitor). For a finer display, I had each sample drawn, it's this source code, the edit is on line 39. Still, not every sample will be rendered now. Why?
In order to render virtually every sound sample, you must first determine in how many frames per second the program will run.
Suppose you set 50 frames per second for smooth graphics. For sound, this means 44100 (SNDRATE) / 50 samples per second, that is 882 samples. But that also means overwriting 882 values in memory 50 times per second.
In this program, this is solved by not tracking exactly where you ended up rendering. Simply take the current position of the sound and load more samples from it. Therefore, it can easily happen that some samples simply fall out before the whole thing is rendered.
  Under line 61, the program solves normal 2D graphics for blinking background circles.

This source code try use "every" sample:

Code: QB64: [Select]
  2. 'sky texture
  3. Texture2 = NewImage(255, 255, 32)
  4. Dest Texture2
  5. For diY = 0 To 100
  6.     Line (diY + 20, diY + 20)-(235 - diY, 235 - diY), RGBA32(67, 100, 255 - diY, 255 - diY), B
  7.     Circle (127, 127), 100 + diY, RGBA32(155 - diY, diY / 2, 20 + diY, 155 - diY)
  9. 'earth texture
  10. Texture = NewImage(255, 255, 32)
  11. Dest Texture
  12. Cls , &HFFFF0000
  13. For diY = 0 To 100
  14.     Line (diY + 20, diY + 20)-(235 - diY, 235 - diY), RGB32(diY, 0, 0), B
  16. Dest 0
  17. Dim As Long SND, Position, FillCachem, HT
  18. Dim As Float IL, IR, IntensityLeft, IntensityRight
  19. Dim As MEM L, R
  20. Dim As Unsigned Byte Rc, Gc, Bc
  21. ReDim LightsL(10) As Unsigned Byte
  22. ReDim LightsR(10) As Unsigned Byte
  23. Dim M3D(90, 90) As Single
  24. Dim M2D(90, 90) As Single
  25. SND = SndOpen("bb.mp3") '            <-----------------  insert here your sound file name!
  26. VOL = 10
  27. SndVol SND, VOL / 20
  28. L = MemSound(SND, 1)
  29. R = MemSound(SND, 2)
  30. DW = DesktopWidth
  31. DH = DesktopHeight
  32. HT = CopyImage(Texture, 33)
  33. HT2 = CopyImage(Texture2, 33)
  34. FreeImage Texture
  35. Screen NewImage(DW, DH, 32)
  36. FullScreen
  37. SndPlay SND
  38. Do Until Position >= L.SIZE - 882 'CHANGED
  39.     ShiftIt = 89
  40.     Do Until ShiftIt < 0
  41.         For rows = 0 To 90
  42.             Swap M3D(rows, ShiftIt), M3D(rows, ShiftIt + 1)
  43.             Swap M2D(rows, ShiftIt), M2D(rows, ShiftIt + 1)
  44.         Next
  45.         ShiftIt = ShiftIt - 1
  46.     Loop
  47.     Depth = 0
  48.     Do Until Depth = 180 '                              This fill 3D visualisation in X axis. One sample is long 2 bytes, one row is 90 points long. This fill 90 points.
  49.         If Depth + Position > L.SIZE Then End
  50.         M3D(ra, 0) = MemGet(L, L.OFFSET + Position + Depth, Integer) / 32768 * 1.7
  51.         M2D(ra, 0) = MemGet(R, R.OFFSET + Position + Depth, Integer) / 32768 * 1.7
  52.         Depth = Depth + 2 '                            This is byte counter and now use all samples not every 8192th as in previous case (first source code in this thread)
  53.         ra = ra + 1
  54.     Loop
  55.     ra = 0
  56.     For Z = 0 To 89
  57.         For X = 0 To 89
  58.             HX = -45 + X
  59.             HX2 = HX + 1
  60.             HZ = -89 + Z
  61.             HZ2 = HZ + 1
  62.             HY1 = -3 + M3D(X, Z): HY2 = -3 + M3D(X + 1, Z): HY3 = -3 + M3D(X, Z + 1): HY4 = -3 + M3D(X + 1, Z + 1)
  63.             HY11 = 3 - M2D(X, Z): HY12 = 3 - M2D(X + 1, Z): HY13 = 3 - M2D(X, Z + 1): HY14 = 3 - M2D(X + 1, Z + 1)
  64.             MapTriangle (0, 0)-(255, 0)-(0, 255), HT To(HX, HY1, HZ)-(HX2, HY2, HZ)-(HX, HY3, HZ2), 0, Smooth
  65.             MapTriangle (255, 0)-(0, 255)-(255, 255), HT To(HX2, HY2, HZ)-(HX, HY3, HZ2)-(HX2, HY4, HZ2), 0, Smooth
  66.             MapTriangle (0, 0)-(255, 0)-(0, 255), HT2 To(HX, HY11, HZ)-(HX2, HY12, HZ)-(HX, HY13, HZ2), 0, Smooth
  67.             MapTriangle (255, 0)-(0, 255)-(255, 255), HT2 To(HX2, HY12, HZ)-(HX, HY13, HZ2)-(HX2, HY14, HZ2), 0, Smooth
  68.     Next X, Z
  69.  
  70.     '----------------------------------------------------------------------------------------------------------- CIRCLES --------------------------------------------------------------
  71.     FillCache = 0
  72.     IntensityLeft = 0
  73.     IntensityRight = 0
  74.     Do Until FillCache = 882
  75.         IntensityLeft = IntensityLeft + Abs(MemGet(L, L.OFFSET + Position + FillCache, Integer) / 32768)
  76.         IntensityRight = IntensityRight + Abs(MemGet(R, R.OFFSET + Position + FillCache, Integer) / 32768)
  77.         FillCache = FillCache + 2
  78.     Loop
  79.     IL = IntensityLeft / 2 '                                                                   recalc values as decimal
  80.     IR = IntensityRight / 2
  81.     ReDim LightsL(10) As Unsigned Byte
  82.     ReDim LightsR(10) As Unsigned Byte
  83.     CLL = 0
  84.     Do Until IL <= 0
  85.         If IL > 4.41 Then LightsL(CLL) = 255 Else LightsL(CLL) = IL * 57
  86.         IL = IL - 4.41
  87.         CLL = CLL + 1
  88.         MAX CLL, 10
  89.     Loop
  90.     CLR = 0
  91.     Do Until IR <= 0
  92.         If IR > 4.41 Then LightsR(CLR) = 255 Else LightsR(CLR) = IR * 57
  93.         IR = IR - 4.41
  94.         CLR = CLR + 1
  95.         MAX CLR, 10
  96.     Loop
  97.     IL = 0
  98.     IR = 0
  99.     For DL = 0 To 10
  100.         Select Case DL
  101.             Case 0 TO 5
  102.                 Rc = 0: Gc = 255: Bc = 0
  103.             Case 6 TO 8
  104.                 Rc = 255: Gc = 255: Bc = 0
  105.             Case Is > 8
  106.                 Rc = 255: Gc = 0: Bc = 0
  107.         End Select
  108.         CircleFill Width / 2 - 50 - DL * 80, Height / 2, 30, &HFF000000
  109.         CircleFill Width / 2 - 50 - DL * 80, Height / 2, 30, RGBA32(Rc, Gc, Bc, LightsL(DL))
  110.         CircleFill Width / 2 + 50 + DL * 80, Height / 2, 30, &HFF000000
  111.         CircleFill Width / 2 + 50 + DL * 80, Height / 2, 30, RGBA32(Rc, Gc, Bc, LightsR(DL))
  112.     Next
  113.     Display
  114.     Limit 50
  115.     Position = SndGetPos(SND) * SndRate * 2
  117.  
  119.  
  120. Sub MAX (Value, mv)
  121.     If Value > mv Then Value = mv
  123.  
  124. Sub CircleFill (CX As Integer, CY As Integer, R As Integer, C As _Unsigned Long)
  125.     ' CX = center x coordinate
  126.     ' CY = center y coordinate
  127.     '  R = radius
  128.     '  C = fill color
  129.     Dim Radius As Integer, RadiusError As Integer
  130.     Dim X As Integer, Y As Integer
  131.     Radius = Abs(R)
  132.     RadiusError = -Radius
  133.     X = Radius
  134.     Y = 0
  135.     If Radius = 0 Then PSet (CX, CY), C: Exit Sub
  136.     Line (CX - X, CY)-(CX + X, CY), C, BF
  137.     While X > Y
  138.         RadiusError = RadiusError + Y * 2 + 1
  139.         If RadiusError >= 0 Then
  140.             If X <> Y + 1 Then
  141.                 Line (CX - Y, CY - X)-(CX + Y, CY - X), C, BF
  142.                 Line (CX - Y, CY + X)-(CX + Y, CY + X), C, BF
  143.             End If
  144.             X = X - 1
  145.             RadiusError = RadiusError - X * 2
  146.         End If
  147.         Y = Y + 1
  148.         Line (CX - X, CY - Y)-(CX + X, CY - Y), C, BF
  149.         Line (CX - X, CY + Y)-(CX + X, CY + Y), C, BF
  150.     Wend
  152.  

Due to the adjustment, I also had to adjust the rendering of the circles. This brought a noticeable increase in speed (not so many shades are used anymore, only about 5 for the color intensity of the circle)

2
Programs / Re: Next one Music Visualizer
« on: March 16, 2022, 01:04:37 pm »
@johnno56

Thank you for trying it. I am glad, that you like it!

3
QB64 Discussion / Re: Command line to create EXE's ?
« on: March 13, 2022, 04:57:56 am »
@mynameispaul

You can also use QB64 /? for view more options (switches).

4
Programs / Next one Music Visualizer
« on: March 12, 2022, 12:49:01 pm »
Hi. This program try generate terrain (not smooth) using music file.

Do not forget overwriting your sound file name on row 17 in this source code.

Code: QB64: [Select]
  2. Texture = NewImage(255, 255, 32)
  3. Dest Texture
  4. Cls , &HFFFF0000
  5. For diY = 0 To 100
  6.     Line (diY + 20, diY + 20)-(235 - diY, 235 - diY), RGB32(diY, 0, 0), B
  8. Dest 0
  9. Dim As Long SND, Position, FillCachem, HT
  10. Dim As Float IL, IR, IntensityLeft, IntensityRight
  11. Dim As MEM L, R
  12. Dim As Unsigned Byte Rc, Gc, Bc
  13. ReDim LightsL(10) As Unsigned Byte
  14. ReDim LightsR(10) As Unsigned Byte
  15. Dim M3D(90, 90) As Single
  16. Dim M2D(90, 90) As Single
  17. SND = SndOpen("bb.mp3") '            <-----------------  insert here your sound file name!
  18. VOL = 10
  19. SndVol SND, VOL / 20
  20. L = MemSound(SND, 1)
  21. R = MemSound(SND, 2)
  22. DW = DesktopWidth
  23. DH = DesktopHeight
  24. HT = CopyImage(Texture, 33)
  25. FreeImage Texture
  26. Screen NewImage(DW, DH, 32)
  27. FullScreen
  28. SndPlay SND
  29. Do Until Position >= L.SIZE - 8192
  30.     ShiftIt = 89
  31.     Do Until ShiftIt < 0
  32.         For rows = 0 To 90
  33.             Swap M3D(rows, ShiftIt), M3D(rows, ShiftIt + 1)
  34.             Swap M2D(rows, ShiftIt), M2D(rows, ShiftIt + 1)
  35.         Next
  36.         ShiftIt = ShiftIt - 1
  37.     Loop
  38.     Depth = 0
  39.     Do Until Depth = 90000
  40.         If Depth + Position > L.SIZE Then End
  41.         M3D(ra, 0) = MemGet(L, L.OFFSET + Position + Depth, Integer) / 32768 * 1.7
  42.         M2D(ra, 0) = MemGet(R, R.OFFSET + Position + Depth, Integer) / 32768 * 1.7
  43.         Depth = Depth + 1000
  44.         ra = ra + 1
  45.     Loop
  46.     ra = 0
  47.     For Z = 0 To 89
  48.         For X = 0 To 89
  49.             HX = -45 + X
  50.             HX2 = HX + 1
  51.             HZ = -89 + Z
  52.             HZ2 = HZ + 1
  53.             HY1 = -3 + M3D(X, Z): HY2 = -3 + M3D(X + 1, Z): HY3 = -3 + M3D(X, Z + 1): HY4 = -3 + M3D(X + 1, Z + 1)
  54.             HY11 = 3 - M2D(X, Z): HY12 = 3 - M2D(X + 1, Z): HY13 = 3 - M2D(X, Z + 1): HY14 = 3 - M2D(X + 1, Z + 1)
  55.             MapTriangle (0, 0)-(255, 0)-(0, 255), HT To(HX, HY1, HZ)-(HX2, HY2, HZ)-(HX, HY3, HZ2), 0, Smooth
  56.             MapTriangle (255, 0)-(0, 255)-(255, 255), HT To(HX2, HY2, HZ)-(HX, HY3, HZ2)-(HX2, HY4, HZ2), 0, Smooth
  57.             MapTriangle (0, 0)-(255, 0)-(0, 255), HT To(HX, HY11, HZ)-(HX2, HY12, HZ)-(HX, HY13, HZ2), 0, Smooth
  58.             MapTriangle (255, 0)-(0, 255)-(255, 255), HT To(HX2, HY12, HZ)-(HX, HY13, HZ2)-(HX2, HY14, HZ2), 0, Smooth
  59.     Next X, Z
  60.  
  61.     '----------------------------------------------------------------------------------------------------------- CIRCLES --------------------------------------------------------------
  62.     FillCache = 0
  63.     IntensityLeft = 0
  64.     IntensityRight = 0
  65.     Do Until FillCache = 8192
  66.         IntensityLeft = IntensityLeft + Abs(MemGet(L, L.OFFSET + Position + FillCache, Integer) / 32768)
  67.         IntensityRight = IntensityRight + Abs(MemGet(R, R.OFFSET + Position + FillCache, Integer) / 32768)
  68.         FillCache = FillCache + 2
  69.     Loop
  70.     IL = IntensityLeft / 2 '                                                                   recalc values as decimal
  71.     IR = IntensityRight / 2
  72.     ReDim LightsL(10) As Unsigned Byte
  73.     ReDim LightsR(10) As Unsigned Byte
  74.     CLL = 0
  75.     Do Until IL <= 0
  76.         If IL > 28 Then LightsL(CLL) = 255 Else LightsL(CLL) = IL * 8
  77.         IL = IL - 28
  78.         CLL = CLL + 1
  79.         MAX CLL, 10
  80.     Loop
  81.     CLR = 0
  82.     Do Until IR <= 0
  83.         If IR > 28 Then LightsR(CLR) = 255 Else LightsR(CLR) = IR * 8
  84.         IR = IR - 28
  85.         CLR = CLR + 1
  86.         MAX CLR, 10
  87.     Loop
  88.     IL = 0
  89.     IR = 0
  90.     For DL = 0 To 10
  91.         Select Case DL
  92.             Case 0 TO 5
  93.                 Rc = 0: Gc = 255: Bc = 0
  94.             Case 6 TO 8
  95.                 Rc = 255: Gc = 255: Bc = 0
  96.             Case Is > 8
  97.                 Rc = 255: Gc = 0: Bc = 0
  98.         End Select
  99.         CircleFill Width / 2 - 50 - DL * 80, Height / 2, 30, &HFF000000
  100.         CircleFill Width / 2 - 50 - DL * 80, Height / 2, 30, RGBA32(Rc, Gc, Bc, LightsL(DL))
  101.         CircleFill Width / 2 + 50 + DL * 80, Height / 2, 30, &HFF000000
  102.         CircleFill Width / 2 + 50 + DL * 80, Height / 2, 30, RGBA32(Rc, Gc, Bc, LightsR(DL))
  103.     Next
  104.     Display
  105.     Limit 50
  106.     Position = SndGetPos(SND) * SndRate * 2
  108.  
  110.  
  111. Sub MAX (Value, mv)
  112.     If Value > mv Then Value = mv
  114.  
  115. Sub CircleFill (CX As Integer, CY As Integer, R As Integer, C As _Unsigned Long)
  116.     ' CX = center x coordinate
  117.     ' CY = center y coordinate
  118.     '  R = radius
  119.     '  C = fill color
  120.     Dim Radius As Integer, RadiusError As Integer
  121.     Dim X As Integer, Y As Integer
  122.     Radius = Abs(R)
  123.     RadiusError = -Radius
  124.     X = Radius
  125.     Y = 0
  126.     If Radius = 0 Then PSet (CX, CY), C: Exit Sub
  127.     Line (CX - X, CY)-(CX + X, CY), C, BF
  128.     While X > Y
  129.         RadiusError = RadiusError + Y * 2 + 1
  130.         If RadiusError >= 0 Then
  131.             If X <> Y + 1 Then
  132.                 Line (CX - Y, CY - X)-(CX + Y, CY - X), C, BF
  133.                 Line (CX - Y, CY + X)-(CX + Y, CY + X), C, BF
  134.             End If
  135.             X = X - 1
  136.             RadiusError = RadiusError - X * 2
  137.         End If
  138.         Y = Y + 1
  139.         Line (CX - X, CY - Y)-(CX + X, CY - Y), C, BF
  140.         Line (CX - X, CY + Y)-(CX + X, CY + Y), C, BF
  141.     Wend
  143.  

5
QB64 Discussion / Re: Blurry text??
« on: February 19, 2022, 04:02:24 pm »
Hi, @Mad Axeman

Try pressing Left Alt + Enter a few times while working in the IDE.

6
QB64 Discussion / Re: Compilation error: simple fixed string binary file PUT
« on: February 18, 2022, 02:15:36 pm »
Hi @OldMoses

It still make error. I've dealt with it too, so I'm going it through MEM:

Code: QB64: [Select]
  1. 'OPTION BASE 1
  2. Screen _NewImage(1024, 512, 32)
  3.  
  4. Dim An(1 To 10) As String * 10
  5.  
  6. For x% = 1 To 10
  7.     Read An(x%)
  8. Next x%
  9.  
  11. Open "animals.dat" For Binary As #f
  12.  
  13. 'method A
  14. 'For R = LBound(An) To UBound(An)
  15. 'Put #f, , An(R)
  16. 'Next
  17.  
  18. 'method B
  20. m = _Mem(An())
  21. r$ = Space$(m.SIZE)
  22. _MemGet m, m.OFFSET, r$
  23. Put #f, , r$
  25.  
  26.  
  29. Print "done"
  31.  
  32. Data dog,cat,bison,elephant,weasel,bear,skunk,ocelot,platypus,pig
  33.  
  34.  
  35.  

7
Programs / Petr's Script program in QB64
« on: February 07, 2022, 10:29:56 am »
Hi guys.

This is a small program I'm working on right now. Its purpose is simply to display lyrics, subtitles, comments and / or pictures, play sounds and it's all time-controlled. It can also pause the execution and stop the presentation time. It is a very simple solution. The main goal is to make it easier to shoot videos about QB64 on YouTube - of course, subtitles can also be added there, but this solution, without the need for further editing, seemed better to me. So now all you have to do is download non-copyrighted music, take a few screenshots, translate the comments and it can be fun to create. The amazing thing about Open Source is that it can be shared like this. You will definitely have suggestions on what to add. I gradually want to do it. In the evening, I will use this program to create a presentation about why I haven't been here for a long time and then publish it on my Youtube channel.

You need the attached ZIP file to try it out. When started, the program will ask for the file name. Write there "kuci" - it is script file name, this file is also in zip file. Look in kuci file and see how it is all done.

Code: QB64: [Select]
  2. Title "QB64 Script"
  3. Type Content
  4.     Time As Single
  5.     Statement As String
  7.  
  8.  
  9. ReDim Shared Images(0) As Long, imgI
  10. ReDim Sounds(0) As Long
  11. ReDim Videos(0) As String
  12. ReDim Fonts(0) As Long
  13. ReDim My(0) As Content
  14. ReDim Clrs(2) As Unsigned Byte
  16.  
  17. Input "Input text script file name:"; script$
  18. If FileExists(script$) Then
  19.     FF = FreeFile
  20.     Open script$ For Input As #FF
  21.     While Not EOF(FF)
  22.         Line Input #FF, s$
  23.  
  24.  
  25.         '-------------------------------------- LOAD TO MEMORY AND CHECK ALL FILES IF EXISTS [STEP 1/3] ----------------------------------------------------------
  26.         'ziskat cas
  27.         sep = InStr(s$, " ")
  28.         Tim$ = Mid$(s$, 1, sep - 1)
  29.         sep = InStr(Tim$, ":")
  30.         Min = Val(Mid$(Tim$, 2, sep))
  31.         Tim$ = Mid$(Tim$, sep + 1)
  32.         Secs = Val(Mid$(Tim$, 1, sep))
  33.         sep = InStr(Tim$, ":")
  34.         Tim$ = Mid$(Tim$, sep + 1)
  35.         Set = Val(Mid$(Tim$, 1, sep))
  36.  
  37.         'cas: Min, Sec, Set
  38.         Time = (Min * 60) + Secs + (Set / 100)
  39.         My(record).Time = Time
  40.  
  41.  
  42.  
  43.         'ziskat prikaz (cmd$)
  44.         sep = InStr(s$, " ")
  45.         s$ = Mid$(s$, sep + 1)
  46.         My(record).Statement = (s$)
  47.  
  48.  
  49.  
  50.         sep = InStr(s$, " ")
  51.         cmd$ = Left$(s$, sep - 1)
  52.  
  53.         Select Case UCase$(cmd$)
  54.             Case "SCRN" '                                                        Screen settings
  55.                 'ziskat ResX
  56.                 s$ = Mid$(s$, sep + 1)
  57.                 sep = InStr(s$, " ")
  58.                 ResX = Val(Mid$(s$, 1, sep - 1))
  59.  
  60.                 'ziskat ResY
  61.                 s$ = Mid$(s$, sep + 1)
  62.                 sep = InStr(s$, " ")
  63.                 ResY = Val(Mid$(s$, sep + 1))
  64.  
  65.             Case "SIMG" '                                                       Load images to array (in my mind is already upgrade for it)
  66.                 FileName$ = Mid$(s$, sep + 1)
  67.                 If FileExists(FileName$) Then
  68.                     iU = UBound(Images)
  69.                     Images(iU) = _LoadImage(FileName$, 32)
  70.                     If Images(iU) = -1 Then Print "Error: Image file "; FileName$; " is in unsupported format.": Sleep 3: End
  71.                     ReDim Preserve Images(iU + 1) As Long
  72.                 Else
  73.                     Print "SIMG File "; FileName$; " not found. (Record nr."; record; ")": Sleep 3: End
  74.                 End If
  75.  
  76.             Case "PASS"
  77.                 '                                                              Load images to array as SIMG statement, but PASS is for other use than SIMG (look again)
  78.  
  79.                 s$ = Mid$(s$, sep + 1)
  80.                 sep = InStr(s$, " ")
  81.                 PhotoA$ = Mid$(s$, sep + 1)
  82.  
  83.                 sep = InStr(s$, " ")
  84.                 s$ = Mid$(s$, sep + 1)
  85.                 sep2 = InStrRev(s$, " ")
  86.  
  87.                 s$ = Mid$(s$, sep2)
  88.                 Effect = Val(s$)
  89.  
  90.                 PassE(psI) = Effect
  91.                 psI = psI + 1
  92.                 ReDim Preserve PassE(psI) As Integer
  93.  
  94.                 If FileExists(PhotoA$) Then
  95.                     iU = UBound(Images)
  96.                     Images(iU) = _LoadImage(PhotoA$, 32)
  97.                     If Images(iU) = -1 Then Print "Error: Image file "; PhotoA$; " is in unsupported format.": Sleep 3: End
  98.                     ReDim Preserve Images(iU + 1) As Long
  99.                 Else
  100.                     Print "PASS File "; PhotoA$; " not found. (Record nr."; record; ")": Sleep 3: End
  101.                 End If
  102.  
  103.             Case "SNDL", "SNDP" '                                                Load sounds to array
  104.                 FileName$ = Mid$(s$, sep + 1)
  105.                 If FileExists(FileName$) Then
  106.                     sU = UBound(Sounds)
  107.                     Sounds(sU) = SndOpen(FileName$)
  108.                     If Sounds(sU) = 0 Then Print "Error: Sound file: "; FileName$; " is in unsupported format,": Sleep 3: End
  109.                     ReDim Preserve Sounds(sU + 1) As Long
  110.                 Else
  111.                     Print "Sound file "; FileName$; " not found.": Sleep 3: End
  112.                 End If
  113.  
  114.             Case "SVID" '                                                       Load video file names (if file exists) to array as string (will be used later with Windows Media Player)
  115.                 FileName$ = Mid$(s$, sep + 1)
  116.                 If FileExists(FileName$) Then
  117.                     vU = UBound(Videos)
  118.                     Videos(vU) = FileName$
  119.                     ReDim Preserve Videos(vU + 1) As String
  120.                 Else
  121.                     Print "Video file "; FileName$; " not found.": Sleep 3: End
  122.                 End If
  123.  
  124.             Case "FONT" '                                                       Load font TTF, OTF file
  125.                 sep = InStr(s$, " ")
  126.                 sep2 = InStrRev(s$, " ")
  127.                 FontName$ = Mid$(s$, sep + 1, sep2 - sep)
  128.                 FontSize = Val(Mid$(s$, sep2 + 1))
  129.                 fU = UBound(Fonts)
  130.                 Fonts(fU) = LoadFont(FontName$, FontSize, "MONOSPACE")
  131.                 If Fonts(fU) = 0 Then Print "Error loading font "; FontName$: Sleep 3: End
  132.                 ReDim Preserve Fonts(fU + 1) As Long
  133.         End Select
  134.         record = record + 1
  135.         ReDim Preserve My(record) As Content
  136.     Wend
  138.     Print "Error: Script text file "; script$; " not exists."
  139.     End
  141.  
  142. ' -------------------------------------  RUN OWN PRESENTATION [STEP 2/3]  -------------------------------------------------------------------------------
  143. NullTime = Timer
  145.  
  146. If ResX > 0 And ResY > 0 Then Screen NewImage(ResX, ResY, 32) Else Print "Text mode!"
  147.  
  148. R = 0
  149.  
  150. Do Until k& = 27
  151.     k& = _KeyHit
  152.     'time is calculated from TIMER
  153.     If Timer < NullTime Then NullTime = Timer - P_time 'midnight overflow check / not tested
  154.  
  155.  
  156.     'this is console developing window, it show presentation time for us. If presentation time is the same as in your script file, then it run again, otherwise program wait.
  157.  
  158.     P_time = Timer - NullTime
  159.  
  160.     Do Until P_time > My(R).Time
  161.         P_time = Timer - NullTime
  162.  
  163.         $Console
  164.         Dest Console
  165.         Echo Str$(P_time): Echo Str$(My(R).Time)
  166.         Delay .01
  167.         Dest 0
  168.  
  169.     Loop
  170.  
  171.  
  172.     Statement$ = UCase$(Left$(My(R).Statement, 4))
  173.  
  174.     'od 05-02-2022
  175.     Select Case Statement$
  176.         Case "SIMG" '                        command: Show Image (accept ratio)
  177.             If PixelSize = 4 Then '          works just if SCRN stetement for setting graphic screen is in text file used before SIMG statement, otherwise is this skipped!
  178.                 GetImageRatio LUX, LUY, RUX, RUY, imgI
  179.                 _PutImage (LUX, LUY)-(RUX, RUY), Images(imgI)
  180.                 imgI = imgI + 1
  181.             End If
  182.         Case "SNDL"
  183.             If SndPlaying(Sounds(SoundsI)) = 1 Then SndStop Sounds(SoundsI) 'Play sound in loop
  184.             SndLoop Sounds(SoundsI)
  185.             SoundsI = SoundsI + 1
  186.         Case "SNDP"
  187.             If SndPlaying(Sounds(SoundsI)) = 1 Then SndStop Sounds(SoundsI) 'Play sound once
  188.             SndPlay Sounds(SoundsI)
  189.             SoundsI = SoundsI + 1
  190.         Case "SNDS"
  191.             SndStop Sounds(SoundsI)
  192.         Case "PASS" '                         insert a transition between photos / videos 'parameter is OPTIONAL!
  193.             Parameter = PassE(passI)
  194.             passI = passI + 1
  195.             InsertTransmission Parameter
  196.         Case "DELA" '                                        DELA statement is the same as SLEEP, it also stop time in presentation
  197.             Parameter = Val(Mid$(My(R).Statement, 5))
  198.  
  199.             StopTime = Timer - NullTime
  200.             NullTime = StopTime
  201.             If Parameter Then Sleep Parameter Else Sleep
  202.             NullTime = Timer - StopTime
  203.  
  204.         Case "SVID" '                                       For future version - PlayVideo in this version is empty SUB, in future it use SpriggsySpriggs libraries for call Windows Media Player
  205.             VideoName$ = Videos(VideoI)
  206.             VideoI = VideoI + 1
  207.             PlayVideo VideoName$
  208.         Case "FONT" '                                       View FONT. Use in file: ú[00:00:10] FONT Arial.ttf 40  <---- in step 1/3 it loads and in step 2/3 it view all text using Arial font size 40
  209.             Font Fonts(FontI)
  210.             FontI = FontI + 1
  211.         Case "STIT"
  212.             Text$ = Mid$(My(R).Statement, 5) '              Print SUBTITLE to screen (just one row in this version) use in file is: [01:00:97] STIT This is subtitle
  213.             InsertText Text$
  214.         Case "CLRS"
  215.             Cls , RGB32(Clrs(0), Clrs(1), Clrs(2)) '                 clear screen using color sets for foreground or for background color
  216.         Case "COLF" '                                                set foreground color for subtitles (STIT statement)
  217.             ReDim Clrs(2) As _Unsigned _Byte
  218.             n$ = Mid$(My(R).Statement, 5)
  219.             'Print n$
  220.             For T = 0 To 2
  221.                 sep = InStr(n$, " ") + 1
  222.                 nr$ = Mid$(n$, sep, 3)
  223.                 control = InStr(nr$, " ")
  224.                 If control Then Clrs(T) = Val(Mid$(nr$, 1, control)) Else Clrs(T) = Val(nr$)
  225.                 n$ = Mid$(n$, sep + 1)
  226.             Next
  227.  
  228.             Color RGB32(Clrs(0), Clrs(1), Clrs(2))
  229.  
  230.         Case "COLB" '                                                set background color
  231.             ReDim Clrs(2) As _Unsigned _Byte
  232.             n$ = Mid$(My(R).Statement, 5)
  233.             'Print n$
  234.             For T = 0 To 2
  235.                 sep = InStr(n$, " ") + 1
  236.                 nr$ = Mid$(n$, sep, 3)
  237.                 control = InStr(nr$, " ")
  238.                 If control Then Clrs(T) = Val(Mid$(nr$, 1, control)) Else Clrs(T) = Val(nr$)
  239.                 n$ = Mid$(n$, sep + 1)
  240.             Next
  241.  
  242.             Color , RGB32(Clrs(0), Clrs(1), Clrs(2))
  243.  
  244.         Case "TEXT" '                                                      Print centered text to screen. Use in file: [02:00:99] TEXT Here place long text which is then centered and printed to screen
  245.             n$ = Mid$(My(R).Statement, 5)
  246.             LongText n$
  247.  
  248.         Case "FSCR"
  249.             FullScreen
  250.         Case "CLSS"
  251.             Cls
  252.  
  253.     End Select
  254.     R = R + 1
  255.     If R > record Then Exit Do 'skip to phase 3 - erasing RAM and quit.
  257.  
  258. '-------------------------------------- Erase RAM, delete images and sounds from memory and then end [Step 3/3] -----------------------------------------
  259.  
  260.  
  261. For C1 = LBound(Images) To UBound(Images) - 1
  262.     FreeImage Images(C1)
  264.  
  265. For C2 = LBound(Sounds) To UBound(Sounds) - 1
  266.     SndClose Sounds(C2)
  268.  
  269. Erase Images
  270. Erase Sounds
  271. Erase Videos
  272. Erase Fonts
  274. Erase Clrs
  275. Erase PassE
  276.  
  278.  
  279.  
  280.  
  281.  
  282.  
  283.  
  284.  
  285.  
  286.  
  287.  
  288.  
  289.  
  290.  
  291. Sub InsertText (T$)
  292.     TextLenght = PrintWidth(T$)
  293.     Middle = Width \ 2 - TextLenght \ 2
  294.     PrintMode KeepBackground
  295.     PrintString (Middle, Height - FontHeight - 10), T$
  297.  
  298.  
  299. Sub LongText (t As String)
  300.     TextMax = Width \ FontWidth
  301.     Rows = Len(t) \ TextMax
  302.     y = Height / 2 - (FontHeight * Rows / 2)
  303.     Tr = 1
  304.     t$ = t$ + " "
  305.     Do Until LastSpace = Len(t)
  306.         Word$ = Mid$(t, Tr, TextMax)
  307.         LastSpace = InStrRev(Word$, " ")
  308.         S$ = Mid$(Word$, 1, LastSpace)
  309.         Center = Width / 2 - PrintWidth(S$) / 2
  310.         PrintString (Center, y), S$
  311.         y = y + FontHeight
  312.         t$ = Mid$(t$, LastSpace + 1)
  313.     Loop
  315.  
  316.  
  317.  
  318.  
  319. Sub InsertTransmission (Value As Integer)
  320.     'prechody fotek, 0 = nahodny
  321.     Old = CopyImage(0, 32)
  322.     New = NewImage(Width, Height, 32)
  323.     GetImageRatio lux, luy, rdx, rdy, imgI
  324.     _PutImage (lux, luy)-(rdx, rdy), Images(imgI), New
  325.     imgI = imgI + 1
  326.     If Value = 0 Then Value = 1 + 10 * Rnd
  327.     s = 0
  328.     centerX = Width \ 2
  329.     centerY = Height \ 2
  330.  
  331.     Select Case Value
  332.         Case 1 'old image shift up, new is shift from bottom
  333.             Do Until s <= -Height
  334.                 PutImage (0, s), Old, 0
  335.                 PutImage (0, s + Height), New, 0
  336.                 s = s - 10
  337.             Loop
  338.  
  339.         Case 2 'old photo go down, new is shift from ceil
  340.             Do Until s >= Height
  341.                 PutImage (0, s), Old, 0
  342.                 PutImage (0, s - Height), New, 0
  343.                 s = s + 10
  344.             Loop
  345.  
  346.         Case 3 'old photo is shifted to right, new is comming from left
  347.             Do Until s >= Width
  348.                 PutImage (s, 0), Old, 0
  349.                 PutImage (s - Width, 0), New, 0
  350.                 s = s + 10
  351.             Loop
  352.  
  353.         Case 4 'old photo is shifted to left and new photo is comming from right
  354.             Do Until s <= -Width
  355.                 PutImage (s, 0), Old, 0
  356.                 PutImage (s + Width, 0), New, 0
  357.                 s = s + 10
  358.             Loop
  359.  
  360.         Case 5 'old photo is rewrited by circle contains new photo
  361.             Do Until s > _Pi(2)
  362.                 x1 = centerX + Cos(s) * Width
  363.                 y1 = centerY + Sin(s) * Width
  364.                 x2 = centerX + Cos(s + .2) * Width
  365.                 y2 = centerY + Sin(s + .2) * Width
  366.                 MapTriangle (centerX, centerY)-(x1, y1)-(x2, y2), New To(centerX, centerY)-(x1, y1)-(x2, y2), 0
  367.                 s = s + .01
  368.                 Display
  369.             Loop
  370.             Delay .2
  371.             AutoDisplay
  372.  
  373.         Case 6 ' new photo is zoomed from middle the screen as rectangle with this image
  374.  
  375.             Stp = Width / 100
  376.             Stp2 = Height / 100
  377.             x1 = centerX + Sin(3.925) * k
  378.             Do Until x1 <= 0
  379.                 x1 = centerX + Sin(3.925) * k
  380.                 y1 = centerY + Cos(3.925) * k2
  381.                 x3 = centerX + Sin(0.785) * k
  382.                 y3 = centerY + Cos(0.785) * k2
  383.                 PutImage (x1, y1)-(x3, y3), New, 0
  384.                 k = k + Stp
  385.                 k2 = k2 + Stp2
  386.                 kk = kk + 1
  387.                 Delay .01
  388.             Loop
  389.  
  390.         Case 7 'new photo is inserted as rectnagles from left to right and from ceiling to bottom
  391.  
  392.             sx = Width / 10
  393.             sy = Height / 10
  394.             For y = 0 To Height Step sy
  395.                 For x = 0 To Width Step sx
  396.                     PutImage (x, y), New, 0, (x, y)-(x + sx, y + sy)
  397.                     Delay .02
  398.             Next x, y
  399.  
  400.         Case 8 'vice versa as Case 7
  401.  
  402.             sx = Width / 10
  403.             sy = Height / 10
  404.  
  405.             For x = 0 To Width Step sx
  406.                 For y = 0 To Height Step sy
  407.                     PutImage (x, y), New, 0, (x, y)-(x + sx, y + sy)
  408.                     Delay .02
  409.             Next y, x
  410.  
  411.         Case 9 'photo is displayed using quarter circle effect
  412.             c = _Pi / 2
  413.             Do Until s > _Pi(2) / 4
  414.                 x1 = centerX + Cos(s) * Width
  415.                 y1 = centerY + Sin(s) * Width
  416.                 x2 = centerX + Cos(s + .01) * Width
  417.                 y2 = centerY + Sin(s + .01) * Width
  418.  
  419.                 x3 = centerX + Cos(s + c) * Width
  420.                 y3 = centerY + Sin(s + c) * Width
  421.                 x4 = centerX + Cos(s + .01 + c) * Width
  422.                 y4 = centerY + Sin(s + .01 + c) * Width
  423.  
  424.                 x5 = centerX + Cos(s + 2 * c) * Width
  425.                 y5 = centerY + Sin(s + 2 * c) * Width
  426.                 x6 = centerX + Cos(s + .01 + 2 * c) * Width
  427.                 y6 = centerY + Sin(s + .01 + 2 * c) * Width
  428.  
  429.                 x7 = centerX + Cos(s + 3 * c) * Width
  430.                 y7 = centerY + Sin(s + 3 * c) * Width
  431.                 x8 = centerX + Cos(s + .01 + 3 * c) * Width
  432.                 y8 = centerY + Sin(s + .01 + 3 * c) * Width
  433.  
  434.  
  435.                 MapTriangle (centerX, centerY)-(x1, y1)-(x2, y2), New To(centerX, centerY)-(x1, y1)-(x2, y2), 0
  436.                 MapTriangle (centerX, centerY)-(x3, y3)-(x4, y4), New To(centerX, centerY)-(x3, y3)-(x4, y4), 0
  437.                 MapTriangle (centerX, centerY)-(x5, y5)-(x6, y6), New To(centerX, centerY)-(x5, y5)-(x6, y6), 0
  438.                 MapTriangle (centerX, centerY)-(x7, y7)-(x8, y8), New To(centerX, centerY)-(x7, y7)-(x8, y8), 0
  439.  
  440.                 s = s + .01
  441.                 Display
  442.                 Delay .01
  443.             Loop
  444.             Delay .2
  445.             AutoDisplay
  446.  
  447.         Case 10 'The image is divided into stripes in the Y axis, odd go to the right, even go to the left. So the old one is comming out and a new image arrives at the screen.
  448.             ReDim Ys(1 To 10) As Integer
  449.             ReDim Xs(1 To 10) As Integer
  450.             d = Height / 10
  451.             XSpd = Width / 100 'shift speed in X axis is WIDTH/100 pixels per loop
  452.             For Yf = 1 To 10
  453.                 Ys(Yf) = (Yf - 1) * d
  454.             Next
  455.             PCopy 0, 1
  456.             Do Until done >= Width
  457.                 PCopy 1, 0
  458.                 For s = 1 To 10
  459.                     If s Mod 2 = 0 Then
  460.                         Xs(s) = Xs(s) - XSpd
  461.                         PutImage (Xs(s), Ys(s)), Old, 0, (0, Ys(s))-(Width, Ys(s) + d)
  462.                         PutImage (Xs(s) + Width, Ys(s)), New, 0, (0, Ys(s))-(Width, Ys(s) + d)
  463.                     Else
  464.                         Xs(s) = Xs(s) + XSpd
  465.                         PutImage (Xs(s), Ys(s)), Old, 0, (0, Ys(s))-(Width, Ys(s) + d)
  466.                         PutImage (Xs(s) - Width, Ys(s)), New, 0, (0, Ys(s))-(Width, Ys(s) + d)
  467.                     End If
  468.                 Next s
  469.                 done = done + XSpd
  470.                 Display
  471.                 Delay .01
  472.             Loop
  473.             Delay .02
  474.             AutoDisplay
  475.  
  476.         Case 11 'vice versa as Case 10
  477.             ReDim Ys(1 To 10) As Integer
  478.             ReDim Xs(1 To 10) As Integer
  479.             d = Height / 10
  480.             XSpd = Width / 100 'shift speed in X axis is WIDTH/100 pixels per loop
  481.             For Yf = 1 To 10
  482.                 Ys(Yf) = (Yf - 1) * d
  483.             Next
  484.             PCopy 0, 1
  485.             Do Until done >= Width
  486.                 PCopy 1, 0
  487.                 For s = 1 To 10
  488.                     If s Mod 2 = 0 Then
  489.                         Xs(s) = Xs(s) + XSpd
  490.                         PutImage (Xs(s), Ys(s)), Old, 0, (0, Ys(s))-(Width, Ys(s) + d)
  491.                         PutImage (Xs(s) - Width, Ys(s)), New, 0, (0, Ys(s))-(Width, Ys(s) + d)
  492.                     Else
  493.                         Xs(s) = Xs(s) - XSpd
  494.                         PutImage (Xs(s), Ys(s)), Old, 0, (0, Ys(s))-(Width, Ys(s) + d)
  495.                         PutImage (Xs(s) + Width, Ys(s)), New, 0, (0, Ys(s))-(Width, Ys(s) + d)
  496.                     End If
  497.                 Next s
  498.                 done = done + XSpd
  499.                 Display
  500.                 Delay .01
  501.             Loop
  502.             Delay .02
  503.             AutoDisplay
  504.     End Select
  505.     FreeImage Old
  506.     FreeImage New
  508.  
  509. Sub PlayVideo (Video As String)
  510.     'is my work for next weekend...
  511.  
  512.  
  514.  
  515. Sub GetImageRatio (LeftUpperX, LeftUpperY, RightDownX, RightDownY, handle)
  516.     W = Width(Images(handle))
  517.     H = Height(Images(handle))
  518.     sW = Width '                    Screen Width
  519.     sH = Height '                   Screen Height
  520.  
  521.     RatioX = sW / W
  522.     RatioY = sH / H
  523.  
  524.     Ratio = 1 '                     if RatioX = RatioY
  525.     If RatioX < RatioY Then Ratio = RatioX
  526.     If RatioY < RatioX Then Ratio = RatioY
  527.  
  528.     N_I_W = W * Ratio '             New _ Image _ Width
  529.     N_I_H = H * Ratio '             New _ Image _ Height
  530.  
  531.     LeftUpperX = (sW - N_I_W) \ 2
  532.     RightDownX = sW - LeftUpperX
  533.     LeftUpperY = (sH - N_I_H) \ 2
  534.     RightDownY = sH - LeftUpperY
  536.  

Edit: After creating window press any key to start, i forgot DELA statement in script file (is used before screen recording)

8
Programs / Re: Program for neat display of long text
« on: February 06, 2022, 03:53:53 am »
Thank you all for your many inspiring ideas and examples. The MasterGy solution is beautiful, the test with the Steve program took me 61 seconds, and to comment on BPlus - you're right, my program just didn't expect that there would be so many characters in the text without a space. I see that you can really improve a lot on this as well. The solution at the beginning of this thread is still sufficient for the purpose for which it was written. I will publish the exact use and the reason why I deal with it soon. It is again just one fragment from a larger program. Thank you all for your many inspiring suggestions!

9
Programs / Re: Program for neat display of long text
« on: February 05, 2022, 10:16:16 am »
Now is it centered also in Y axis:

Code: QB64: [Select]
  1. 'TEXT statement automaticelly center and divide long text string on the screen. Also in Y axis now.
  2.  
  4.  
  5. T$ = "For English-speaking friends, this notice in English: This program is designed to split extremely long text so that whole words appear on a line and do not break at the end of a line. Dividing is only possible in spaces between words."
  6.  
  7. Screen NewImage(1024, 768, 32)
  8. f = LoadFont("arial.ttf", 25, "MONOSPACE")
  9. Font f
  10. Text T$
  11.  
  12.  
  13. Sub Text (t As String)
  14.     TextMax = Width \ FontWidth
  15.     Rows = Len(t) \ TextMax
  16.     y = Height / 2 - (FontHeight * Rows / 2)
  17.     Tr = 1
  18.     t$ = t$ + " "
  19.     Do Until LastSpace = Len(t)
  20.         Word$ = Mid$(t, Tr, TextMax)
  21.         LastSpace = InStrRev(Word$, " ")
  22.         S$ = Mid$(Word$, 1, LastSpace)
  23.         Center = Width / 2 - PrintWidth(S$) / 2
  24.         PrintString (Center, y), S$
  25.         y = y + FontHeight
  26.         t$ = Mid$(t$, LastSpace + 1)
  27.     Loop
  29.  

10
Programs / Re: Program for neat display of long text
« on: February 05, 2022, 09:53:54 am »
Quote from: _vince on February 05, 2022, 09:52:18 am
skvely!

Thank you, _vince :)

11
Programs / Program for neat display of long text
« on: February 05, 2022, 09:46:30 am »
This program has one goal. Divide the text where it is expected, ie where there is a space in the text. It looks funny now, but - I went to it so badly again, I won't even describe it, you wouldn't want to believe it anyway...

It's not visible, but - I mean - so much work and so much nonsense. I spend three hours on it (due to a completely disastrous concept) until I finally left the computer, deleted it all, and finally did it completely differently. The original source was a nasty monster and it didn't work. This is short and functional. So if anyone wants to deal with it, it's available here.

Code: QB64: [Select]
  1. 'prikaz TEXT automaticky rozdeli a vycentruje na radky dlouhy text:
  2.  
  4.  
  5. T$ = "Toto je ukazka velice dlouheho textoveho retezce, ktery ma program za ukol rozdelit na nekolik kratsich retezcu a zobrazit je vycentrovane. Deleni je mozne jen v mezerach. For English-speaking friends, this notice in English: This program is designed to split extremely long text so that whole words appear on a line and do not break at the end of a line. Dividing is only possible in spaces between words."
  6.  
  7. Screen NewImage(1024, 768, 32)
  8. f = LoadFont("arial.ttf", 25, "MONOSPACE")
  9. Font f
  10. Text T$
  11.  
  12.  
  13. Sub Text (t As String)
  14.     'spocitam pocet znaku na obrazovku, podle toho rozsekam retezec (v kusu o te delce najdu prvni mezeru zprava)
  15.     TextMax = Width \ FontWidth
  16.     Tr = 1
  17.     t$ = t$ + " "
  18.     Do Until LastSpace = Len(t)
  19.         Word$ = Mid$(t, Tr, TextMax)
  20.         LastSpace = InStrRev(Word$, " ")
  21.         S$ = Mid$(Word$, 1, LastSpace)
  22.         Center = Width / 2 - PrintWidth(S$) / 2
  23.         PrintString (Center, y), S$
  24.         y = y + FontHeight
  25.         t$ = Mid$(t$, LastSpace + 1)
  26.     Loop
  28.  

12
QB64 Discussion / Re: The QB64 Bible (Work In Progress)
« on: February 01, 2022, 05:09:09 pm »
@SMcNeill

Nicely written, it reads nicely. I'm glad you started, I'm looking forward to continuing. I also learned a few things I didn't know about before.

13
QB64 Discussion / Re: A lesson on how to break QB64
« on: January 24, 2022, 02:39:54 pm »
Hi. Maybe this can be solved by adding the Lock command to the IDE? This ensures that nothing - only the IDE can manipulate with the file on the disk. Maybe it would also like to check if each path and file exists before each compilation?

14
QB64 Discussion / Re: Shell Copy (small bug ?)
« on: January 21, 2022, 05:05:28 pm »
It is really very stupid to give such a short code as an attachment. Next time, I will not respond to such a post at all. Here's the solution (save it as untitled.bas)

Code: QB64: [Select]
  1. a$ = "copy " + Chr$(34) + _StartDir$ + "\untitled.bas" + Chr$(34) + Chr$(32) + Chr$(34) + "target.bas" + Chr$(34)
  3.  

15
Programs / Re: Playing with fire (again)
« on: January 18, 2022, 11:40:04 am »
This just wants an answer with a little modification :)

external files is not need

Code: QB64: [Select]
  1. _Title "Jolly Roger on Fire" 'b+ 2022-01-17
  2.  
  3. Const xmax = 500, ymax = 400
  4. Screen _NewImage(xmax, ymax, 32)
  5. _ScreenMove 360, 160
  6.  
  7. Dim p&(300) 'pallette
  8. For i = 1 To 100
  9.     fr = 240 * i / 100 + 15
  10.     p&(i) = _RGB(fr, 0, 0)
  11.     p&(i + 100) = _RGB(255, fr, 0)
  12.     p&(i + 200) = _RGB(255, 255, fr)
  14. w~& = _RGB32(255)
  15. jr& = _NewImage(188, 154, 32) '_LoadImage("Jolly Roger.png") '
  16. D = _Dest: _Dest jr&
  17. F = _LoadFont("arial.ttf", 64, "bold")
  18. _Font F, jr&
  19. _PrintString (10, 60), "NICE!"
  21. _PutImage , jr&, 0
  22. xxmax = 500: yymax = 200 'pixels too slow
  23. xstep = xmax / xxmax: ystep = ymax / yymax
  24. Dim f(xxmax, yymax), ff(xxmax, yymax) 'fire array and seed
  25. For y = 0 To yymax - 1
  26.     For x = 0 To xxmax - 1
  27.         If Point(x * xstep, y * ystep) = w~& Then f(x, y) = 300: ff(x, y) = 300
  28.     Next
  30.  
  31. While 1 'main fire
  32.     Cls
  33.     For y = 1 To yymax - 1
  34.         For x = 1 To xxmax - 1 'shift fire seed a bit
  35.             r = Rnd
  36.             If r > .9 Then f(x, y) = ff(x, y)
  37.         Next
  38.     Next
  39.     For y = 0 To yymax - 2 'fire based literally on 4 pixels below it like cellular automata
  40.         For x = 1 To xxmax - 1
  41.             f(x, y) = max((f(x - 1, y + 1) + f(x, y + 1) + f(x + 1, y + 1) + f(x - 1, y + 2)) / 4 - 5, 0)
  42.             Line (x * xstep, y * ystep)-Step(xstep, ystep), p&(f(x, y)), BF
  43.         Next
  44.     Next
  45.     _Display
  46.     _Limit 30
  48.  
  49. Function max (a, b)
  50.     If a > b Then max = a Else max = b
  52.  

Pages: [1] 2 3 ... 115