Форум программистов, компьютерный форум CyberForum.ru
Наши страницы

QBasic

Войти
Регистрация
Восстановить пароль
 
 
Рейтинг: Рейтинг темы: голосов - 397, средняя оценка - 4.85
Quiet Snow
4373 / 1235 / 208
Регистрация: 25.04.2010
Сообщений: 3,027
#1

Графика на бейсике - QBasic

16.08.2010, 02:10. Просмотров 53807. Ответов 57
Метки нет (Все метки)

Здравствуйте уважаемые участники форума и администрация!

Уже давно заметил, что "скудновато" в данном разделе по прикреплённым темам, есть предложение закрепить топик, освещая следующие вопросы:

1) Обсуждаем графические приложения, написанные на бейсике(любые MS-DOS компиляторы)
2) Выкладываем разные "поучительные" примеры

Понимаете, область далеко не самая простая, хочется развеить предрассудки о том что бейсик мол "игрушка", отсталый язык, есть же "сильные" программы, использующие разные ухищрения. Короче хочется чтобы было больше дискуссий на эту тему. В рамках форума можно решать самые разнообразные вопросы, от вопросов алгоритмизации до выбора стратегии оптимизации, от простых до сложных.

Что подразумевается под графическими приложениями:
- В первую очередь программы работающие в графическом режиме, с упором на вывод графики.
- Разные рисунки, анимация, эффекты, воспроизводящиеся непосредственно в программе.
- Мультимедиа приложения и игры.
- Обычные программы использующие средства для вывода графики.

Также можно обсуждать и выкладывать какие-либо вспомогательные программы(будь то конвертер или редактор), идеологические аспекты, т.е. допустим один человек предлагает идею - другой реализовывает.

Вообщем если найдутся энтузиасты поддержать топик, буду очень рад. Хочется чтобы в разделе было больше посетителей и чтоб форум не "сдох".
7
Similar
Эксперт
41792 / 34177 / 6122
Регистрация: 12.04.2006
Сообщений: 57,940
16.08.2010, 02:10
Здравствуйте! Я подобрал для вас темы с ответами на вопрос Графика на бейсике (QBasic):

решение задач на бейсике - QBasic
прошу, помогите с решением номера 98 и 99

Текстовые игры на бейсике - QBasic
Подскажите, можно ли сделать что-то похожее на тиду или мир теней (или еще что-то от playtox)в среде бейсика? Заранее спасибо. ...

Функция на бейсике - Basic
помогите пожалуйста сделать задание) составить функцию на Бейсике для вычисления заданной функции.Составьте программу вводящую с клавиатуры...

Программы на Паскале И Бейсике - Basic
Помогите решить: 5.Составить программу, с помощью которой получить цвет¬ной рисунок «Робот». А эту в Бейсике. Заранее спасибо.

Можно ли на Бейсике писать хак-софт? - Basic
Можно ли на Бейсике писать хакерские программы, типа брутфорсов, чекеров, спамеров, грабберов, реггеров и тд.?

составить разветвляющую программу в бейсике при заранее неизвестных значениях параметров - Basic
Пожалуйста помогите нубу составить разветвляющую программу в бейсике при заранее неизвестных значениях параметров

Надоела реклама? Зарегистрируйтесь и она исчезнет полностью.
velvet1545
6 / 9 / 0
Регистрация: 21.05.2011
Сообщений: 81
23.05.2011, 23:26 #31
ребята знаете что формат бмп шифрованый?

когда я поставил задачу перед собой сделать вьюер бмп файлов я перед этим не знал этого
паришлось в ручную разгадывать его шифр

коекак разгадал получился бмп 256 цветных файлов вьер под кубейсиком

Добавлено через 4 минуты
идеальный графический формат где нет избыточныйх вредных затормаживающих байтов в конце каждой полоски бмп

и где файл не перевернут с ног на голову

тело картинки побайтно и таблица цветов для 256цветного режима а название формата
*.256

да здраствует этот формат файла

ура ура ура

pcx gif отдыхает..
0
Quiet Snow
4373 / 1235 / 208
Регистрация: 25.04.2010
Сообщений: 3,027
24.05.2011, 06:04  [ТС] #32
Народ, давайте не будем разводить демагогий, монологов и разный оффтоп в закреплённом топике, создавайте отдельные темы для отдельных вопросов, тут постим программы и обсуждаем конкретно их.
Надеюсь на понимание.
0
softmob
1248 / 698 / 155
Регистрация: 20.02.2010
Сообщений: 1,035
16.06.2011, 23:49 #33
фрактал Martin.
PureBasic
1
2
3
4
5
6
7
SCREEN 12
WHILE INKEY$ = ""
    t = x
    x = y - SIN(x)
    y = 3.14 - t
    PSET (2 * x + 320, 2 * y + 240), 4
WEND
4
Миниатюры
Графика на бейсике  
Quiet Snow
4373 / 1235 / 208
Регистрация: 25.04.2010
Сообщений: 3,027
29.07.2011, 03:07  [ТС] #34
Небольшая демка, кривые безье + брозенхем с эмуляцией антиналожения.
Скриншот можно взять кнопкой "S".
4
Миниатюры
Графика на бейсике  
Вложения
Тип файла: zip BEZIER2.zip (2.7 Кб, 70 просмотров)
Quiet Snow
4373 / 1235 / 208
Регистрация: 25.04.2010
Сообщений: 3,027
29.05.2012, 03:46  [ТС] #35
Программа для построения графиков функций, закину сюда в тему, чтобы не искать потом.
Автоматически подбирает масштабы по осям, исходя из границ всех графиков.
Наклепал 5 графиков, больше вероятно и не потребуется, необходимо тестирование.
QBasic/QuickBASIC
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
SCREEN 12
CONST Pi = 3.141592653589793#
DIM MinX, MinY, MaxX, MaxY
DIM XRazn, YRazn, MnogX, MnogY
DIM StpScX AS INTEGER, StpScY AS INTEGER
  '  Функции графиков
  DEF FnY1 (x) = SIN(x)
  DEF FnY2 (x) = COS(x)
  DEF FnY3 (x) = x / 2
  DEF FnY4 (x) = x * x * .1
  DEF FnY5 (x) = SQR(EXP(x)) * .3
 '  Ф-ция поиска границ
DEF FnMinMax (x, y)
    IF x < MinX THEN MinX = x
    IF x > MaxX THEN MaxX = x
    IF y < MinY THEN MinY = y
    IF y > MaxY THEN MaxY = y
END DEF
 '  Экранное преобразование
DEF FnGetX (x) = x * MnogX - MinX * MnogX
DEF FnGetY (y) = y * MnogY - MaxY * MnogY
 '  Параметры трассировки функций
Str1 = -Pi: Str2 = -Pi: Str3 = -Pi: Str4 = -Pi: Str5 = -Pi
End1 = Pi: End2 = Pi: End3 = Pi: End4 = Pi: End5 = Pi
Stp1 = .01: Stp2 = .03: Stp3 = .1: Stp4 = .1: Stp5 = .1
 '  Переменные для трассировки
x1 = Str1: x2 = Str2: x3 = Str3: x4 = Str4: x5 = Str5
y1 = FnY1(x1): y2 = FnY2(x2): y3 = FnY3(x3): y4 = FnY4(x4): y5 = FnY5(x5)
 '  Вычисляем параметры графиков
