QB64.org Forum

Active Forums => Programs => Topic started by: Petr on January 19, 2021, 03:15:49 pm

Title: Disappearing drawing
Post by: Petr on January 19, 2021, 03:15:49 pm

Download the attached file and you will see a message for developers. Then delete the GOTO statement at the beginning and you can create your own messages. It's just a little thing I played with today.

Code: QB64: [Select]

1. SCREEN _NEWIMAGE(1280, 720, 32)
2.  
3. TYPE Pojnt
4.     X AS INTEGER
5.     Y AS INTEGER
6. END TYPE
7. REDIM B(0) AS Pojnt
8.  
9.  
10. GOTO loader 'erase this row for full program function after first run :)
11.  
12. ' in this block - draw something (bigger image is better) to screen
13. ' -----------------------------------------------------------------
14. DO UNTIL _KEYHIT = 27
15.     WHILE _MOUSEINPUT
16.     WEND
17.     OMX = mx
18.     OMY = my
19.     mx = _MOUSEX
20.     my = _MOUSEY
21.     LB = _MOUSEBUTTON(1)
22.     IF LB AND OMX <> mx OR LB AND OMY <> my THEN
23.         B(i).X = mx
24.         B(i).Y = my
25.         i = i + 1
26.         CircleFill mx, my, 5, &HFFFFFF00
27.         REDIM _PRESERVE B(i) AS Pojnt
28.     END IF
29. LOOP
30. ' --------------------------------------------------------------------
31.  
32.  
33. ' in this block: Save your work as compressed binary file to harddrive
34. ' --------------------------------------------------------------------
35. DIM Save AS _MEM
36. Save = _MEMNEW((i + 1) * 4)
37. _MEMPUT Save, Save.OFFSET, B()
38. uncompress$ = SPACE$(i * 4)
39. _MEMGET Save, Save.OFFSET, uncompress$
40. Compress$ = _DEFLATE$(uncompress$)
41. ff = FREEFILE
42. OPEN "MizejiciText.sav" FOR BINARY AS ff
43. PUT ff, 1, Compress$
44. CLOSE ff
45. _MEMFREE Save
46. ' ---------------------------------------------------------------------
47.  
48. ' RESET ALL VALUES TO ZERO
49. ' ------------------------
50. loader:
51. i = 0
52. REDIM B(0) AS Pojnt
53.  
54.  
55. ' Load Values from file to memory, decompress it and palce it back to array
56. ' -------------------------------------------------------------------------
57. ff = FREEFILE
58. OPEN "MizejiciText.sav" FOR BINARY AS ff
59. Load$ = SPACE$(LOF(ff))
60. GET ff, , Load$ '                      compressed string
61. Uncompressed$ = _INFLATE$(Load$)
62. i = LEN(Uncompressed$)
63. DIM ArrMEM AS _MEM
64. ArrMEM = _MEMNEW(i)
65. _MEMPUT ArrMEM, ArrMEM.OFFSET, Uncompressed$
66. i = i \ 4
67. REDIM B(i) AS Pojnt
68. ii = 0
69. DO UNTIL ii = i
70.     B(ii).X = _MEMGET(ArrMEM, ArrMEM.OFFSET + fill, INTEGER)
71.     B(ii).Y = _MEMGET(ArrMEM, ArrMEM.OFFSET + fill + 2, INTEGER)
72.     fill = fill + 4
73.     ii = ii + 1
74. LOOP
75. _MEMFREE ArrMEM
76. '---------------------------------------------------------------------------
77.  
78. '-------------- DRAW IT ------------
79. CLS
80. lenght = 1000
81. j = 0
82. DO
83.     Shift = 255 / lenght
84.     DO UNTIL j = i
85.         IF k > lenght THEN
86.             alfa = 0
87.             FOR sm = j TO j - lenght STEP -1
88.                 IF sm > -1 AND sm < i - 1 THEN CircleFill B(sm).X, B(sm).Y, 5, _RGBA32(0, 0, 20, alfa)
89.                 alfa = alfa + Shift
90.             NEXT
91.             j = j + 1
92.         END IF
93.         k = k + 1
94.         IF k <= i - 1 THEN CircleFill B(k).X, B(k).Y, 5, &HFFFF0000
95.         _LIMIT 100
96.     LOOP
97.     CLS
98.     j = 0
99.     k = 0
100. LOOP
101.  
102.  
103.  
104. SUB CircleFill (CX AS INTEGER, CY AS INTEGER, R AS INTEGER, C AS _UNSIGNED LONG)
105.     ' CX = center x coordinate
106.     ' CY = center y coordinate
107.     '  R = radius
108.     '  C = fill color
109.     DIM Radius AS INTEGER, RadiusError AS INTEGER
110.     DIM X AS INTEGER, Y AS INTEGER
111.     Radius = ABS(R)
112.     RadiusError = -Radius
113.     X = Radius
114.     Y = 0
115.     IF Radius = 0 THEN PSET (CX, CY), C: EXIT SUB
116.     LINE (CX - X, CY)-(CX + X, CY), C, BF
117.     WHILE X > Y
118.         RadiusError = RadiusError + Y * 2 + 1
119.         IF RadiusError >= 0 THEN
120.             IF X <> Y + 1 THEN
121.                 LINE (CX - Y, CY - X)-(CX + Y, CY - X), C, BF
122.                 LINE (CX - Y, CY + X)-(CX + Y, CY + X), C, BF
123.             END IF
124.             X = X - 1
125.             RadiusError = RadiusError - X * 2
126.         END IF
127.         Y = Y + 1
128.         LINE (CX - X, CY - Y)-(CX + X, CY - Y), C, BF
129.         LINE (CX - X, CY + Y)-(CX + X, CY + Y), C, BF
130.     WEND
131. END SUB
132.  

Title: Re: Disappearing drawing
Post by: FellippeHeitor on January 19, 2021, 03:21:31 pm

Thank you! ❤️

And that's a very cool effect!

Title: Re: Disappearing drawing
Post by: Petr on January 19, 2021, 03:45:15 pm

@FellippeHeitor  Thank you :)

Text Only | Text with Attachments