My wish

[Petr]

I want something for you all. Why not say this with program :-D

Code: QB64: [Select]

1. REDIM P0(0, 0) AS INTEGER
2. REDIM p1(0, 0) AS INTEGER
3. REDIM p2(0, 0) AS INTEGER
4. REDIM p3(0, 0) AS INTEGER
5. REDIM p4(0, 0) AS INTEGER
6. REDIM p5(0, 0) AS INTEGER
7. REDIM p6(0, 0) AS INTEGER
8. DIM SHARED image AS LONG, ext
9.  
10. a& = _NEWIMAGE(800, 600, 32): _FULLSCREEN
11. SCREEN a&
12. CLS , _RGB32(6, 89, 244)
13. image& = _NEWIMAGE(50, 50, 32)
14.  
15. _PUTIMAGE , CB&, image&
16. _CLEARCOLOR _RGB32(0, 0, 0), image&
17. _FREEIMAGE CB&
18.  
19. text$ = "Petr"
20. TextToArray P0(), text$
21. TextToArray p1(), "wish"
22. TextToArray p2(), "you"
23. TextToArray p3(), "a"
24. TextToArray p4(), "lot"
25. TextToArray p5(), "of"
26. TextToArray p6(), "fun!"
27.  
28. m = (LEN(text$) * 8) / 2
29. n = 16
30. o = 12
31. p = 4
32. q = 12
33. r = 8
34. s = 16
35.  
36. DO
37.     ToScreen P0(), m, 20
38.     ToScreen p1(), n, 20
39.     ToScreen p2(), o, 20
40.     ToScreen p3(), p, 20
41.     ToScreen p4(), q, 20
42.     ToScreen p5(), r, 20
43.     ToScreen p6(), s, 20
44. LOOP UNTIL _KEYHIT = 27
45. SCREEN 0
46. _FREEIMAGE image&
47. ERASE P0, p1, p2, p3, p4, p5, p6
48. END
49.  
50. SUB ToScreen (array() AS INTEGER, lenght AS _BYTE, speed AS _UNSIGNED _BYTE)
51.     FOR sx = -15 TO 20 STEP .4
52.         CLS , _RGB32(6, 89, 244)
53.         DrawArray array(), _WIDTH / 2 - (sx * lenght), _HEIGHT / 2 - sx * 8, sx, sx
54.         _LIMIT speed
55.         _DISPLAY
56.     NEXT sx
57.     _DELAY .5
58. END SUB
59.  
60. SUB DrawArray (p() AS INTEGER, posx, posy, roztecx, roztecy)
61.     MaxX = UBOUND(p, 1): MaxY = UBOUND(p, 2)
62.     MinX = LBOUND(p, 1): MinY = LBOUND(p, 2)
63.     FOR y = MinY TO MaxY
64.         FOR x = MinX TO MaxX
65.             IF p(x, y) THEN _PUTIMAGE (posx + (x * roztecx), posy + (y * roztecy)), image&
66.             IF _KEYHIT = 27 THEN pad p(), x, y, roztecx, roztecy, posx, posy
67.     NEXT x, y
68. END SUB
69.  
70. SUB pad (p() AS INTEGER, x AS INTEGER, y AS INTEGER, roztecx, roztecy, posx, posy)
71.     MaxX = UBOUND(p, 1): MaxY = UBOUND(p, 2)
72.     MinX = LBOUND(p, 1): MinY = LBOUND(p, 2)
73.  
74.     DO WHILE Down < 800
75.         CLS , _RGB32(6, 89, 244)
76.         FOR y = MinY TO MaxY
77.             Down = Down + RND * 5
78.             FOR x = MinX TO MaxX
79.                 IF p(x, y) THEN _PUTIMAGE (posx + (x * roztecx), (posy + (y * roztecy)) + Down), image&
80.             NEXT
81.         NEXT
82.         _LIMIT 15
83.         _DISPLAY
84.     LOOP
85.     SCREEN 0
86.     _FREEIMAGE image&
87.     END
88. END SUB
89.  
90. SUB TextToArray (array( x , y) AS INTEGER, text AS STRING)
91.     v& = _NEWIMAGE(LEN(text$) * 8, 16, 256)
92.     REDIM array(LEN(text$) * 8, 16)
93.     _DEST v&
94.     _PRINTSTRING (1, 1), text$, v&
95.     _DEST 0
96.     _SOURCE v&
97.     FOR y = 0 TO 15
98.         PRINT
99.         FOR x = 0 TO 8 * LEN(text$) - 1
100.             IF POINT(x, y) THEN array(x, y) = 1
101.     NEXT x, y
102.     _DEST 0: _SOURCE 0
103. END SUB
104.  
105. FUNCTION CB&
106.     CB& = _NEWIMAGE(40, 40, 256)
107.     FOR F = 31 TO 16 STEP -1
108.         rd = rd + 1
109.         FOR R = 0 TO _PI(2) STEP .01
110.             _DEST CB&
111.             CIRCLE (SIN(R) + 20, COS(R) + 20), rd, F
112.     NEXT R, F
113. END FUNCTION
114.  

[johnno56]

Cool... Thank you!

J

[bplus]

Hi Petr (and all!),

I have coded a reply! After extracting zip file, load and run .bas file, press p for play...