DO
  Go = 0: y1 = FnY1(x1): y2 = FnY2(x2): y3 = FnY3(x3)
  y4 = FnY4(x4): y5 = FnY5(x5)
  IF x1 < End1 THEN x1 = x1 + Stp1: y1 = FnY1(x1): Go = -1
  IF x2 < End2 THEN x2 = x2 + Stp2: y2 = FnY2(x2): Go = -1
  IF x3 < End3 THEN x3 = x3 + Stp3: y3 = FnY3(x3): Go = -1
  IF x4 < End4 THEN x4 = x4 + Stp4: y4 = FnY4(x4): Go = -1
  IF x5 < End5 THEN x5 = x5 + Stp5: y5 = FnY5(x5): Go = -1
  i = FnMinMax(x1, y1)     '  Ищем границы
  i = FnMinMax(x2, y2)
  i = FnMinMax(x3, y3)
  i = FnMinMax(x4, y4)
  i = FnMinMax(x5, y5)
LOOP WHILE Go
  PRINT
  PRINT "  "; INT(MinX); INT(MinY); INT(MaxX); INT(MaxY)
 '  Реинициализация трассировки
x1 = Str1: x2 = Str2: x3 = Str3: x4 = Str4: x5 = Str5
y1 = FnY1(x1): y2 = FnY2(x2): y3 = FnY3(x3): y4 = FnY4(x4): y5 = FnY5(x5)
 '  Старые координаты(Прошлый шаг трассировки)
xo1 = x1: xo2 = x2: xo3 = x3: xo4 = x4: xo5 = x5
yo1 = y1: yo2 = y2: yo3 = y3: yo4 = y4: yo5 = y5
 '  Делаем фрейм пошире, чтобы больше было видно
 '  + сетку, если она где-то рядом
 XRazn = MaxX - MinX
 YRazn = MinY - MaxY
 MinX = MinX - XRazn / 4
 MaxX = MaxX + XRazn / 4
 MinY = MinY + YRazn / 4
 MaxY = MaxY - YRazn / 4
 '  Для преобразования координат в экранные
XRazn = MaxX - MinX    ' Разности координат графиков
YRazn = MinY - MaxY
  IF XRazn = 0 THEN XRazn = .00001
  IF YRazn = 0 THEN YRazn = .00001
MnogX = 640 / XRazn    ' Отнош. к разностям коо. гр.
MnogY = 480 / YRazn
StpScX = 1: StpScY = 1 ' Шаг сетки
 '  Если сетка не умещается увеличиваем шаг сетки
DO: ScTst = 0
  IF ABS(XRazn / StpScX) > 160 THEN StpScX = StpScX * 10: ScTst = -1
  IF ABS(YRazn / StpScY) > 120 THEN StpScY = StpScY * 10: ScTst = -1
LOOP WHILE ScTst
 
 '  Нарисуем сетку
DlSc = SQR(1 / ABS(XRazn / StpScX) + 1 / ABS(XRazn / StpScX)) * 10
IF DlSc > 10 THEN DlSc = 10
IF DlSc < 2 THEN DlSc = 2
LINE (FnGetX(MinX), FnGetY(0))-(FnGetX(MaxX), FnGetY(0)), 8
LINE (FnGetX(0), FnGetY(MinY))-(FnGetX(0), FnGetY(MaxY)), 8
FOR i = INT(MinX) TO INT(MaxX) STEP StpScX
  LINE (FnGetX(i), FnGetY(0) - DlSc)-(FnGetX(i), FnGetY(0) + DlSc), 8
NEXT
FOR i = INT(MinY) TO INT(MaxY) STEP StpScY
  LINE (FnGetX(0) - DlSc, FnGetY(i))-(FnGetX(0) + DlSc, FnGetY(i)), 8
NEXT
 
 '  Рисуем графики
DO
  Go = 0: y1 = FnY1(x1): y2 = FnY2(x2): y3 = FnY3(x3)
  IF x1 < End1 THEN x1 = x1 + Stp1: y1 = FnY1(x1): Go = -1
  IF x2 < End2 THEN x2 = x2 + Stp2: y2 = FnY2(x2): Go = -1
  IF x3 < End3 THEN x3 = x3 + Stp3: y3 = FnY3(x3): Go = -1
  IF x4 < End4 THEN x4 = x4 + Stp4: y4 = FnY4(x4): Go = -1
  IF x5 < End5 THEN x5 = x5 + Stp5: y5 = FnY5(x5): Go = -1
    LINE (FnGetX(xo1), FnGetY(yo1))-(FnGetX(x1), FnGetY(y1)), 9
    LINE (FnGetX(xo2), FnGetY(yo2))-(FnGetX(x2), FnGetY(y2)), 10
    LINE (FnGetX(xo3), FnGetY(yo3))-(FnGetX(x3), FnGetY(y3)), 7
    LINE (FnGetX(xo4), FnGetY(yo4))-(FnGetX(x4), FnGetY(y4)), 12
    LINE (FnGetX(xo5), FnGetY(yo5))-(FnGetX(x5), FnGetY(y5)), 14
  xo1 = x1: xo2 = x2: xo3 = x3: xo4 = x4: xo5 = x5  ' Старые координаты
  yo1 = y1: yo2 = y2: yo3 = y3: yo4 = y4: yo5 = y5
LOOP WHILE Go
 
WHILE INKEY$ = "": WEND   ' Ждать кнопку
3
PAnT0P
1016 / 539 / 70
Регистрация: 26.03.2012
Сообщений: 981
16.06.2012, 13:58 #36
Векторный шрифт
QBasic/QuickBASIC
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
DECLARE SUB DrawText (Text AS STRING, X AS INTEGER, Y AS INTEGER, FontColor AS INTEGER, FontSize AS INTEGER, FontAngle AS INTEGER)
 
SCREEN 12
DIM SHARED Font(223) AS STRING
DIM I AS INTEGER
RESTORE FontData
FOR I = 0 TO 223
    READ Font(I)
NEXT I
'Демо
DrawText " !" + CHR$(34) + "#$%&'()*+,-./0123456789:;<=>?@", 50, 50, 15, 4, 0
DrawText "ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_`", 50, 100, 14, 4, 0
DrawText "abcdefghijklmnopqrstuvwxyz{|}~в€љ№в–*", 50, 150, 12, 4, 0
DrawText "АБВГДЕЁЖЗИЙКЛМНОПРСТУФХЦЧШЩЪЫЬЭЮЯ", 50, 200, 11, 4, 0
DrawText "абвгдеёжзийклмнопрстуфхцчшщъыьэюя", 50, 250, 10, 4, 0
DrawText "1", 50, 400, 13, 1, 0
DrawText "2", 60, 400, 13, 2, 0
DrawText "3", 75, 400, 13, 3, 0
DrawText "4", 95, 400, 13, 4, 0
DrawText "5", 120, 400, 13, 5, 0
DrawText "6", 150, 400, 13, 6, 0
DrawText "7", 185, 400, 13, 7, 0
DrawText "8", 225, 400, 13, 8, 0
DrawText "9", 260, 400, 13, 9, 0
DrawText "10", 310, 400, 13, 10, 0
DrawText "     Вращение 0", 500, 350, 9, 2, 0
DrawText "     Вращение 45", 500, 350, 9, 2, 45
DrawText "     Вращение -45", 500, 350, 9, 2, -45
DrawText "     Вращение 90", 500, 350, 9, 2, 90
DrawText "     Вращение -90", 500, 350, 9, 2, -90
DrawText "     Вращение 135", 500, 350, 9, 2, 135
DrawText "     Вращение 180", 500, 350, 9, 2, 180
DrawText "     Вращение -135", 500, 350, 9, 2, -135
 
'Правила построения символов:
'Общая высота символа 9 единиц, ширина может быть любой.
'Рисование всегда начинается в точке A и заканчивается в точке C
'При рисовании символа можно использовать все команды оператора DRAW,
'за исключением команд вращения, масштаба и цвета.
'Пример (символ Щ):
DATA "NU5R2NU4R2NU5RDBE"
'0 0 0 0 0 0
'0 0 0 0 0 0
'B 0 0 0 B 0
'B 0 B 0 B 0
'B 0 B 0 B 0
'B 0 B 0 B 0
'B 0 B 0 B 0
'A B B B B B C
'0 0 0 0 0 B
FontData:
DATA "BR2"                                  : REM Пробел
DATA "NURUNLBUU3LM+1,+3BF2"                 : REM !
DATA "BU4UBRDBD4BR"                         : REM "
DATA "BU3NR3BUNR3BEND3BRD3BR2BD2"           : REM #
DATA "BUFEH2ENUNFD5BRBE"                    : REM $
DATA "BRRULNDBLE3BLLURDBD4BR2"              : REM %
DATA "BR4HUHLGDFREEBLNDHLHERFGBF3"          : REM &
DATA "BU5DENLBD5BR"                         : REM '
DATA "BRBU5GD3FBR"                          : REM (
DATA "BU5FD3GBR2"                           : REM )
DATA "BU3R2BDH2BD2E2BD4BR"                  : REM *
DATA "BU3R2BHD2BD2BR2"                      : REM +
DATA "BURGURBF"                             : REM ,
DATA "BU3R2BD3BR"                           : REM -
DATA "URDLBR2"                              : REM .
DATA "M+2,-5BD5BR"                          : REM /
DATA "BUU3ERFNM-3,+3D3GLHBDBR4"             : REM 0
DATA "BU4ED5LR2BR"                          : REM 1
DATA "BU3UERFDG3R3BR"                       : REM 2
DATA "BU5R3DGFDGLHBR4BD"                    : REM 3
DATA "BR3U5G3DR4BF"                         : REM 4
DATA "BUFREUHL2U2R3BD5BR"                   : REM 5
DATA "BU2ERFDGLHU3ERFBD4BR"                 : REM 6
DATA "BU5R3DM-2,+4BR3"                      : REM 7
DATA "BUUEREHLGFRFDGLHBR4BD"                : REM 8
DATA "BUFREU3HLGDFREBD3BR"                  : REM 9
DATA "URDLBU3URDLBR2BD3"                    : REM :
DATA "URGBU3URDLBD3BR2"                     : REM ;
DATA "BR2M-2,-2M+2,-2BD4BR"                 : REM <
DATA "BU2R2BUNL2BD3BR"                      : REM =
DATA "M+2,-2M-2,-2BD4BR3"                   : REM >
DATA "BU4ERFGDBDDLURBBFBR"                  : REM ?
DATA "BEBUURDNLEHLGD2FRBR2"                 : REM @
DATA "U4ER2D3NL3D2BR"                       : REM A
DATA "U5R2FGNL2FDGL2BR4"                    : REM B
DATA "BE3BUHLGD3FREBF"                      : REM C
DATA "U5R2FD3GL2BR4"                        : REM D
DATA "BU5BR3L3D2NR2D3R3BR"                  : REM E
DATA "U2NR2U3R3DBD4BR"                      : REM F
DATA "BE2RDGLHU3ERFBD4BR"                   : REM G
DATA "U3NU2R3NU2D3BR"                       : REM H
DATA "RNRU5NLRBD5BR"                        : REM I
DATA "BUNUFREU4NL3BD5BR"                    : REM J
DATA "U3NU2RNM+2,-2M+2,+3BR"                : REM K
DATA "NU5R3NUBR"                            : REM L
DATA "M+1,-5M+1,+5M+1,-5M+1,+5BR"           : REM M
DATA "U5M+3,+5NU5BR"                        : REM N
DATA "BUU3ERFD3GLHBDBR4"                    : REM O
DATA "U5R2FDGL2BR4BD2"                      : REM P
DATA "BUU3ERFD3GLHBRRFBR"                   : REM Q
DATA "U5R2FDGLNLF2BR"                       : REM R
DATA "BUFREUHLHERFBD4BR"                    : REM S
DATA "BR2U5BL2BDUR4DBD4BR"                  : REM T
DATA "BU5D4FRENU4BF"                        : REM U
DATA "BU5M+1,+5RNM+1,-5BR2"                 : REM V
DATA "BU5M+1,+5M+1,-5M+1,+5NM+1,-5BR2"      : REM W
DATA "M+3,-5BL3M+3,+5BR"                    : REM X
DATA "BRU2NM-1,-3NM+1,-3BF2"                : REM Y
DATA "BU4UR3DG3DR3NUBR"                     : REM Z
DATA "BU5NRD5RBR"                           : REM [
DATA "BU5M+2,+5BR"                          : REM \
DATA "BU5RD5NLBR"                           : REM ]
DATA "BU4M+1,-1M+1,+1BD4BR"                 : REM ^
DATA "BDR2BE"                               : REM _
DATA "BU5FBD4BR"                            : REM `
DATA "BU3EFD2GHERD2BR"                      : REM a
DATA "NU5REUHLBF3"                          : REM b
DATA "BE3HLGD2FREBF"                        : REM c
DATA "BE2BULGDFRNU5BR"                      : REM d
DATA "BU2R2EHLGD2FREBF"                     : REM e
DATA "BRU2NLNRU2ERBD5BR"                    : REM f
DATA "BE2BU2LGDFRNU3DNGBR"                  : REM g
DATA "U3NU2RFD2BR"                          : REM h
DATA "RNRU3NLBUUBD5BR2"                     : REM i
DATA "FEU3NLBUUBD5BR"                       : REM j
DATA "U2NU3NE2F2BR"                         : REM k
DATA "BUNU4FBR"                             : REM l
DATA "U3NUEDND3ED4BR"                       : REM m
DATA "U3NUEFD3BR"                           : REM n
DATA "BUU2ER1FD2GL1HBDBR4"                  : REM o
DATA "U4RFDGLBR3BD"                         : REM p
DATA "BE2BU2LGDFRNU3D2BE"                   : REM q
DATA "U3NUERBD4BR"                          : REM r
DATA "BUFREHLHERFBD3BR"                     : REM s
DATA "BRBU5D2NLNRD2FEBF"                    : REM t
DATA "BU4D3FRENU3DBR"                       : REM u
DATA "BU4M+1,+4NM+1,-4BR2"                  : REM v
DATA "BU4M+1,+4M+1,-4M+1,+4NM+1,-4BR2"      : REM w
DATA "M+2,-4BL2M+2,+4BR"                    : REM x
DATA "BU4M+1,+2ND2NM+1,-2BF2"               : REM y
DATA "BU3UR2M-2,+4R2NUBR"                   : REM z
DATA "BU4BR2GDNLDFBR"                       : REM {
DATA "NU4BR"                                : REM |
DATA "BU4FDNRDGBR3"                         : REM }
DATA "BU2EF2EBD2BR"                         : REM ~
DATA "U7R4D8L4UBR5"                         : REM Рамка
DATA "U4ER2D3NL3D2BR"                       : REM А
DATA "BU3R2FDGL2U5R3BD5BR"                  : REM Б
DATA "U5R2FGNL2FDGL2BR4"                    : REM В
DATA "U5R3DBD4BR"                           : REM Г
DATA "BDURM+1,-5RD5NL2RDBE"                 : REM Д
DATA "BU5BR3L3D2NR2D3R3BR"                  : REM Е
DATA "U2ER2FD2BL4BU5DFR2EUBL2D5BR3"         : REM Ж
DATA "BUFREUHEHLGBF4"                       : REM З
DATA "NU5M+3,-5D5BR"                        : REM И
DATA "NU5M+3,-5ND5BUBL2RBR2BD6"             : REM Й
DATA "U3NU2RNM+2,-2M+2,+3BR"                : REM К
DATA "M+2,-5RD5BR"                          : REM Л
DATA "M+1,-5M+1,+5M+1,-5M+1,+5BR"           : REM М
DATA "U3NU2R3NU2D3BR"                       : REM Н
DATA "BUU3ERFD3GLHBDBR4"                    : REM О
DATA "U5R3D5BR"                             : REM П
DATA "U5R2FDGL2BR4BD2"                      : REM Р
DATA "BE3BUHLGD3FREBF"                      : REM С
DATA "BR2U5BL2BDUR4DBD4BR"                  : REM Т
DATA "BUFREU4BL3D2FR2BD2BR"                 : REM У
DATA "BR2U5RFD2GL2HU2ERBR3BD5"              : REM Ф
DATA "M+3,-5BL3M+3,+5BR"                    : REM Х
DATA "NU5R2NU5RDBE"                         : REM Ц
DATA "BR3U5BL3D2FR2BD2BR"                   : REM Ч
DATA "NU5R2NU4R2NU5BR"                      : REM Ш
DATA "NU5R2NU4R2NU5RDBE"                    : REM Щ
DATA "BU4URD5R2EUHL2BF3BR"                  : REM Ъ
DATA "BU3R2FDGL2U5BR4D5BR"                  : REM Ы
DATA "BU5D5R2EUHL2BF3BR"                    : REM Ь
DATA "BUFREU2NL2UHLGBF4"                    : REM Э
DATA "U3NU2RUERFD3GLHU3BF4"                 : REM Ю
DATA "E2NRLHUER2D5BR"                       : REM Я
DATA "BU3EFD2GHERD2BR"                      : REM а
DATA "BU2RFGLU3ERBD4BR"                     : REM б
DATA "U4RFGNLFGNLBR2"                       : REM в
DATA "U4R2DBD3BR"                           : REM г
DATA "BDURM+1,-4RD4NL2RDBUBR"               : REM д
DATA "BU2R2EHLGD2FREBF"                     : REM е
DATA "UENRHUBR2ND4BR2DGNLFDBR"              : REM ж
DATA "BU3ERFGNLFGLHBDBR4"                   : REM з
DATA "BU4D4M+2,-4D4BR"                      : REM и
DATA "BU4D4M+2,-4BLNUBRD4BR"                : REM й
DATA "U2NU2NE2F2BR"                         : REM к
DATA "M+1,-4RD4BR"                          : REM л
DATA "M+1,-4M+1,+4M+1,-4M+1,+4BR"           : REM м
DATA "U2NU2R2NU2D2BR"                       : REM н
DATA "BUU2ER1FD2GL1HBDBR4"                  : REM о
DATA "U4R2D4BR"                             : REM п
DATA ""
DATA ""
DATA ""
DATA ""
DATA ""
DATA ""
DATA ""
DATA ""
DATA ""
DATA ""
DATA ""
DATA ""
DATA ""
DATA ""
DATA ""
DATA ""
DATA ""
DATA ""
DATA ""
DATA ""
DATA ""
DATA ""
DATA ""
DATA ""
DATA ""
DATA ""
DATA ""
DATA ""
DATA ""
DATA ""
DATA ""
DATA ""
DATA ""
DATA ""
DATA ""
DATA ""
DATA ""
DATA ""
DATA ""
DATA ""
DATA ""
DATA ""
DATA ""
DATA ""
DATA ""
DATA ""
DATA ""
DATA ""
DATA "U4RFDGLBR3BD"                         : REM р
DATA "BE3HLGD2FREBF"                        : REM с
DATA "BU3URND4RDBD3BR"                      : REM т
DATA "BU4D1FRNU2D1GLBR3"                    : REM у
DATA "BR2U4LGDFR2EUHLBD4BR3"                : REM ф
DATA "M+2,-4BL2M+2,+4BR"                    : REM х
DATA "BU4D4R2NU4RDBE"                       : REM ц
DATA "BU4D2FRNU3DBR"                        : REM ч
DATA "NU4RNU4RNU4BR"                        : REM ш
DATA "NU4RNU4RNU4RDBE"                      : REM щ
DATA "BU3URD4REUHLBF3"                      : REM ъ
DATA "BU3RFDGLU4BR3D4BR"                    : REM ы
DATA "NU4REUHLBF3"                          : REM ь
DATA "BUFREUNLUHLGBF3BR"                    : REM э
DATA "U2NU2RUERFD2GLHUBF2BR2"               : REM ю
DATA "ENRHUERD4BR"                          : REM я
DATA "BU7BRDBRUBRBD2L3D2NR2D3R3BR"          : REM Ё
DATA "BU2R2EHBUUBD2LBUUBD2GD2FREBF"         : REM ё
DATA ""
DATA ""
DATA ""
DATA ""
DATA ""
DATA ""
DATA ""
DATA ""
DATA ""
DATA "BU2RM+1,+2M+1,-5BD5BR"                : REM в€љ
DATA "U5M+2,+5U5RBDRDLNUBDRBD2BR"           : REM №
DATA ""
DATA "BU2URDLBF2"                           : REM в–*
DATA ""
 
SUB DrawText (Text AS STRING, X AS INTEGER, Y AS INTEGER, FontColor AS INTEGER, FontSize AS INTEGER, FontAngle AS INTEGER)
    'Text           Печатаемый текст
    'X              Горизонтальная позиция начала текста
    'Y              Вертикалная позиция начала текста
    'FontColor      Цвет шрифта
    'FontSize       Размер шрифта
    'FontAngle      Угол поворота текста
    DIM N AS INTEGER, I AS INTEGER
    DIM C AS STRING, S AS STRING, Message AS STRING, A AS STRING
    FOR N = 1 TO LEN(Text)
        I = ASC(MID$(Text, N, 1))
        I = I - 32
        Message = Message + RTRIM$(Font(I))
    NEXT N
    C = "C" + LTRIM$(RTRIM$(STR$(FontColor)))
    A = "TA" + LTRIM$(RTRIM$(STR$(FontAngle)))
    S = "S" + LTRIM$(RTRIM$(STR$(FontSize * 4)))
    Message = C + A + S + Message + "TA0"
    PSET (X, Y), POINT(X, Y)
    DRAW "X" + VARPTR$(Message):
END SUB
PS. Немного изменил код и внес исправление в начертание некоторых символов.
Модератору просьба удалить мое предыдущее сообщение.
5
Миниатюры
Графика на бейсике  
PAnT0P
1016 / 539 / 70
Регистрация: 26.03.2012
Сообщений: 981
07.07.2012, 11:47 #37
Ремейк Color Lines. Делалось на QBasic, но на QB тоже должен работать. Зачем делалось? Да скучно было во время дежурства.

PS. Че то мне понравилось, надо будет код прилизать и на VB.NET портануть
6
Миниатюры
Графика на бейсике   Графика на бейсике   Графика на бейсике  

Графика на бейсике  
Вложения
Тип файла: zip LINES.zip (94.3 Кб, 147 просмотров)
Quiet Snow
4373 / 1235 / 208
Регистрация: 25.04.2010
Сообщений: 3,027
06.04.2013, 05:44  [ТС] #38
Простенький тетрис на QBasic, написал вчера за вечер...
Это кстати мой первый тетрис , знаю что какашка редкостная, ну, что есть то есть...

QBasic/QuickBASIC
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
'
'  Тетрис v 0.2 Alfa
'  Авторство: >Quiet Snow<
'  (c) 2013
'_____________________________
 
  DECLARE SUB PrepareALL ()
  DECLARE SUB DeinitALL ()
  DECLARE SUB DrawPole ()
  DECLARE SUB ClearPole ()
  DECLARE SUB CheckLines ()
  DECLARE SUB SdvigPole ()
  DECLARE SUB CopyToTek (NumFigur%)
  DECLARE SUB CopyTekToPole ()
  DECLARE SUB PoleTekFigureDelete ()
  DECLARE SUB FreezeFigure ()
  DECLARE SUB SaveTekState ()
  DECLARE SUB NextFigureToMem (NumFigur%)
  DECLARE SUB RestoreTekState ()
  DECLARE SUB RotateRight ()
  DECLARE SUB RotateLeft ()
  DECLARE SUB EngineTick ()
  DECLARE SUB Delay (Delitel AS INTEGER)
  DECLARE SUB GoGame ()
  DECLARE SUB HelpScreen ()
  DECLARE SUB MainMenu ()
 
CONST CSize = 8     ' Размер ячейки поля
CONST NSize = 14    ' Размер ячейки поля след фигуры
CONST Figur = 7     ' Сколько фигур в наборе
 
CONST LSz = CSize - 2
CONST NSz = NSize - 2
CONST NfSz = NSize * 4
CONST ObvWdt = CSize * 10, ObvHgt = CSize * 20
DIM SHARED Tm AS LONG, TimerFactor AS LONG, TickControl AS INTEGER
DIM SHARED Kb$, Dn%
DIM SHARED Pole%(9, 23), Figura(Figur - 1, 3, 3) AS INTEGER
DIM SHARED TekF(3, 3) AS INTEGER, PosY%, PosX%, NewFigure%
DIM SHARED Collizion%, NextFigure%, RotF(3, 3) AS INTEGER
DIM SHARED StatF(3, 3) AS INTEGER, NxtF(3, 3) AS INTEGER
DIM SHARED Quit AS INTEGER, StartRound AS INTEGER, GmPause AS INTEGER
DIM SHARED EndRaund AS INTEGER, PlayScore&, FigCv%, NxFigCv%
DIM SHARED ix AS INTEGER, iy AS INTEGER, FstMul%(19), FstMul2%(3)
DIM SHARED px AS INTEGER, py AS INTEGER
DIM SHARED nfx AS INTEGER, nfy AS INTEGER
 
  PrepareALL
 
     MainMenu
 
  DeinitALL
  CLEAR
 
END
DnOn: Dn% = 1: RETURN
DnOff: Dn% = 0: RETURN
 
DATA 0,0,1,0
DATA 0,0,1,0
DATA 0,0,1,0
DATA 0,0,1,0
 
DATA 0,0,0,0
DATA 0,1,0,0
DATA 0,1,0,0
DATA 0,1,1,0
 
DATA 0,0,0,0
DATA 0,0,1,0
DATA 0,0,1,0
DATA 0,1,1,0
 
DATA 0,0,0,0
DATA 0,0,0,0
DATA 0,1,1,0
DATA 0,1,1,0
 
DATA 0,0,0,0
DATA 0,1,0,0
DATA 0,1,1,0
DATA 0,0,1,0
 
DATA 0,0,0,0
DATA 0,0,1,0
DATA 0,1,1,0
DATA 0,1,0,0
 
DATA 0,0,0,0
DATA 0,0,1,0
DATA 0,1,1,0
DATA 0,0,1,0
 
SUB CheckLines
DIM LnFill%, Porog AS INTEGER, Udy%
 iy = 23
 Porog = 4
 DO
    '  Проверка заполненности гориз. линии
    LnFill% = 1
    FOR ix = 0 TO 9
       IF Pole%(ix, iy) = 0 THEN LnFill% = 0
    NEXT
    '  Если заполнена
    IF LnFill% THEN
    PlayScore& = PlayScore& + 100
      FOR Udy% = iy TO Porog STEP -1
         FOR ix = 0 TO 9
            Pole%(ix, Udy%) = Pole%(ix, Udy% - 1)
         NEXT
      NEXT
      FOR ix = 0 TO 9
         Pole%(ix, Porog) = 0
      NEXT
      Porog = Porog + 1
    ELSE
      iy = iy - 1
    END IF
 LOOP UNTIL iy <= Porog
   '  Если уже некуда совать и выходит наверх
   '  То пора игроку сдаться
 FOR ix = 0 TO 9
    IF Pole%(ix, 3) = 1 THEN EndRaund = 1: EXIT FOR
 NEXT
END SUB
 
SUB ClearPole
FOR iy = 0 TO 23
  FOR ix = 0 TO 9
     Pole%(ix, iy) = 0
NEXT ix, iy
END SUB
 
SUB CopyTekToPole
DIM Ccx%, Ccy%
 FOR iy = 0 TO 3
    Ccy% = PosY% + iy
    FOR ix = 0 TO 3
       Ccx% = PosX% + ix
       '  Если попадает в поле
       IF Ccx% > -1 AND Ccx% < 10 AND Ccy% < 24 AND Ccy% >= 0 THEN
          IF TekF(ix, iy) = 2 AND Pole%(Ccx%, Ccy%) = 1 THEN Collizion% = 1
       ELSE
          IF TekF(ix, iy) = 2 THEN Collizion% = 1
       END IF
 NEXT ix, iy
IF PosY% > 20 THEN Collizion% = 1
IF Collizion% = 0 THEN
 FOR iy = 0 TO 3
    Ccy% = PosY% + iy
    FOR ix = 0 TO 3
       Ccx% = PosX% + ix
       '  Если попадает в поле
       IF Ccx% > -1 AND Ccx% < 10 AND Ccy% < 24 THEN
          IF TekF(ix, iy) = 2 THEN Pole%(Ccx%, Ccy%) = TekF(ix, iy)
       END IF
 NEXT ix, iy
END IF
END SUB
 
SUB CopyToTek (NumFigur%)
 FOR iy = 0 TO 3
    FOR ix = 0 TO 3
       IF Figura(NumFigur%, ix, iy) = 1 THEN
       TekF(ix, iy) = 2
       ELSE : TekF(ix, iy) = 0
       END IF
 NEXT ix, iy
END SUB
 
SUB DeinitALL
  KEY(15) OFF
  KEY(16) OFF
END SUB
 
SUB Delay (Delitel AS INTEGER)
 Td = Tm \ Delitel
 Tmr = 0
 DO
   Tmr = Tmr + 1: f = TIMER
 LOOP UNTIL Tmr > Td
END SUB
 
SUB DrawPole
 
FOR iy = 0 TO 19
  FOR ix = 0 TO 9
     'IF Pole%(ix, iy + 4) THEN Cv% = 7 ELSE Cv% = 0
     SELECT CASE Pole%(ix, iy + 4)
       CASE 1: Cv% = 8
       CASE 2: Cv% = FigCv%
       CASE ELSE: Cv% = 0
     END SELECT
     LINE (FstMul%(ix) + px, FstMul%(iy) + py)-STEP(LSz, LSz), Cv%, BF
NEXT ix, iy
LINE (px - 1, py - 1)-STEP(ObvWdt, ObvHgt), 7, B
 
FOR iy = 0 TO 3
  FOR ix = 0 TO 3
     IF NxtF(ix, iy) = 2 THEN Cv% = NxFigCv% ELSE Cv% = 0
     LINE (FstMul2%(ix) + nfx, FstMul2%(iy) + nfy)-STEP(NSz, NSz), Cv%, BF
NEXT ix, iy
LINE (nfx - 1, nfy - 1)-STEP(NfSz, NfSz), 7, B
 
END SUB
 
SUB EngineTick
DIM i AS INTEGER
DIM DnStatus%
 
 TickControl = TickControl + 1
 
   '  Старт раунда
   IF StartRound THEN
     ClearPole
     PlayScore& = 0
     NewFigure% = 1
     NextFigure% = INT(RND * Figur)
     StartRound = 0
   END IF
   '  Новая фигура
   IF NewFigure% THEN
     FigCv% = NxFigCv%
     CopyToTek NextFigure%  ' Откопируем новую фигуру в тек фигуру
     NextFigure% = INT(RND * Figur)
     NextFigureToMem NextFigure%
     NxFigCv% = 125 + RND * 26
     PosY% = -1: PosX% = 3  ' Фигура наверху по центру
     Collizion% = 0
     NewFigure% = 0         ' Пока новых фигур больше не надо
   END IF
  
  
   '  Управление
 
 
   LOCATE 1, 1: PRINT "Score: "; PlayScore&
   IF Dn% = 1 THEN DnStatus% = 0 ELSE DnStatus% = 10
     '  Фигуру по час стрелке
   IF Kb$ = "." OR Kb$ = "ю" OR Kb$ = "Ю" OR Kb$ = CHR$(0) + "H" THEN
     SaveTekState
     RotateRight
     CopyTekToPole
     IF Collizion% THEN
       RestoreTekState
       Collizion% = 0
     ELSE
       PoleTekFigureDelete
       CopyTekToPole
       DrawPole
     END IF
   END IF
 
     '  Фигуру против час стрелки
   IF Kb$ = "," OR Kb$ = "б" OR Kb$ = "Б" THEN
     SaveTekState
     RotateLeft
     CopyTekToPole
     IF Collizion% THEN
       RestoreTekState
       Collizion% = 0
     ELSE
       PoleTekFigureDelete
       CopyTekToPole
       DrawPole
     END IF
   END IF
 
     '  Фигуру налево
   IF Kb$ = CHR$(0) + "K" THEN
     PoleTekFigureDelete    '  Удаляем тек фигуру с поля
     PosX% = PosX% - 1
     CopyTekToPole
     IF Collizion% THEN
       PosX% = PosX% + 1
       CopyTekToPole
       Collizion% = 0
     ELSE
       DrawPole
     END IF
   END IF
 
     '  Фигуру направо
   IF Kb$ = CHR$(0) + "M" THEN
     PoleTekFigureDelete    '  Удаляем тек фигуру с поля
     PosX% = PosX% + 1
     CopyTekToPole
     IF Collizion% THEN
       PosX% = PosX% - 1
       CopyTekToPole
       Collizion% = 0
     ELSE
       DrawPole
     END IF
   END IF
 
   '  Основной движок
   IF TickControl > DnStatus% THEN
     PosY% = PosY% + 1
     PoleTekFigureDelete    '  Удаляем тек фигуру с поля
     CopyTekToPole
     '  Столкновение
     IF Collizion% THEN
       PoleTekFigureDelete  '  Удаляем тек фигуру с поля
       PosY% = PosY% - 1    '  На шаг назад
       FreezeFigure         '  Зафризим на поле тек фигуру
       NewFigure% = 1       '  Подать новую фигуру
       CheckLines           '  Проверим не заполнены ли строки
     END IF
     TickControl = 0
   DrawPole
   END IF
 
END SUB
 
SUB FreezeFigure
DIM Ccx%, Ccy%
 FOR iy = 0 TO 3
    Ccy% = PosY% + iy
    FOR ix = 0 TO 3
       Ccx% = PosX% + ix
       '  Если попадает в поле
       IF Ccx% > -1 AND Ccx% < 10 AND Ccy% < 24 THEN
          IF TekF(ix, iy) = 2 THEN Pole%(Ccx%, Ccy%) = 1
       END IF
 NEXT ix, iy
END SUB
 
SUB GoGame
 
  StartRound = 1
  
    DO: Kb$ = INKEY$
 
     ' Пауза ВКЛ/ВЫКЛ
     IF Kb$ = CHR$(32) THEN
       GmPause = -1 - GmPause: COLOR 7
       IF NOT GmPause THEN LOCATE 12, 17: PRINT "         "
     END IF
 
       IF GmPause THEN
          
           COLOR (COS((TimerFactor AND 31) / (9.8676064716#)) + 1) * 6 + 16
           LOCATE 12, 17: PRINT "[ PAUSE ]"
      
       ELSE
         
           EngineTick
 
       END IF
 
       Delay 80
       TimerFactor = (TimerFactor + 1) AND &HFFFFFF
       IF Kb$ = CHR$(27) THEN Quit = -1
   
    LOOP UNTIL Quit OR EndRaund
 
  Quit = 0
  CLS
END SUB
 
SUB HelpScreen
  CLS
  LOCATE 3, 19: PRINT "Help"
  COLOR 7
  LOCATE 8, 4: PRINT CHR$(17) + "   " + CHR$(16) + "   -   Move figure Left/Right"
  LOCATE 10, 3: PRINT " < " + CHR$(24) + " >   -   Rotate figure"
  LOCATE 12, 6: PRINT CHR$(25); "     -   Fast fall"
  LOCATE 14, 4: PRINT "Space   -   Pause"
  LOCATE 16, 5: PRINT "Esc    -   Exit everywhere"
  COLOR 10
  LOCATE 20, 4: PRINT "Press any key to exit help..."
  WHILE INKEY$ = "": WEND
END SUB
 
SUB MainMenu
V% = 0: Rdr% = 1
KEY(15) OFF
KEY(16) OFF
 
  DO: Kb$ = INKEY$
 
     IF Kb$ = CHR$(0) + "H" AND V% > 0 THEN V% = V% - 1: Rdr% = 1
     IF Kb$ = CHR$(0) + "P" AND V% < 2 THEN V% = V% + 1: Rdr% = 1
     
   IF Rdr% THEN
       CLS 2
       LOCATE 10
       IF V% = 0 THEN COLOR 10: d$ = CHR$(27) ELSE COLOR 7: d$ = ""
           PRINT TAB(18); "Play "; d$; CHR$(10)
       IF V% = 1 THEN COLOR 14: d$ = CHR$(27) ELSE COLOR 7: d$ = ""
           PRINT TAB(18); "Help "; d$; CHR$(10)
       IF V% = 2 THEN COLOR 12: d$ = CHR$(27) ELSE COLOR 7: d$ = ""
           PRINT TAB(18); "Quit "; d$; CHR$(10)
       Rdr% = 0
   END IF
     '  Выбор опции
   IF Kb$ = CHR$(13) THEN
     SELECT CASE V%
       CASE 0: KEY(15) ON: KEY(16) ON
               CLS
               GoGame
               Rdr% = 1
               KEY(15) OFF: KEY(16) OFF
               Kb$ = ""
       CASE 1: HelpScreen: Rdr% = 1
       CASE 2: EXIT DO
       CASE ELSE
     END SELECT
   END IF
     '  Окончание раунда
   IF EndRaund THEN
   DO: LOOP UNTIL INKEY$ = ""
   CLS : LOCATE 11, 10: PRINT "Your record is"
         LOCATE 13, 15: PRINT PlayScore&; "points"
      EndRaund = 0
      WHILE INKEY$ = "": WEND
   END IF
 
  LOOP UNTIL Kb$ = CHR$(27)
CLS
KEY(15) ON
KEY(16) ON
END SUB
 
SUB NextFigureToMem (NumFigur%)
 FOR iy = 0 TO 3
    FOR ix = 0 TO 3
       IF Figura(NumFigur%, ix, iy) = 1 THEN
       NxtF(ix, iy) = 2
       ELSE : NxtF(ix, iy) = 0
       END IF
 NEXT ix, iy
END SUB
 
SUB PoleTekFigureDelete
 StY% = PosY% - 1
 EnY% = PosY% + 4
 IF StY% < 0 THEN StY% = 0
 IF StY% > 23 THEN StY% = 23
 IF EnY% < 0 THEN EnY% = 0
 IF EnY% > 23 THEN EnY% = 23
 FOR iy = StY% TO EnY%
    FOR ix = 0 TO 9
       Pole%(ix, iy) = Pole%(ix, iy) AND 1
 NEXT ix, iy
END SUB
 
SUB PrepareALL
     '  Почистим экран
   CLS
     '  Клавиши на прерывание
   KEY 15, "АP"
   KEY 16, "А" + CHR$(208)
   ON KEY(15) GOSUB DnOn
   ON KEY(16) GOSUB DnOff
   KEY(15) ON
   KEY(16) ON
     '  Определяем задержку
   PRINT "Delay determinating...";
   f = TIMER
   DO: Tm = Tm + 1
   LOOP UNTIL TIMER - f > .5
   PRINT "ok!"
   Tm = Tm * 2
     '  Подгрузим фигуры из DATA
   FOR FgNum = 0 TO Figur - 1
      FOR iy = 0 TO 3
         FOR ix = 0 TO 3
            READ Figura(FgNum, ix, iy)
   NEXT ix, iy, FgNum
     '  Экран
   SCREEN 13
     '  Предрассчёт таблицы
   FOR iy = 0 TO 19
      FstMul%(iy) = CSize * iy
   NEXT
   FOR iy = 0 TO 3
      FstMul2%(iy) = NSize * iy
   NEXT
     '  Положение поля
   px = 123
   py = 20
     '  Положение поля след фигуры
   nfx = 230
   nfy = 20
     '  Цвет фигуры
   FigCv% = 1
   NxFigCv% = 1
     '  Случайность
   RANDOMIZE TIMER
END SUB
 
SUB RestoreTekState
  FOR iy = 0 TO 3
     FOR ix = 0 TO 3
        TekF(ix, iy) = StatF(ix, iy)
     NEXT
  NEXT
END SUB
 
SUB RotateLeft
  FOR iy = 0 TO 3
     FOR ix = 0 TO 3
        RotF(3 - ix, iy) = TekF(3 - iy, 3 - ix)
     NEXT
  NEXT
  FOR iy = 0 TO 3
     FOR ix = 0 TO 3
        TekF(ix, iy) = RotF(ix, iy)
     NEXT
  NEXT
DO
  NeedSdvig = 1
  FOR ix = 0 TO 3
     IF TekF(ix, 3) = 2 THEN NeedSdvig = 0
  NEXT
  IF NeedSdvig THEN
    FOR iy = 3 TO 1 STEP -1
       FOR ix = 0 TO 3
          TekF(ix, iy) = TekF(ix, iy - 1)
       NEXT
    NEXT
    FOR ix = 0 TO 3
       TekF(ix, 0) = 0
    NEXT
  END IF
LOOP WHILE NeedSdvig = 1
END SUB
 
SUB RotateRight
  FOR iy = 0 TO 3
     FOR ix = 0 TO 3
        RotF(3 - ix, iy) = TekF(iy, ix)
     NEXT
  NEXT
  FOR iy = 0 TO 3
     FOR ix = 0 TO 3
        TekF(ix, iy) = RotF(ix, iy)
     NEXT
  NEXT
DO
  NeedSdvig = 1
  FOR ix = 0 TO 3
     IF TekF(ix, 3) = 2 THEN NeedSdvig = 0
  NEXT
  IF NeedSdvig THEN
    FOR iy = 3 TO 1 STEP -1
       FOR ix = 0 TO 3
          TekF(ix, iy) = TekF(ix, iy - 1)
       NEXT
    NEXT
    FOR ix = 0 TO 3
       TekF(ix, 0) = 0
    NEXT
  END IF
LOOP WHILE NeedSdvig = 1
 
END SUB
 
SUB SaveTekState
  FOR iy = 0 TO 3
     FOR ix = 0 TO 3
        StatF(ix, iy) = TekF(ix, iy)
     NEXT
  NEXT
END SUB
 
SUB SdvigPole
 FOR iy = 23 TO 1 STEP -1
    FOR ix = 0 TO 9
       Pole%(ix, iy) = Pole%(ix, iy - 1)
 NEXT ix, iy
 FOR ix = 0 TO 9
    Pole%(ix, 0) = 0
 NEXT
END SUB
0
Good-Morning
1042 / 313 / 40
Регистрация: 13.07.2013
Сообщений: 1,269
14.07.2013, 19:04 #39
Недавно написал программу для "текстирования" изображения. Есть, правда, недоработки, но работает =). Вот она:

PureBasic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
cls
p$="" 'text       19600
kk$=""
input "A file to compile (short name+.bmp) "; na$
input "A file to create (short name+.txt) "; nam$
open "d:\"+na$ for binary as #1
open "d:\"+nam$ for output as #2
seek #1, 10
get$ #1, 1, a$
shift=asc(a$)
? shift
seek #1, 18
get$ #1, 1, a$
seek #1, 19
get$ #1, 1, b$
widtha=asc(a$)
widthb=asc(b$)
wid=widtha+widthb*256
? wid
seek #1, 22
get$ #1, 1, a$
seek #1, 23
get$ #1, 1, b$
lengtha=asc(a$)
lengthb=asc(b$)
lon=lengtha+lengthb*256
? lon
seek #1, shift
input "width", wi
input "length", le
s=wi*le
l=lon/le
cls
? chr$(201)
if l<>fix(l) then l=fix(l)+1
w=wid/wi
if w<>fix(w) then w=fix(w)+1
dim dynamic k%(1:l,1:w)
for i=1 to lon
ii=fix((i-1)/le)+1
for j=1 to wid
jj=fix((j-1)/wi)+1
seek #1, shift
get$ #1, 1, a$
seek #1, shift+1
get$ #1, 1, b$
seek #1, shift+2
get$ #1, 1, c$
k%(l-ii+1,jj)=k%(l-ii+1,jj)+fix((asc(a$)+asc(b$)+asc(c$))/3)
if ii>l then ? "ii="ii" l="l: end
shift=shift+3
next j
locate 10,10
? fix(100*i/lon)"% is done"
 
next i
for i=1 to l
for j=1 to w
'if len(p$)>19000 then swap p$, kk$
'if len(p$)>19000 and len(kk$)>19000 then cls: ? "overload": end
if k%(i,j)/s<=85 then p$=p$+"Ы"
if k%(i,j)/s<170 and k%(i,j)/s>85 then p$=p$+"+"
if k%(i,j)/s>=170 then p$=p$+" "
next j
p$=p$+chr$(13)
next i
print #2, p$
'if kk$="" then print #2, p$
'if kk$<>"" then print #2, kk$+p$
? "completed"
close #1
close #2
Добавлено через 8 минут
(эта программа написана на Turbo Basic)

Добавлено через 6 минут
Цитата Сообщение от velvet1545 Посмотреть сообщение
ребята знаете что формат бмп шифрованый?
ЧИво? Почему он шифрованый? BMP формат - самый простой и понятный.

Добавлено через 18 минут
Простенький, написанный за несколько минут "осциллограф" с возможностью указания частоты на обоих электродах + маштабирование...

PureBasic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
screen 9
input "F of x", xx
input "F of y", yy
input "cmewenue x", xxx
input "cmewenue y", yyy
cls
kk=1/xx
kk=kk*100
kk=int(kk)
kk=kk/100
yy=yy/xx
if kk>1 then ? kk"x"
if kk<1 then ? "1/"xx"x"
xx=1
a=a+xxx/57.3
b=b+yyy/57.3
z=150*sin(a)+320
w=150*sin(b)+175
lvl:
x=150*sin(a)+320
y=150*sin(b)+175
a=a+xx*0.3
b=b+yy*0.3
if a>20 then a=a-12.56
if b>20 then b=b-12.56
line(x,y)-(z,w)
delay 0.05
line(x,y)-(z,w),0
z=x
w=y
k$=inkey$
if k$="" then lvl
Кривой, но что получилось

Добавлено через 1 час 57 минут
Вот еще одна программка... Понять что она делает, я думаю, будет очень не просто, но объяснять еще треднее . В общих чертах - программа черчения 3d функций. Там надо некоторые константы подработать и будет то, что надо, надеюсь! Вот она:

PureBasic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
screen 9
alfa=1.55
gamma=0.5
sc=260
'yy=-100
zz=600
for xx=-100 to 100
for yy=-100 to 100 step 50
gosub drawing
next yy
next xx
for yy=-100 to 100
for xx=-100 to 100 step 50
gosub drawing
next xx
next yy
for xx=-100 to 100 step 20
for yy=-100 to 100 step 20
zz=200-xx-yy
gosub drawing
next yy
next xx
end
 
 
drawing:
z=zz
y=(xx+yy)*0.707+500
x=(xx-yy)*0.707
 
beta=atn(y/x)
beta=-(beta-alfa)
a=tan(beta)*sc
d=sqr((x*x)+(y*y))
beta=atn(z/d)
beta=beta-gamma
'if abs(beta)>89/57.29 then lvl
b=tan(beta)*sc
pset(320+a,175+b)
'? a, b
return
0
Good-Morning
1042 / 313 / 40
Регистрация: 13.07.2013
Сообщений: 1,269
14.07.2013, 19:11 #40
Вот вариант получше...
0
Вложения
Тип файла: zip 3DFUNC.ZIP (412 байт, 33 просмотров)
Good-Morning
14.07.2013, 20:37
  #41

Не по теме:

Я тут повнимательней почитал форум - оказывается почти все, что я написал, уже было написано и трижды хорошо... ( )

0
gehh
Заблокирован
15.06.2014, 09:06 #42
Мне ваша тема понравилась. Тут я подумал.
Вот я на форуме тоже писал графику на QBasic.
А что если снять копию с лучших программ и
перекинуть сюда. Там ими мало кто интересуется.
Как вы думаете?
P.S.
Как бы не съели М-ы

Добавлено через 17 часов 2 минуты
Эта программа рисует колесо и оно крутится
QBasic мой друг. Чтобы жить надо крутиться!!
(программа проверена)
QBasic/QuickBASIC
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
DEFSNG F-G, X-Y
DEFLNG I-K
CLS
 
SCREEN 12
WINDOW (-2.8, 2.1)-(2.8, -2.1)
 
f = .5236
j = 800000
k = 8000
g = 0
DO WHILE INKEY$ = ""
   g = g + .1
   CIRCLE (0, 0), 1, 11
   FOR i = 1 TO 12
      x = COS(f * i + g)
      y = SIN(f * i + g)
      LINE (x, y)-(0, 0), 11
   NEXT i
   FOR i = 1 TO j: NEXT i
   FOR i = 1 TO 12
      x = COS(f * i + g)
      y = SIN(f * i + g)
      LINE (x, y)-(0, 0), 0
   NEXT i
   IF j > k THEN j = j - k ELSE k = -k / 8
   IF j > 0 THEN j = j - k
   IF j > 400000 AND k < 0 THEN EXIT DO
LOOP
 
FOR i = 1 TO 12
   x = COS(f * i)
   y = SIN(f * i)
   LINE (x, y)-(0, 0), 11
NEXT i
 
END
Удачи вам!
0
gehh
Заблокирован
17.06.2014, 14:18 #43
Эта программа рисует цифру 4, а потом делает ее толще
(программа проверена)
QBasic/QuickBASIC
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
DEFINT I-N
SCREEN 12
WINDOW (0, 479)-(639, 0)
 
LINE (270, 350)-(250, 250), 11
LINE (250, 250)-(300, 250), 11
LINE (300, 300)-(280, 150), 11
 
FOR i = 250 TO 300
   FOR j = 150 TO 350
      k = POINT(i, j)
      IF k = 11 THEN
         IF POINT(i - 8, j - 8) <> 11 THEN PSET (i - 8, j - 8), 11
      END IF
   NEXT j
NEXT i
END
Удачи вам!
0
gehh
Заблокирован
18.06.2014, 16:46 #44
Эта программа рисует квадратики и не один
а целую кучу. Это оператор Line один, но он
расположен в двойном цикле.
(программа проверена)
QBasic/QuickBASIC
1
2
3
4
5
6
7
8
9
10
11
12
13
14
DIM i AS INTEGER
DIM j AS INTEGER
DIM c AS INTEGER
CLS
SCREEN 12
WINDOW (0, 300)-(400, 0)
 
FOR i = 1 TO 19
   FOR j = 1 TO 14
      c = 16 * RND
      LINE (20 * i, 20 * j)-(20 * i + 10, 20 * j + 10), c, B
   NEXT j
NEXT i
END
Удачи вам!
0
Quiet Snow
4373 / 1235 / 208
Регистрация: 25.04.2010
Сообщений: 3,027
20.06.2014, 00:46  [ТС] #45
Мне ваша тема понравилась.
И вы решили её изгадить своими детскими поделками... маааладец. Продолжайте в том же духе.
Через n-лет осознаете какой бред вы сейчас пишете.
1
MoreAnswers
Эксперт
37091 / 29110 / 5898
Регистрация: 17.06.2006
Сообщений: 43,301
20.06.2014, 00:46
Привет! Вот еще темы с ответами:

Составить программу в бейсике для вычисления значения функции при заданных параметрах - Basic
Пожалуйста помогите нубу составить программу в бейсике для вычисления значения функции при заданных параметрах

Третий раз информатику буду сдавать информатику. На языке Бейсике - Basic
Дан одномерный массив A из N элементов. Если четвертый элемент массива больше квадратного 6-го элемента, то каждый четвертый элемент...

Ищу книгу Я. Т. Гринчишина "Алгоритмы и программы на Бейсике" - Basic
я.т. гринчишина &quot;алгоритмы и программы на бейсике&quot; нужна ссылка на скачивание... может искать канешн не умею но в нете только на...

Что означает PSET в бейсике и что в скобке? И как записать его в Матлабе? - Basic
Что означает PSET в бейсике и что в скобке? И как записать его в Матлабе?


Искать еще темы с ответами

Или воспользуйтесь поиском по форуму:
Yandex
Объявления
20.06.2014, 00:46
Ответ Создать тему
Опции темы

КиберФорум - форум программистов, компьютерный форум, программирование
Powered by vBulletin® Version 3.8.9
Copyright ©2000 - 2017, vBulletin Solutions, Inc.
Рейтинг@Mail.ru