Форум программистов, компьютерный форум, киберфорум
Наши страницы
QBasic
Войти
Регистрация
Восстановить пароль
 
 
Рейтинг 4.82/335: Рейтинг темы: голосов - 335, средняя оценка - 4.82
Quiet Snow
4403 / 1287 / 375
Регистрация: 25.04.2010
Сообщений: 3,286
#1

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

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

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

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

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

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

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

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

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

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

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

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

Программы на Паскале И Бейсике
Помогите решить: 5.Составить программу, с помощью которой получить цвет¬ной...

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

80
Good-Morning
14.07.2013, 20:37     Графика на бейсике
  #41

Не по теме:

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

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
4403 / 1287 / 375
Регистрация: 25.04.2010
Сообщений: 3,286
20.06.2014, 00:46  [ТС] #45
Мне ваша тема понравилась.
И вы решили её изгадить своими детскими поделками... маааладец. Продолжайте в том же духе.
Через n-лет осознаете какой бред вы сейчас пишете.
1
Pro_grammer
Модератор
6139 / 2217 / 438
Регистрация: 24.04.2011
Сообщений: 3,897
Записей в блоге: 10
29.01.2015, 11:27 #46
Цитата Сообщение от Quiet Snow Посмотреть сообщение
Через n-лет осознаете какой бред вы сейчас пишете.

А что писал сам Билл Гейтс много лет назад? Я тут встретил одну старую игру, к созданию которой он непосредственно руку приложил - DONKEY.BAS
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
940 REM The IBM Personal Computer Donkey
950 REM Version 1.10 (C)Copyright IBM Corp 1981, 1982
960 REM Licensed Material - Program Property of IBM
975 DEF SEG : POKE 106, 0
980 SAMPLES$ = "NO"
990 GOTO 1010
1000 SAMPLES$ = "YES"
1010 KEY OFF: SCREEN 0, 1: COLOR 15, 0, 0: WIDTH 40: CLS : LOCATE 5, 19: PRINT "IBM"
1020 LOCATE 7, 12, 0: PRINT "Personal Computer"
1030 COLOR 10, 0: LOCATE 10, 9, 0: PRINT CHR$(213) + STRING$(21, 205) + CHR$(184)
1040 LOCATE 11, 9, 0: PRINT CHR$(179) + "       DONKEY        " + CHR$(179)
1050 LOCATE 12, 9, 0: PRINT CHR$(179) + STRING$(21, 32) + CHR$(179)
1060 LOCATE 13, 9, 0: PRINT CHR$(179) + "    Version 1.1O     " + CHR$(179)
1070 LOCATE 14, 9, 0: PRINT CHR$(212) + STRING$(21, 205) + CHR$(190)
1080 COLOR 15, 0: LOCATE 17, 4, 0: PRINT "(C) Copyright IBM Corp 1981, 1982"
1090 COLOR 14, 0: LOCATE 23, 7, 0: PRINT "Press space bar to continue"
1100 IF INKEY$ <> "" THEN GOTO 1100
1110 CMD$ = INKEY$
1120 IF CMD$ = "" THEN GOTO 1110
1130 IF CMD$ = CHR$(27) THEN GOTO 1298
1140 IF CMD$ = " " THEN GOTO 1160
1150 GOTO 1110
1160 DEF SEG = 0
1170 IF (PEEK(&H410) AND &H30) <> &H30 THEN DEF SEG : GOTO 1291
1180 WIDTH 80: CLS : LOCATE 3, 1
1190 PRINT "HOLD IT!"
1200 PRINT "YOU'RE NOT USING THE COLOR/GRAPHICS MONITOR ADAPTER!"
1210 PRINT "THIS PROGRAM USES GRAPHICS AND REQUIRES THAT ADAPTER."
1220 PRINT "PRESS THE SPACE BAR TO CONTINUE."
1230 DEF SEG
1240 IF INKEY$ <> "" THEN GOTO 1240
1250 CMD$ = INKEY$
1260 IF CMD$ = "" THEN GOTO 1250
1270 IF CMD$ = CHR$(27) THEN GOTO 1298
1280 IF CMD$ = " " THEN GOTO 1298
1290 GOTO 1250
1291 KEY OFF
1292 ON ERROR GOTO 1295
1293 PLAY "p16"
1294 GOTO 1300
1295 COLOR 31, 0, 0
1296 PRINT "THIS PROGRAM REQUIRES ADVANCED BASIC -- USE COMMAND 'BASICA'": COLOR 15, 0, 0: FOR I = 1 TO 9000: NEXT: RESUME 1298
1298 ON ERROR GOTO 0
1299 SCREEN 0, 1: 'IF SAMPLES$ = "YES" THEN CHAIN "samples",1000 ELSE COLOR 7,0,0:CLS:END
1300 REM
1410 COLOR 0
1420 DEFINT A-Y
1440 SCREEN 1, 0: COLOR 8, 1
1450 DIM Q%(500)
1460 DIM D1%(150), D2%(150), C1%(200), C2%(200)
1470 DIM DNK%(300)
1480 GOSUB 1940
1490 GOSUB 1780
1500 CLS
1510 DIM B%(300): DIM CAR%(900)
1520 FOR I = 2 TO 300: B%(I) = -16384 + 192: NEXT
1530 B%(0) = 2: B%(1) = 193
1540 REM
1550 CX = 110: CLS
1590 LINE (0, 0)-(305, 199), , B
1600 LINE (6, 6)-(97, 195), 1, BF
1610 LINE (183, 6)-(305, 195), 1, BF
1620 LOCATE 3, 5: PRINT "Donkey"
1630 LOCATE 3, 29: PRINT "Driver"
1631 LOCATE 19, 25: PRINT "Press Space  ";
1632 LOCATE 20, 25: PRINT "Bar to switch";
1633 LOCATE 21, 25: PRINT "lanes        ";
1635 LOCATE 23, 25: PRINT "Press ESC    ";
1636 LOCATE 24, 25: PRINT "to exit      ";
1640 FOR Y = 4 TO 199 STEP 20: LINE (140, Y)-(140, Y + 10): NEXT
1650 CY = 105: CX = 105
1660 LINE (100, 0)-(100, 199): LINE (180, 0)-(180, 199)
1670 LOCATE 5, 6: PRINT SD: LOCATE 5, 31: PRINT SM
1680 CY = CY - 4: IF CY < 60 THEN 2230
1690 PUT (CX, CY), CAR%, PRESET
1700 DX = 105 + 42 * INT(RND * 2)
1710 FOR Y = (RND * -4) * 8 TO 124 STEP 6
1720 SOUND 20000, 1
1730 A$ = INKEY$: IF A$ = CHR$(27) THEN 1298 ELSE POKE 106, 0: IF LEN(A$) > 0 THEN LINE (CX, CY)-(CX + 28, CY + 44), 0, BF: CX = 252 - CX: PUT (CX, CY), CAR%, PRESET: SOUND 200, 1
1740 IF Y >= 3 THEN PUT (DX, Y), DNK%, PSET
1750 IF CX = DX AND Y + 25 >= CY THEN 2060
1760 IF Y AND 3 THEN PUT (140, 6), B%
1770 NEXT: LINE (DX, 124)-(DX + 32, 149), 0, BF: GOTO 1670
1780 CLS
1790 DRAW "S8C3"
1800 DRAW "BM12,1r3m+1,3d2R1ND2u1r2d4l2u1l1"
1810 DRAW "d7R1nd2u2r3d6l3u2l1d3m-1,1l3"
1820 DRAW "m-1,-1u3l1d2l3u6r3d2nd2r1u7l1d1l2"
1830 DRAW "u4r2d1nd2R1U2"
1840 DRAW "M+1,-3"
1850 DRAW "BD10D2R3U2M-1,-1L1M-1,1"
1860 DRAW "BD3D1R1U1L1BR2R1D1L1U1"
1870 DRAW "BD2BL2D1R1U1L1BR2R1D1L1U1"
1880 DRAW "BD2BL2D1R1U1L1BR2R1D1L1U1"
1890 LINE (0, 0)-(40, 60), , B
1900 PAINT (1, 1)
'1910 DIM CAR%(900)
1920 GET (1, 1)-(29, 45), CAR%
1930 RETURN
1940 CLS
1950 DRAW "S08"
1960 DRAW "BM14,18"
1970 DRAW "M+2,-4R8M+1,-1U1M+1,+1M+2,-1"
1980 DRAW "M-1,1M+1,3M-1,1M-1,-2M-1,2"
1990 DRAW "D3L1U3M-1,1D2L1U2L3D2L1U2M-1,-1"
2000 DRAW "D3L1U5M-2,3U1"
2010 PAINT (21, 14), 3
2020 PRESET (37, 10): PRESET (40, 10)
2030 PRESET (37, 11): PRESET (40, 11)
2040 GET (13, 0)-(45, 25), DNK%
2050 RETURN
2060 SD = SD + 1: LOCATE 14, 6: PRINT "BOOM!"
2070 GET (DX, Y)-(DX + 16, Y + 25), D1%
2080 D1X = DX: D1Y = Y: D2X = DX + 17
2090 GET (DX + 17, Y)-(DX + 31, Y + 25), D2%
2100 GET (CX, CY)-(CX + 14, CY + 44), C1%
2110 GET (CX + 15, CY)-(CX + 28, CY + 44), C2%
2120 C1X = CX: C1Y = CY: C2X = CX + 15
2130 FOR P = 6 TO 0 STEP -1: Z = 1 / (2 ^ P): Z1 = 1 - Z
2140 PUT (C1X, C1Y), C1%: PUT (C2X, C1Y), C2%
2150 PUT (D1X, D1Y), D1%: PUT (D2X, D1Y), D2%
2160 C1X = CX * Z1: D1Y = Y * Z1: C2X = C2X + (291 - C2X) * Z
2170 D1X = DX * Z1: C1Y = C1Y + (155 - C1Y) * Z: D2X = D2X + (294 - D2X) * Z
2180 PUT (C1X, C1Y), C1%: PUT (C2X, C1Y), C2%
2190 PUT (D1X, D1Y), D1%: PUT (D2X, D1Y), D2%
2200 SOUND 37 + RND * 200, 4: NEXT
2210 FOR Y = 1 TO 2000: NEXT
2220 CLS : GOTO 1540
2230 SM = SM + 1: LOCATE 7, 25: PRINT "Donkey loses!"
2240 FOR Y = 1 TO 1000: NEXT
2250 CLS : GOTO 1540
Написано для 'BASICA', но можно запустить на QBasic, работает под DOS эмулятором. Не работает выход по клавише Esc, остальное вполне играбельно.


Кликните здесь для просмотра всего текста

ARI BIXHORN: Well, I am thrilled to be here today, because this week we are celebrating the ten-year birthday of the world's most powerful, productive and popular developer tool. And of course I'm talking about Visual Basic.

Now, to help set the context for just how far Visual Basic has come and really how far the Basic language has come, I'd like to take a step back just a few years and look at an application that was written in Basic. This application, called Donkey.bas was actually written by none other than the gentleman standing to the left of me. Bill, how long ago was it that you wrote Donkey.bas?

BILL GATES: Actually, it was myself and Neil Konzen at four in the morning with this prototype IBM PC sitting in this small room. IBM insisted that we had to have a lock on the door and we only had this closet that had a lock on it, so we had to do all our development in there and it was always over 100 degrees, but we wrote late at night a little application to show what the Basic built into the IBM PC could do. And so that was Donkey.bas. It was at the time very thrilling. So go ahead and show them what that looks like.
0
Миниатюры
Графика на бейсике  
echs
Регистрация: 23.10.2013
Сообщений: 5,076
Записей в блоге: 8
01.08.2015, 08:44 #47
Эта программа рисует узор из окружностей.

QBasic/QuickBASIC
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
DECLARE SUB f(x, y, r, p)
 
CLS
CLEAR, , 20000
SCREEN 12
WINDOW (-320, 240)-(320, -240)
CALL f(0, 0, 100, 4)
 
END
 
SUB f(x, y, r, p)
   IF p>0 THEN
      CIRCLE (x, y), r
      FOR i=1 TO 50000: NEXT i
      CALL f(x + r, y, r/2, p - 1)
      CALL f(x, y - r, r/2, p - 1)
      CALL f(x - r, y, r/2, p - 1)
      CALL f(x, y + r, r/2, p - 1)
   END IF
END SUB
0
echs
Регистрация: 23.10.2013
Сообщений: 5,076
Записей в блоге: 8
02.08.2015, 11:04 #48
Эта программа рисует узор из треугольников.

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
DECLARE SUB DRE(x!, y!, r!, n!)
 
CLS
DIM SHARED S, C
C = .866
S = .5
x0 = 0: y0 = 0
 
SCREEN 12
WINDOW (-320, 240)-(320, -240)
CALL DRE(0, 0, 100, 4)
END
 
SUB DRE(x0, y0, r, n)
   IF n > 0 THEN
      x1 = x0 - r*C
      y1 = y0 - r*S
      x2 = x0 + r*C
      y2 = y0 - r*S
      x3 = x0
      y3 = y0 + r
 
      LINE (x1, y1)-(x2, y2)
      LINE (x2, y2)-(x3, y3)
      LINE (x3, y3)-(x1, y1)
 
      FOR I = 1 TO 100000: NEXT I
 
      CALL DRE(x1, y1, r/2, n - 1)
      CALL DRE(x2, y2, r/2, n - 1)
      CALL DRE(x3, y3, r/2, n - 1)
   END IF
END SUB
0
Quiet Snow
4403 / 1287 / 375
Регистрация: 25.04.2010
Сообщений: 3,286
02.08.2015, 22:25  [ТС] #49
Уважаемые модераторы, будьте добры, переместите сообщения пользователя geh и его клона
gehh в одноимённые темы(название темы - то, что написано перед программой).
0
echs
Регистрация: 23.10.2013
Сообщений: 5,076
Записей в блоге: 8
03.08.2015, 13:15 #50
Графическая программа-анимация. Называется
Ханойские башни. (Вы вероятно о них слышали)
Программа запросит ввести число.
Для начала можете вести число 3. Если число
не вводить, а сразу нажать Enter, то будет по
умолчанию введено число 4. Число большее чем
7 вводить не стоит.

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
DECLARE SUB PYR(SD AS STRING, ND%)
DECLARE SUB REC(N%, o1%, o2%, o3%)
DECLARE SUB GRF(p1%, p2%)
 
DIM SHARED N AS INTEGER
DIM SHARED S(1 TO 3) AS STRING
 
CLS
CLEAR, , 26000
INPUT "N = "; NS$
IF NS$ = "" THEN N = 4 ELSE N = VAL(NS$)
 
FOR i = 1 TO N
   S(1) = S(1) + LTRIM$(STR$(i))
NEXT i
 
SCREEN 12
WINDOW (0, 480)-(640, 0)
 
CALL PYR(S(1), 160)
CALL PYR(S(2), 320)
CALL PYR(S(3), 480)
SLEEP 2
CLS
CALL REC(N, 1, 2, 3)
END
 
SUB GRF(p1 AS INTEGER, p2 AS INTEGER)
DIM t1 AS STRING
   t1 = LEFT$(S(p1), 1)
   S(p1) = RIGHT$(S(p1), LEN(S(p1)) - 1)
   S(p2) = t1 + S(p2)
 
   CALL PYR(S(1), 160)
   CALL PYR(S(2), 320)
   CALL PYR(S(3), 480)
   SLEEP 1
   IF LEN(S(3)) < N THEN CLS
END SUB
 
SUB PYR(SD AS STRING, ND AS INTEGER)
DIM S1 AS STRING
DIM S2 AS STRING
   H = 20
   S2 = SD
   LINE (ND, 240)-(ND, 400)
   IF LEN(SD) = 0 THEN EXIT SUB
   
   FOR i = 1 TO LEN(S2)
      S1 = RIGHT$(S2, 1)
      S2 = LEFT$(S2, LEN(S2) - 1)
      n1 = VAL(S1)
      X1 = ND - 10*n1
      X2 = ND + 10*n1
      Y1 = 240 + 20*i
      Y2 = Y1 - 20
      LINE (X1, Y1)-(X2, Y2), , B
   NEXT i
END SUB
 
SUB REC(N AS INTEGER, o1 AS INTEGER, o2 AS INTEGER, o3 AS INTEGER)
   IF N > 0 THEN
      CALL REC(N - 1, o1, o3, o2)
      CALL GRF(o1, o3)
      CALL REC(N - 1, o2, o1, o3)
   END IF
END SUB
Добавлено через 4 часа 8 минут

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
REM      Curve of Gilbert
 
DECLARE SUB ABC (x2!, y2!)
DECLARE SUB A (i!)
DECLARE SUB B (i!)
DECLARE SUB C (i!)
DECLARE SUB D (i!)
 
DIM SHARED p
DIM SHARED n
CLS
CLEAR , , 2900
 
p = 5
n = 10
SCREEN 12
DRAW "BM 450,50"
CALL A(p)
INPUT "Enter"; z$
SCREEN 0
END
 
SUB A (i)
   IF i > 0 THEN
      CALL D(i - 1)
      CALL ABC(POINT(0) - n, POINT(1))
      CALL A(i - 1)
      CALL ABC(POINT(0), POINT(1) + n)
      CALL A(i - 1)
      CALL ABC(POINT(0) + n, POINT(1))
      CALL B(i - 1)
   END IF
END SUB
 
SUB ABC (x2, y2)
   x1 = POINT(0)
   y1 = POINT(1)
   IF x1 <> x2 THEN
      LINE (x1, y1)-(x2, y2)
      FOR j = 1 TO 10000: NEXT
   ELSE
      LINE (x1, y1)-(x2, y2)
      FOR j = 1 TO 10000: NEXT
   END IF
END SUB
 
SUB B (i)
   IF i > 0 THEN
      CALL C(i - 1)
      CALL ABC(POINT(0), POINT(1) - n)
      CALL B(i - 1)
      CALL ABC(POINT(0) + n, POINT(1))
      CALL B(i - 1)
      CALL ABC(POINT(0), POINT(1) + n)
      CALL A(i - 1)
   END IF
END SUB
 
SUB C (i)
   IF i > 0 THEN
      CALL B(i - 1)
      CALL ABC(POINT(0) + n, POINT(1))
      CALL C(i - 1)
      CALL ABC(POINT(0), POINT(1) - n)
      CALL C(i - 1)
      CALL ABC(POINT(0) - n, POINT(1))
      CALL D(i - 1)
   END IF
END SUB
 
SUB D (i)
   IF i > 0 THEN
      CALL A(i - 1)
      CALL ABC(POINT(0), POINT(1) + n)
      CALL D(i - 1)
      CALL ABC(POINT(0) - n, POINT(1))
      CALL D(i - 1)
      CALL ABC(POINT(0), POINT(1) - n)
      CALL C(i - 1)
   END IF
END SUB
=========

Программа рисует узор из квадратов

QBasic/QuickBASIC
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
DECLARE SUB f (x!, y!, r!, p!)
 
CLS
CLEAR , , 20000
SCREEN 12
WINDOW (-320, 240)-(320, -240)
CALL f(0, 0, 100, 3)
 
END
 
SUB f (x, y, r, p)
   IF p > 0 THEN
      s = r - 1
      LINE (x - r, y + r)-(x + r, y - r), , B
      LINE (x - s, y + s)-(x + s, y - s), 0, BF
      FOR i = 1 TO 100000: NEXT
      CALL f(x + r, y, r / 3, p - 1)
      CALL f(x, y - r, r / 3, p - 1)
      CALL f(x - r, y, r / 3, p - 1)
      CALL f(x, y + r, r / 3, p - 1)
   END IF
END SUB
==========

Рекурсия. Узор из квадратов.
(Вариант 2)
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
DECLARE SUB f (x!, y!, r!, p!)
DIM SHARED c
 
CLS
CLEAR , , 20000
c = 2.4
SCREEN 12
WINDOW (-320, 240)-(320, -240)
CALL f(0, 0, 100, 4)
 
END
 
SUB f (x, y, r, p)
 
   IF p > 0 THEN
      s = r - 1
      LINE (x - r, y - r)-(x + r, y + r), , B
      LINE (x - s, y - s)-(x + s, y + s), 0, BF
      FOR i = 1 TO 50000: NEXT
      CALL f(x + r, y - r, r / c, p - 1)
      CALL f(x - r, y - r, r / c, p - 1)
      CALL f(x - r, y + r, r / c, p - 1)
      CALL f(x + r, y + r, r / c, p - 1)
   END IF
END SUB
========

Программа рисует узор из квадратов
(Вариант 3)
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
DECLARE SUB f (x!, y!, r!, p!)
 
CLS
CLEAR , , 20000
SCREEN 12
WINDOW (-320, 240)-(320, -240)
CALL f(0, 0, 100, 3)
 
END
 
SUB f (x, y, r, p)
   IF p > 0 THEN
      s = r - 1
      LINE (x - r, y + r)-(x + r, y - r), , B
      LINE (x - s, y + s)-(x + s, y - s), 0, BF
      FOR i = 1 TO 30000: NEXT
      CALL f(x, y, r / 4, p - 1)
      CALL f(x + r, y, r / 4, p - 1)
      CALL f(x + r, y + r, r / 4, p - 1)
      CALL f(x, y + r, r / 4, p - 1)
      CALL f(x - r, y + r, r / 4, p - 1)
      CALL f(x - r, y, r / 4, p - 1)
      CALL f(x - r, y - r, r / 4, p - 1)
      CALL f(x, y - r, r / 4, p - 1)
      CALL f(x + r, y - r, r / 4, p - 1)
   END IF
END SUB
0
Quiet Snow
4403 / 1287 / 375
Регистрация: 25.04.2010
Сообщений: 3,286
03.08.2015, 23:48  [ТС] #51
Не знаю, кому n лет назад создавал данную тему, но развеивание предрассудков, очевидно,
превратилось в их полнейшее доказательство - основного целевого контингента.
Больно, конечно, всё это видеть, столько сил было положено в своё время, Раптор, softmob,
мои прожки по мелочи, и тут нате вам... просто на дно... мерси коллеги программеры
1
echs
Регистрация: 23.10.2013
Сообщений: 5,076
Записей в блоге: 8
04.08.2015, 06:47 #52
Спасибо!
Хотя бы за то, что я знаю, что это ваша тема
и я должен был создать свою ...
Спасибо!
0
MiXa42
2 / 2 / 0
Регистрация: 26.11.2015
Сообщений: 43
26.11.2015, 23:23 #53
У меня собственная игра
Вот код:
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
CHDIR ".\game"
'-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
'
'        ±±    ±± ±±±±±± ±±±±±± ±± ±±±±±  ±±±±±± ±±±   ±±  ±±±±±±±±±±
'        ±±    ±± ±±  ±± ±±  ±± ±±    ±±  ±±  ±± ±± ±± ±±      ±±
'        ±±±±±±±± ±±  ±± ±±±±±± ±±   ±±   ±±  ±± ±±  ±±±±      ±±
'        ±±    ±± ±±  ±± ±± ±±  ±±  ±±    ±±  ±± ±±   ±±±      ±±
'        ±±    ±± ±±±±±± ±±  ±± ±± ±±±±±± ±±±±±± ±±    ±±      ±±
'
'         M I R I D I N    E N T E R T A I N M E N T  -  2 0 1 5
'
'
'               Game Name:  Miridin TANK COMMANDER Horizont version 1.3 ALPHA
'                   Programmer:  Petrov Mihail Denisovech
'                     Completed:  Sentember 22, 2015
'
'
'                               * * * *
'
'Are as follows:
'
'BLUE TANK  - up:  8
'             down:  2
'             left:  4
'             right:  6
'             brakes:  5
'             shoot:  0
'
'GREEN TANK - up:  W
'             down:  S
'             left:  A
'             right:  D
'             brakes:  Q
'             shoot:  SPACE BAR
'File list for Qbasic TANK COMMANDER v2:
'
'*  TCV2.BAS....................Game code file.
'*  ARENA.BSV...................BSAVEd graphics file for game arena.
'*  SPRITES.BSV.................BSAVEd graphics file for sprites.
'
'**************************** PRESS <ENTER> TO PLAY!! *************************
'=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-==-=-=-=-=-=-=-=-=-=-=-=-=-=-=
 
'Define variables A-Z as integers.
DEFINT A-Z
 
'Define the data TYPE, PaletteType.
TYPE PaletteType
    Red AS INTEGER
    Green AS INTEGER
    Blue AS INTEGER
END TYPE
 
'SHAREing of certain variables.
DIM SHARED Pal AS PaletteType
DIM SHARED pData(0 TO 255, 1 TO 3)
 
'Declaration of various SUBs.
DECLARE SUB PALETTE.Set (nColor%, pInfo AS PaletteType)
DECLARE SUB PALETTE.GET (nColor%, pInfo AS PaletteType)
DECLARE SUB PALETTE.FadeOut ()
DECLARE SUB PALETTE.FadeIn ()
 
'Change the default directory to the one being used for TANK COMMANDER. When
'setting this, remember to uncomment it.
'CHDIR ""
 
'Initial values of various variables.
D1 = 2: D2 = 4: T1H = 6: T1V = 87: T2H = 300: T2V = 102: Speed = 550
 
'Customise the VGA color palette for the introductory text.
SCREEN 13
C = 16: FOR A = 16 TO 61 STEP 3: PALETTE C, (256 ^ 2 * A) + (256 * 0) + 0: C = C + 1: NEXT
C = 32: FOR A = 16 TO 61 STEP 3: PALETTE C, (256 ^ 2 * 0) + (256 * A) + 0: C = C + 1: NEXT
C = 48: FOR A = 16 TO 61 STEP 3: PALETTE C, (256 ^ 2 * 0) + (256 * 0) + A: C = C + 1: NEXT
C = 64: FOR A = 16 TO 61 STEP 3: PALETTE C, (256 ^ 2 * A) + (256 * A) + 0: C = C + 1: NEXT
C = 80: FOR A = 16 TO 61 STEP 3: PALETTE C, (256 ^ 2 * A) + (256 * 0) + A: C = C + 1: NEXT
C = 96: FOR A = 16 TO 61 STEP 3: PALETTE C, (256 ^ 2 * 0) + (256 * A) + A: C = C + 1: NEXT
C = 112: B = 0: FOR A = 16 TO 61 STEP 3: PALETTE C, (256 ^ 2 * A) + (256 * B) + 0: B = B + 3: C = C + 1: NEXT
C = 128: B = 0: FOR A = 16 TO 61 STEP 3: PALETTE C, (256 ^ 2 * B) + (256 * 0) + A: B = B + 3: C = C + 1: NEXT
C = 144: B = 0: FOR A = 16 TO 61 STEP 3: PALETTE C, (256 ^ 2 * B) + (256 * A) + 0: B = B + 3: C = C + 1: NEXT
C = 160: B = 0: FOR A = 16 TO 61 STEP 3: PALETTE C, (256 ^ 2 * B) + (256 * A) + A: B = B + 3: C = C + 1: NEXT
C = 176: B = 0: FOR A = 16 TO 61 STEP 3: PALETTE C, (256 ^ 2 * A) + (256 * A) + A: C = C + 1: NEXT
C = 192: B = 12: AA = 0: FOR A = 30 TO 62 STEP 2: PALETTE C, (256 ^ 2 * B) + (256 * AA) + A: B = B + 2: C = C + 1: NEXT
C = 208: B = 12: AA = 0: FOR A = 30 TO 62 STEP 2: PALETTE C, (256 ^ 2 * B) + (256 * B) + A: B = B + 2: C = C + 1: NEXT
C = 224: B = 12: AA = 0: FOR A = 30 TO 62 STEP 2: PALETTE C, (256 ^ 2 * AA) + (256 * B) + A: B = B + 2: C = C + 1: NEXT
 
'Do presentation text.
PALETTE.FadeOut
COLOR 1
LOCATE 11, 14: PRINT  "M I R I D I N"
LOCATE 13, 13: PRINT "P R E S E N T S"
COLOR 9
LOCATE 20, 16: PRINT "*********"
LOCATE 17, 16: PRINT "*********"
LOCATE 18, 16: PRINT "*"
LOCATE 19, 16: PRINT "*"
LOCATE 19, 24: PRINT "*"
LOCATE 18, 24: PRINT "*"
COLOR 2
LOCATE 18, 18: PRINT "ALPHA "
COLOR 6
LOCATE 19, 17: PRINT " v 1.3 "
COLOR 1
'Color in "M I R I D I N" with various shades of blue.
Y = 72: C = 32
DO
    FOR X = 1 TO 300
        IF POINT(X, Y) > 0 THEN PSET (X, Y), C + RND * 17
    NEXT
    Y = Y + 1
LOOP UNTIL Y = 79
 
'Color in "PRESENTS" with various shades of red. Once this has been done,
'fade in the screen, melt it, and then fade out.
Y = 96: C = 49
DO
    FOR X = 1 TO 300
        IF POINT(X, Y) > 0 THEN PSET (X, Y), C + RND * 17
    NEXT
    Y = Y + 1
LOOP UNTIL Y = 103
PALETTE.FadeIn
NOW! = TIMER: WHILE (TIMER - 3) < NOW!: WEND
DIM Melt%(1700)
FOR R = 1 TO 1700
    RANDOMIZE TIMER
    X = INT(RND * 271)
    RANDOMIZE TIMER
    Y = INT(RND * 170)
    GET (X, Y)-(X + 48, Y + 18), Melt%
    PUT (X, Y + 1), Melt%, PSET
    IF INKEY$ = CHR$(27) THEN END
NEXT
PALETTE.FadeOut
CLS : PALETTE: PALETTE.FadeOut
 
'GET the sprite data.
DEF SEG = 40960: BLOAD "sprites.bsv"
DIM Tank1(150): GET (1, 1)-(15, 10), Tank1
DIM Tank2(150): GET (1, 14)-(15, 23), Tank2
DIM Tank3(150): GET (1, 27)-(15, 36), Tank3
DIM Tank4(150): GET (1, 40)-(15, 49), Tank4
DIM Tank5(150): GET (20, 1)-(34, 10), Tank5
DIM Tank6(150): GET (20, 14)-(34, 23), Tank6
DIM Tank7(150): GET (20, 27)-(34, 36), Tank7
DIM Tank8(150): GET (20, 40)-(34, 49), Tank8
 
'Load the file ARENA.BSV, which is the graphics data for the arena, into the
'video memory segment (segment 40960).
BLOAD "arena.bsv"
 
'Place both tanks in their initial positions and fade in the completed arena.
PUT (T1H, T1V), Tank1, PSET
PUT (T2H, T2V), Tank6, PSET
PALETTE.FadeIn
 
'Main program loop.
DO
 
    'IF Count < Speed THEN Count = Count + 1 ELSE Count = 0
    WAIT &H3DA, 8: WAIT &H3DA, 8, 8
 
    IF Go1 = 1 AND Count = 0 THEN
        IF D1 = 1 AND T1V > 26 THEN T1V = T1V - 1: PUT (T1H, T1V), Tank3, PSET
        IF D1 = 2 AND T1H < 305 THEN T1H = T1H + 1: PUT (T1H, T1V), Tank1, PSET
        IF D1 = 3 AND T1V < 190 THEN T1V = T1V + 1: PUT (T1H, T1V), Tank4, PSET
        IF D1 = 4 AND T1H > 0 THEN T1H = T1H - 1: PUT (T1H, T1V), Tank2, PSET
    END IF
    IF Go2 = 1 AND Count = 0 THEN
        IF D2 = 1 AND T2V > 26 THEN T2V = T2V - 1: PUT (T2H, T2V), Tank7, PSET
        IF D2 = 2 AND T2H < 305 THEN T2H = T2H + 1: PUT (T2H, T2V), Tank5, PSET
        IF D2 = 3 AND T2V < 190 THEN T2V = T2V + 1: PUT (T2H, T2V), Tank8, PSET
        IF D2 = 4 AND T2H > 0 THEN T2H = T2H - 1: PUT (T2H, T2V), Tank6, PSET
    END IF
    IF St1 = 30 THEN St1 = 0: Fire1 = 0: PSET (B1H, B1V), Col
    IF St2 = 30 THEN St2 = 0: Fire2 = 0: PSET (B2H, B2V), Col2
    IF Fire1 = 1 AND St1 < 30 AND Count = 0 THEN
        PSET (B1H, B1V), Col
        IF BD1 = 1 THEN B1V = B1V - 2
        IF BD1 = 2 THEN B1H = B1H + 2
        IF BD1 = 3 THEN B1V = B1V + 2
        IF BD1 = 4 THEN B1H = B1H - 2
        Col = POINT(B1H, B1V)
        PSET (B1H, B1V), 14
        St1 = St1 + 1
        GOSUB CheckBullet1
    END IF
    IF Fire2 = 1 AND St2 < 30 AND Count = 0 THEN
        PSET (B2H, B2V), Col2
        IF BD2 = 1 THEN B2V = B2V - 2
        IF BD2 = 2 THEN B2H = B2H + 2
        IF BD2 = 3 THEN B2V = B2V + 2
        IF BD2 = 4 THEN B2H = B2H - 2
        Col2 = POINT(B2H, B2V)
        PSET (B2H, B2V), 14
        St2 = St2 + 1
        GOSUB CheckBullet2
    END IF
    KEY$ = INKEY$
    IF KEY$ = CHR$(27) THEN PALETTE.FadeOut: GOTO Results
    IF KEY$ = "4" THEN Go1 = 1: D1 = 4
    IF KEY$ = "6" THEN Go1 = 1: D1 = 2
    IF KEY$ = "8" THEN Go1 = 1: D1 = 1
    IF KEY$ = "2" THEN Go1 = 1: D1 = 3
    IF KEY$ = "0" THEN IF Fire1 = 0 THEN GOSUB Shoot1
    IF KEY$ = "5" THEN Go1 = 0
    IF KEY$ = "A" OR KEY$ = "a" THEN Go2 = 1: D2 = 4
    IF KEY$ = "D" OR KEY$ = "d" THEN Go2 = 1: D2 = 2
    IF KEY$ = "W" OR KEY$ = "w" THEN Go2 = 1: D2 = 1
    IF KEY$ = "S" OR KEY$ = "s" THEN Go2 = 1: D2 = 3
    IF KEY$ = "Q" OR KEY$ = "q" THEN Go2 = 0
    IF KEY$ = CHR$(32) THEN IF Fire2 = 0 THEN GOSUB Shoot2
LOOP
 
Shoot1:  'Initiates the shooting from Tank 1.
BD1 = D1
IF BD1 = 0 THEN RETURN
IF BD1 = 1 THEN B1H = (T1H + 7): B1V = (T1V - 1)
IF BD1 = 2 THEN B1H = (T1H + 14): B1V = (T1V + 5)
IF BD1 = 3 THEN B1H = (T1H + 7): B1V = (T1V + 11)
IF BD1 = 4 THEN B1H = (T1H - 1): B1V = (T1V + 5)
St1 = 1: Fire1 = 1: Col = POINT(B1H, B1V)
RETURN
 
Shoot2:  'Initiates the shooting from Tank 2.
BD2 = D2
IF BD2 = 0 THEN RETURN
IF BD2 = 1 THEN B2H = (T2H + 7): B2V = (T2V - 1)
IF BD2 = 2 THEN B2H = (T2H + 14): B2V = (T2V + 5)
IF BD2 = 3 THEN B2H = (T2H + 7): B2V = (T2V + 11)
IF BD2 = 4 THEN B2H = (T2H - 1): B2V = (T2V + 5)
St2 = 1: Fire2 = 1: Col2 = POINT(B2H, B2V)
RETURN
 
CheckBullet1:  'Hit detection from Tank 1 bullet.
T2V = T2V + 2: T2H = T2H + 3
FOR ScanTank2 = 1 TO 7
    FOR Scan = 1 TO 9
        IF B1H = T2H AND B1V = T2V THEN Crash = 2: GOTO Explode
        T2H = T2H + 1
    NEXT
    T2H = T2H - 9: T2V = T2V + 1
NEXT
T2V = T2V - 9: T2H = T2H - 3
RETURN
 
CheckBullet2:  'Hit detection from Tank 2 bullet.
T1V = T1V + 2: T1H = T1H + 3
FOR ScanTank1 = 1 TO 7
    FOR Scan = 1 TO 9
        IF B2H = T1H AND B2V = T1V THEN Crash = 1: GOTO Explode
        T1H = T1H + 1
    NEXT
    T1H = T1H - 9: T1V = T1V + 1
NEXT
T1V = T1V - 9: T1H = T1H - 3
RETURN
 
Explode:  'Create very cheap graphic explosion.
IF Crash = 1 THEN ExplodeH = T1H: ExplodeV = T1V: T2Wins = 1
IF Crash = 2 THEN ExplodeH = T2H: ExplodeV = T2V: T1Wins = 1
FOR Explode = 1 TO 9
    IF Explode = 1 THEN Col = 14
    IF Explode = 5 THEN Col = 12
    IF Explode = 7 THEN Col = 4
    CIRCLE (ExplodeH, ExplodeV), Explode, Col
    NOW! = TIMER: WHILE (TIMER - .02) < NOW!: WEND
NEXT
NOW! = TIMER: WHILE (TIMER - 1.2) < NOW!: WEND
PALETTE.FadeOut
 
Results:  'Announce the winning tank and display credits.
SCREEN 0: WIDTH 66, 27
COLOR 12, 4
PRINT " G A M E   R E S U L T S "
PRINT
COLOR 9, 0
PRINT "Blue tank wins:"
COLOR 4
LOCATE 3, 17: PRINT T1Wins
COLOR 2
PRINT "Green tank wins:"
COLOR 4
LOCATE 4, 18: PRINT T2Wins
PRINT
COLOR 12, 4
PRINT " C R E D I T S "
PRINT
COLOR 3, 0
PRINT "Concept:"
PRINT "Programming:"
PRINT "Game art:"
PRINT "Fade effect:"
PRINT "Testing:"
PRINT "Debugging:"
COLOR 2
LOCATE 8, 11: PRINT "Miridin"
LOCATE 9, 15: PRINT "Misha Petrov"
LOCATE 10, 12: PRINT "Misha Petrov"
LOCATE 11, 15: PRINT "Misha Petrov"
COLOR 12
LOCATE 12, 11: PRINT "ALPHA"
COLOR 2
LOCATE 13, 13: PRINT "MIsha Petrov"
PRINT
COLOR 9
PRINT "All programmed by Mihail Petrov."
PRINT
COLOR 4,9
PRINT "Thank you for playing TANK COMMANDER Horizont v1.3 ALPHA !!!"
PRINT "Everything is made in QBASIC"
COLOR 2,0
PRINT ""
PRINT ""
LOCATE 25, 15 :PRINT "Made in POCTOB-HA-DOHY!"
COLOR 9,0
 
 
SUB PALETTE.FadeIn
DIM tT(1 TO 3)
FOR I = 1 TO 64
    WAIT &H3DA, 8, 8
    FOR O = 0 TO 255
        PALETTE.GET O, Pal
        tT(1) = Pal.Red
        tT(2) = Pal.Green
        tT(3) = Pal.Blue
        IF tT(1) < pData(O, 1) THEN tT(1) = tT(1) + 1
        IF tT(2) < pData(O, 2) THEN tT(2) = tT(2) + 1
        IF tT(3) < pData(O, 3) THEN tT(3) = tT(3) + 1
        Pal.Red = tT(1)
        Pal.Green = tT(2)
        Pal.Blue = tT(3)
        PALETTE.Set O, Pal
    NEXT
NEXT
END SUB
 
SUB PALETTE.FadeOut
DIM tT(1 TO 3)
FOR I = 0 TO 255
    PALETTE.GET I, Pal
    pData(I, 1) = Pal.Red
    pData(I, 2) = Pal.Green
    pData(I, 3) = Pal.Blue
NEXT
FOR I = 1 TO 64
    WAIT &H3DA, 8, 8
    FOR O = 0 TO 255
        PALETTE.GET O, Pal
        tT(1) = Pal.Red
        tT(2) = Pal.Green
        tT(3) = Pal.Blue
        IF tT(1) > 0 THEN tT(1) = tT(1) - 1
        IF tT(2) > 0 THEN tT(2) = tT(2) - 1
        IF tT(3) > 0 THEN tT(3) = tT(3) - 1
        Pal.Red = tT(1)
        Pal.Green = tT(2)
        Pal.Blue = tT(3)
        PALETTE.Set O, Pal
    NEXT
NEXT
END SUB
 
SUB PALETTE.GET (nColor%, pInfo AS PaletteType)
OUT &H3C6, &HFF
OUT &H3C7, nColor%
pInfo.Red = INP(&H3C9)
pInfo.Green = INP(&H3C9)
pInfo.Blue = INP(&H3C9)
END SUB
 
SUB PALETTE.Set (nColor%, pInfo AS PaletteType)
OUT &H3C6, &HFF
OUT &H3C8, nColor%
OUT &H3C9, pInfo.Red
OUT &H3C9, pInfo.Green
OUT &H3C9, pInfo.Blue
END SUB
Комплектующие в фале.
Как вы думаете меню можно пристроить?
И вот сам файл:
0
Вложения
Тип файла: zip Cmmand.zip (429.9 Кб, 21 просмотров)
Quiet Snow
4403 / 1287 / 375
Регистрация: 25.04.2010
Сообщений: 3,286
06.12.2015, 17:25  [ТС] #54
Как вы думаете меню можно пристроить?
Думать не нужно, нужно знать, меню - ну а в чём сложность? Вот меню, одеваем его
в спрайты и очень даже нормально получится:

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
CONST Punkts = 2
DIM PuName(Punkts) AS STRING
DIM i AS INTEGER, RDr AS INTEGER
Vib = 0: RDr = -1
PuName(0) = "Variant 1"
PuName(1) = "Variant 2"
PuName(2) = "Exit"
 
DO: Kb$ = INKEY$
  IF Kb$ = CHR$(0) + "H" AND Vib > 0 THEN Vib = Vib - 1: RDr = -1
  IF Kb$ = CHR$(0) + "P" AND Vib < Punkts THEN Vib = Vib + 1: RDr = -1
  IF RDr THEN
    CLS 2
    FOR i = 0 TO Punkts
       IF Vib = i THEN COLOR 11 ELSE COLOR 8
       PRINT PuName(i)
    NEXT
    RDr = 0
  END IF
  IF Kb$ = CHR$(13) THEN
    SELECT CASE Vib
      CASE 0:  '  Делаем первое, например, вызов процедуры
               '  В процедуре может быть точно такое же ещё одно меню,
               '  либо толстый движок, вызывающий десятки других процедур
               '  и всё, что вам только в голову взбредёт.
      CASE 1:  '  Делаем второе, например, вызов процедуры  --||--
      CASE 2:  EXIT DO
      CASE ELSE
    END SELECT
  END IF
LOOP UNTIL Kb$ = CHR$(27)
Фейды - это конечно здорово, но вот INKEY$ для подвижных игр - ужасно.
На вашем месте переписал бы эту прогу заново. Рисовка нужна нормальная это раз, учитывая
то что QB64 позволяет это делать, нужна озвучка, 13 VGA экран под виндой - просто зло, делаем
хотя бы 640x480 в 32 бита конечно же, хотя эра данного разрешения прошла в конце 90-х, но я бы
не обломался, если бы всё было сделано качественно, лучше конечно 800x600 или 1024x768.
Сейчас посмотрю, что там по клавиатуре есть в QB64, судя по всему status% = _KEYDOWN(code&)
Читаем тут:
http://www.qb64.net/wiki/index.php?title=Keyboard_scancodes
Но на QBasic оно работать не будет, почему _KEYDOWN? Потому, что через порты даже в DOS
был западающий костыль, через ON KEY Events не костыль, но тоже западающий, а через сообщения
винды - вам пока это не нужно, короче описание данной функции больше похоже на правду.
Выходит так что в данном плане лучше не иметь совместимости с DOS'ом вообще, чем пихать в прогу
кривые обработчики.

Звук курим тут:
http://www.qb64.net/wiki/index.php/SNDOPEN

Работу с графикой тут:
http://www.qb64.net/wiki/index.php?title=Graphics_with_QB64

Режимы бленда тут, но скудновато, после FB, скажу прямо:
http://www.qb64.net/wiki/index.php/PUT_(graphics_statement)

От рудимента BLOAD отказываемся сразу т.к. есть средства загрузки изображений.

Если важна кроссплатформа DOS\WINDOWS, ставим DOSBox + QBasic.

P.S: Поднимайте скилуху Михаил, а то так и будете на форумах всякую фигню писать.
У меня в ваши годы не то, что интернета не было, компа не было и прежде чем что-то
написать на форумах, сидел несколько месяцев вникал во всё это форумное комьюнити.
Серьёзно говорю, без всяких там пальцев веером и т.д. так что агриться не надо, спокойно
сидим изучаем, качаем мозг, шахматы там, логич. задачи и т.п., и да прежде чем, что-то
написать проверяем информацию в нормальных источниках, это как минимум убережёт
вашу репутацию и предостережёт от ошибок. А что не понятно, лучше лишний раз спросить.
Грамотного народа тут полно.
0
vlisp
455 / 424 / 103
Регистрация: 10.08.2015
Сообщений: 1,435
Завершенные тесты: 1
20.05.2016, 02:57 #55
Complex - интересная 3D программа на qbasic
0
Quiet Snow
4403 / 1287 / 375
Регистрация: 25.04.2010
Сообщений: 3,286
06.09.2016, 17:31  [ТС] #56
Цитата Сообщение от vlisp Посмотреть сообщение
Complex - интересная 3D программа на qbasic
А можно перезалить куда-нибудь? Сайт сдох (Ошибка: "Не удается получить доступ к сайту").
0
vlisp
455 / 424 / 103
Регистрация: 10.08.2015
Сообщений: 1,435
Завершенные тесты: 1
06.09.2016, 19:49 #57
Цитата Сообщение от Quiet Snow Посмотреть сообщение
Сайт сдох
Похоже он переехал сюда...
http://home.scarlet.be/wugi/qbComplex.html
1
starcraft
0 / 0 / 0
Регистрация: 25.11.2016
Сообщений: 1
28.11.2016, 10:47 #58
То что я посмотрел - это выше моего понимания! Как ты вообще это спроектировал? Я архитектуру замысла не то что саму программу не могу представить...Браво...
0
PAnT0P
1022 / 546 / 106
Регистрация: 26.03.2012
Сообщений: 987
19.01.2018, 00:26 #59
Дабы оживить тему - простенький морской бой
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
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
DIM CX AS INTEGER, CY AS INTEGER
DIM SHARED A(1 TO 10, 1 TO 10)
DIM SHARED YOU(1 TO 10, 1 TO 10) AS INTEGER
DIM SHARED SHIP(1 TO 4) AS INTEGER
DIM SHARED ENEMY(1 TO 10, 1 TO 10) AS INTEGER
DIM SHARED ENDGAME AS INTEGER, LMAX AS INTEGER
 
DECLARE SUB SHOWCUR (X AS INTEGER, Y AS INTEGER, L AS INTEGER, R AS INTEGER)
DECLARE SUB BOX (L AS INTEGER, T AS INTEGER, W AS INTEGER, H AS INTEGER)
DECLARE SUB SHOWINDEX (X1 AS INTEGER, Y1 AS INTEGER, MAX AS INTEGER)
DECLARE SUB SHOWCURSOR (X AS INTEGER, Y AS INTEGER)
DECLARE SUB GETLENGHT (X AS INTEGER, Y AS INTEGER)
DECLARE SUB SETSHIPAI (L AS INTEGER, N AS INTEGER)
DECLARE SUB PAUSE (N AS INTEGER)
DECLARE SUB EDITSHIP ()
DECLARE SUB ATOENEMY ()
DECLARE SUB AUTOSET ()
DECLARE SUB RESTART ()
DECLARE SUB ANALIZ1 ()
DECLARE SUB ANALIZ ()
DECLARE SUB REDRAW ()
DECLARE SUB YOUTOA ()
 
DECLARE FUNCTION SETSHIP% (CX AS INTEGER, CY AS INTEGER, L AS INTEGER, R AS INTEGER)
DECLARE FUNCTION VALIDATE% (X AS INTEGER, Y AS INTEGER, L AS INTEGER, R AS INTEGER)
DECLARE FUNCTION FIREAI% (X AS INTEGER, Y AS INTEGER)
DECLARE FUNCTION FIRE% (X AS INTEGER, Y AS INTEGER)
DECLARE FUNCTION GETINDEX% ()
DECLARE FUNCTION AI% ()
 
SCREEN 7
COLOR 15, 1
CLS
RANDOMIZE TIMER
LOCATE 2, 16: PRINT "SEA BATTLE"
RESTART
CX = 5: CY = 5:
DO
  K$ = INKEY$
  IF LEN(K$) > 0 THEN
    K = ASC(RIGHT$(K$, 1))
  ELSE
    K = 0
  END IF
  SELECT CASE K
    CASE 72 'UP
      CY = CY - 1
      IF CY < 1 THEN CY = 1
    CASE 75  'LEFT
      CX = CX - 1
      IF CX < 1 THEN CX = 1
    CASE 77  'RIGHT
      CX = CX + 1
      IF CX > 10 THEN CX = 10
    CASE 80  'DOWN
      CY = CY + 1
      IF CY > 10 THEN CY = 10
    CASE 32 'SPACE
      R = FIRE(CX, CY)
      REDRAW
      IF ENDGAME = 0 THEN
        IF R = 0 THEN
          AIR = 1
          DO WHILE AIR = 1
            AIR = AI
            REDRAW
          LOOP
        END IF
      END IF
    CASE 79 'END
      RESTART
      CX = 5: CY = 5:
  END SELECT
  IF ENDGAME THEN
      CALL BOX(7, 18, 26, 3)
      LOCATE 19, 8: PRINT "                          ";
      IF ENDGAME > 0 THEN
        LOCATE 20, 8: PRINT "         YOU  WIN!        ";
      ELSE
        LOCATE 20, 8: PRINT "         YOU LOSS!        ";
      END IF
      LOCATE 21, 8: PRINT "                          ";
      LOCATE 23, 7: PRINT "                            ";
  ELSE
      CALL SHOWCURSOR(CX, CY)
  END IF
LOOP UNTIL K = 27
END
 
FUNCTION AI%
  DIM X AS INTEGER, Y AS INTEGER, MAX AS INTEGER, I AS INTEGER
  MAX = GETINDEX
  FOR Y = 1 TO 10
    FOR X = 1 TO 10
      IF A(X, Y) = MAX THEN
        I = I + 1
      END IF
    NEXT X
  NEXT Y
  I = INT(RND * I) + 1
  FOR Y = 1 TO 10
    FOR X = 1 TO 10
      IF A(X, Y) = MAX THEN
        I = I - 1
        IF I = 0 THEN
          AI = FIREAI(X, Y)
          EXIT FUNCTION
        END IF
      END IF
    NEXT X
  NEXT Y
END FUNCTION
 
SUB ANALIZ
  DIM X AS INTEGER, Y AS INTEGER, L AS INTEGER, T AS INTEGER
  YOUTOA
  ANALIZ1
  FOR Y = 1 TO 10
    L = 0: T = 0
    FOR X = 1 TO 10
      IF YOU(X, Y) = 3 THEN
        IF T = 0 THEN T = X
        L = L + 1
      ELSE
        IF L >= LMAX THEN
          IF YOU(X, Y) = 0 THEN YOU(X, Y) = -1
          IF T > 1 THEN
            IF YOU(T - 1, Y) = 0 THEN YOU(T - 1, Y) = -1
          END IF
        END IF
        L = 0: T = 0
      END IF
    NEXT X
  NEXT Y
  FOR X = 1 TO 10
    L = 0: T = 0
    FOR Y = 1 TO 10
      IF YOU(X, Y) = 3 THEN
        IF T = 0 THEN T = Y
        L = L + 1
      ELSE
        IF L >= LMAX THEN
          IF YOU(X, Y) = 0 THEN YOU(X, Y) = -1
          IF T > 1 THEN
            IF YOU(X, T - 1) = 0 THEN YOU(X, T - 1) = -1
          END IF
        END IF
        L = 0: T = 0
      END IF
    NEXT Y
  NEXT X
END SUB
 
SUB ANALIZ1
  ERASE SHIP
  FOR L = 1 TO 4
    FOR Y = 1 TO 10
      FOR X = 1 TO 10
        IF A(X, Y) = 3 THEN
          '===============================
          T = X: I = 0
          DO WHILE A(T, Y) = 3
            I = I + 1
            T = T + 1
            IF T > 10 THEN EXIT DO
          LOOP
          IF I = 5 - L THEN
            SHIP(5 - L) = SHIP(5 - L) + 1
            FOR N = 1 TO 5 - L
              A(T - N, Y) = 0
            NEXT N
          END IF
          '==============================
          T = Y: I = 0
          DO WHILE A(X, T) = 3
            I = I + 1
            T = T + 1
            IF T > 10 THEN EXIT DO
          LOOP
          IF I = 5 - L THEN
            SHIP(5 - L) = SHIP(5 - L) + 1
            FOR N = 1 TO 5 - L
              A(X, T - N) = 0
            NEXT N
          END IF
        END IF
      NEXT X
    NEXT Y
  NEXT L
  IF SHIP(4) = 1 THEN
    LMAX = 3
    IF SHIP(3) = 2 THEN
      LMAX = 2
      IF SHIP(2) = 3 THEN
        LMAX = 1
        IF SHIP(1) = 4 THEN
          LMAX = 0
        END IF
      END IF
    END IF
  END IF
END SUB
 
SUB ATOENEMY
  DIM X AS INTEGER, Y AS INTEGER
  FOR Y = 1 TO 10
    FOR X = 1 TO 10
      ENEMY(X, Y) = A(X, Y)
    NEXT X
  NEXT Y
END SUB
 
SUB ATOYOU
  DIM X AS INTEGER, Y AS INTEGER
  FOR Y = 1 TO 10
    FOR X = 1 TO 10
      YOU(X, Y) = A(X, Y)
    NEXT X
  NEXT Y
END SUB
 
SUB AUTOSET
  ERASE A
  ERASE YOU
  CALL SETSHIPAI(4, 1)
  CALL SETSHIPAI(3, 2)
  CALL SETSHIPAI(2, 3)
  CALL SETSHIPAI(1, 4)
  FOR Y = 1 TO 10
    FOR X = 1 TO 10
      IF A(X, Y) = 2 THEN
        YOU(X, Y) = 2
      ELSE
        YOU(X, Y) = 0
      END IF
    NEXT X
  NEXT Y
  REDRAW
END SUB
 
SUB BOX (L AS INTEGER, T AS INTEGER, W AS INTEGER, H AS INTEGER)
  LOCATE T, L: PRINT "Й";
  FOR X = L + 1 TO L + W
    LOCATE T, X: PRINT "Н";
  NEXT X
  LOCATE T, L + W + 1: PRINT "»";
  FOR Y = T + 1 TO T + H
    LOCATE Y, L: PRINT "є";
    LOCATE Y, L + W + 1: PRINT "є";
  NEXT Y
  LOCATE T + H + 1, L: PRINT "И";
  FOR X = L + 1 TO L + W
    LOCATE T + H + 1, X: PRINT "Н";
  NEXT X
  LOCATE T + H + 1, L + W + 1: PRINT "ј";
END SUB
 
SUB EDITSHIP
  DIM CX AS INTEGER, CY AS INTEGER, L AS INTEGER, R AS INTEGER
  CALL BOX(7, 18, 26, 4)
  LOCATE 19, 8: PRINT "[ARROWS] - Move cursor    ";
  LOCATE 20, 8: PRINT " [ENTER] - Rotate ship    ";
  LOCATE 21, 8: PRINT " [SPACE] - Set ship       ";
  LOCATE 22, 8: PRINT "   [END] - Random set ship";
  CX = 5: CY = 5: L = 3: R = 0
  YOUTOA
  DO
    K$ = INKEY$
    IF LEN(K$) > 0 THEN
      K = ASC(RIGHT$(K$, 1))
    ELSE
      K = 0
    END IF
    SELECT CASE K
      CASE 72 'UP
        CY = CY - 1
        IF CY < 1 THEN CY = 1
      CASE 75  'LEFT
        CX = CX - 1
        IF CX < 1 THEN CX = 1
      CASE 77  'RIGHT
        CX = CX + 1
        IF R THEN
          IF CX > 10 - L THEN CX = 10 - L
        ELSE
          IF CX > 10 THEN CX = 10
        END IF
      CASE 80  'DOWN
        CY = CY + 1
        IF R THEN
          IF CY > 10 THEN CY = 10
        ELSE
          IF CY > 10 - L THEN CY = 10 - L
        END IF
      CASE 13 'ENTER
        R = NOT R
        LOCATE 3, 2
        IF R THEN
          IF CX > 10 - L THEN CX = 10 - L
        ELSE
          IF CY > 10 - L THEN CY = 10 - L
        END IF
      CASE 32 'SPACE
        L = SETSHIP(CX, CY, L, R)
        IF L = 0 THEN
          EXIT DO
        END IF
        L = L - 1
      CASE 79 'END
        AUTOSET
        EXIT DO
    END SELECT
    CALL SHOWCUR(CX, CY, L, R)
  LOOP
  LMAX = 4
END SUB
 
SUB ENEMYTOA
  DIM X AS INTEGER, Y AS INTEGER
  FOR Y = 1 TO 10
    FOR X = 1 TO 10
      A(X, Y) = ENEMY(X, Y)
    NEXT X
  NEXT Y
END SUB
 
FUNCTION FIRE% (X AS INTEGER, Y AS INTEGER)
  DIM R AS INTEGER
  SELECT CASE ENEMY(X, Y)
  CASE 0
    COLOR , 9
    ENEMY(X, Y) = 1
    R = 0
  CASE 2
    FOR I = 1 TO 3
      COLOR , 12
      PAUSE 3
      COLOR , 14
      PAUSE 3
    NEXT I
    ENEMY(X, Y) = 3
    R = 1
  CASE ELSE
    R = -1
  END SELECT
  PAUSE 3
  COLOR , 1
  FIRE = R
END FUNCTION
 
FUNCTION FIREAI% (X AS INTEGER, Y AS INTEGER)
  DIM R AS INTEGER
  SELECT CASE YOU(X, Y)
  CASE 0
    COLOR , 9
    YOU(X, Y) = 1
    R = 0
  CASE 2
    FOR I = 1 TO 3
      COLOR , 12
      PAUSE 3
      COLOR , 14
      PAUSE 3
    NEXT I
    YOU(X, Y) = 3
    IF X > 1 AND Y > 1 THEN
      IF YOU(X - 1, Y - 1) = 0 THEN YOU(X - 1, Y - 1) = -1
    END IF
    IF X > 1 AND Y < 10 THEN
      IF YOU(X - 1, Y + 1) = 0 THEN YOU(X - 1, Y + 1) = -1
    END IF
    IF X < 10 AND Y > 1 THEN
      IF YOU(X + 1, Y - 1) = 0 THEN YOU(X + 1, Y - 1) = -1
    END IF
    IF X < 10 AND Y < 10 THEN
      IF YOU(X + 1, Y + 1) = 0 THEN YOU(X + 1, Y + 1) = -1
    END IF
    CALL GETLENGHT(X, Y)
    R = 1
  END SELECT
  PAUSE 3
  COLOR , 1
  FIREAI = R
END FUNCTION
 
FUNCTION GETINDEX%
  DIM T AS INTEGER, U AS INTEGER, D AS INTEGER, L AS INTEGER, R AS INTEGER
  DIM K AS INTEGER, X AS INTEGER, Y AS INTEGER, MAX AS INTEGER
  ANALIZ
  FOR Y = 1 TO 10
    FOR X = 1 TO 10
      IF YOU(X, Y) MOD 2 = 0 THEN
'======================================
        U = 0: D = 0: L = 0: R = 0: K = 0
        IF X > 1 THEN
          IF YOU(X - 1, Y) = 3 THEN K = 60
        END IF
        IF X < 10 THEN
          IF YOU(X + 1, Y) = 3 THEN K = 60
        END IF
        IF Y > 1 THEN
          IF YOU(X, Y - 1) = 3 THEN K = 60
        END IF
        IF Y < 10 THEN
          IF YOU(X, Y + 1) = 3 THEN K = 60
        END IF
        T = Y
        DO WHILE T > 0
          IF YOU(X, T) MOD 2 = 0 THEN
            U = U + 1
          ELSE
            EXIT DO
          END IF
          T = T - 1
        LOOP
        T = Y
        DO WHILE T < 11
          IF YOU(X, T) MOD 2 = 0 THEN
            D = D + 1
          ELSE
            EXIT DO
          END IF
          T = T + 1
        LOOP
        T = X
        DO WHILE T > 0
          IF YOU(T, Y) MOD 2 = 0 THEN
            L = L + 1
          ELSE
            EXIT DO
          END IF
          T = T - 1
        LOOP
        T = X
        DO WHILE T < 11
          IF YOU(T, Y) MOD 2 = 0 THEN
            R = R + 1
          ELSE
            EXIT DO
          END IF
          T = T + 1
        LOOP
'======================================
        A(X, Y) = U * D + L * R + K
        IF MAX < A(X, Y) THEN
          MAX = A(X, Y)
        END IF
      ELSE
        A(X, Y) = 0
      END IF
    NEXT X
  NEXT Y
  GETINDEX = MAX
END FUNCTION
 
SUB GETLENGHT (X AS INTEGER, Y AS INTEGER)
  DIM L AS INTEGER, S AS INTEGER, E AS INTEGER
  L = 1
  S = X - 1
  IF X > 1 THEN
    DO WHILE YOU(S, Y) = 3
      L = L + 1
      S = S - 1
      IF S < 1 THEN EXIT DO
    LOOP
  END IF
  E = X + 1
  IF X < 10 THEN
    DO WHILE YOU(E, Y) = 3
      L = L + 1
      E = E + 1
      IF E > 10 THEN EXIT DO
    LOOP
  END IF
  IF L = LMAX THEN
    IF X > 1 AND YOU(S + 1, Y) = 0 THEN YOU(S, Y) = -1
    IF X < 10 AND YOU(E - 1, Y) = 0 THEN YOU(E, Y) = -1
  END IF
  L = 1
  S = Y - 1
  IF Y > 1 THEN
    DO WHILE YOU(X, S) = 3
      L = L + 1
      S = S - 1
      IF S < 1 THEN EXIT DO
    LOOP
  END IF
  E = Y + 1
  IF Y < 10 THEN
    DO WHILE YOU(X, E) = 3
      L = L + 1
      E = E + 1
      IF E > 10 THEN EXIT DO
    LOOP
  END IF
  IF L = LMAX THEN
    IF Y > 1 AND YOU(X, S + 1) = 0 THEN YOU(X, S) = -1
    IF Y < 10 AND YOU(X, E - 1) = 0 THEN YOU(X, E) = -1
  END IF
END SUB
 
SUB PAUSE (N AS INTEGER)
  FOR J = 1 TO N
    FOR I = 1 TO 50
      A = SQR(PI / I)
    NEXT I
  NEXT J
END SUB
 
SUB REDRAW
  DIM X AS INTEGER, Y AS INTEGER, H AS INTEGER, C AS INTEGER
  DIM H1 AS INTEGER, C1 AS INTEGER
  H = 0: C = 0
  FOR Y = 1 TO 10
    FOR X = 1 TO 10
      LOCATE Y + 4, X + 8:
      SELECT CASE YOU(X, Y)
        CASE 1
          PRINT "ъ";
        CASE 2
          PRINT "Ы";
          H = H + 1
        CASE 3
          PRINT "X";
          H1 = H1 + 1
        CASE ELSE
          PRINT " ";
      END SELECT
      LOCATE Y + 4, X + 22:
      SELECT CASE ENEMY(X, Y)
        CASE 1
          PRINT "ъ";
        CASE 2
          IF ENDGAME <> 0 THEN
            PRINT "Ы";
          END IF
          C = C + 1
        CASE 3
          PRINT "X";
          C1 = C1 + 1
        CASE ELSE
          PRINT " ";
      END SELECT
    NEXT X
  NEXT Y
  LOCATE 3, 12: PRINT USING "###"; H1
  LOCATE 3, 26: PRINT USING "###"; C1
  IF H = 0 THEN ENDGAME = -1
  IF C = 0 THEN ENDGAME = 1
END SUB
 
SUB RESTART
  ERASE A
  ERASE YOU
  ERASE SHIP
  ERASE ENEMY
  REDRAW
  FOR Y = 1 TO 10
    LOCATE Y + 4, 19: PRINT USING "###"; Y;
  NEXT Y
  LOCATE 16, 9: PRINT "ABCDEFGHIJ"
  LOCATE 16, 23: PRINT "ABCDEFGHIJ"
  CALL BOX(8, 4, 10, 10)
  CALL BOX(22, 4, 10, 10)
  EDITSHIP
  ERASE A
  ERASE SHIP
  CALL SETSHIPAI(4, 1)
  CALL SETSHIPAI(3, 2)
  CALL SETSHIPAI(2, 3)
  CALL SETSHIPAI(1, 4)
  ATOENEMY
  FOR Y = 1 TO 10
    FOR X = 1 TO 10
      IF YOU(X, Y) <> 2 THEN
        YOU(X, Y) = 0
      END IF
      IF ENEMY(X, Y) <> 2 THEN
        ENEMY(X, Y) = 0
      END IF
    NEXT X
  NEXT Y
  CALL BOX(7, 18, 26, 4)
  LOCATE 19, 8: PRINT "[ARROWS] - Move cursor    ";
  LOCATE 20, 8: PRINT " [SPACE] - Fire           ";
  LOCATE 21, 8: PRINT "   [END] - Restart game   ";
  LOCATE 22, 8: PRINT "   [ESC] - Exit           ";
  ENDGAME = 0: LMAX = 4
  REDRAW
END SUB
 
FUNCTION SETSHIP% (CX AS INTEGER, CY AS INTEGER, L AS INTEGER, R AS INTEGER)
  IF VALIDATE(CX, CY, L, R) THEN
    FOR T = 0 TO L
      IF R THEN
        IF CX > 1 AND T = 0 THEN YOU(CX - 1, CY) = -1
        IF CX + T > 1 AND CY > 1 THEN YOU(CX + T - 1, CY - 1) = -1
        IF CX + T > 1 AND CY < 10 THEN YOU(CX + T - 1, CY + 1) = -1
        IF CX + T < 10 AND CY > 1 THEN YOU(CX + T + 1, CY - 1) = -1
        IF CX + T < 10 AND CY < 10 THEN YOU(CX + T + 1, CY + 1) = -1
        IF CX + L < 10 AND T = L THEN YOU(CX + L + 1, CY) = -1
        YOU(CX + T, CY) = 2
      ELSE
        IF CY > 1 AND T = 0 THEN YOU(CX, CY - 1) = -1
        IF CX > 1 AND CY + T > 1 THEN YOU(CX - 1, CY + T - 1) = -1
        IF CX > 1 AND CY + T < 10 THEN YOU(CX - 1, CY + T + 1) = -1
        IF CX < 10 AND CY + T > 1 THEN YOU(CX + 1, CY + T - 1) = -1
        IF CX < 10 AND CY + T < 10 THEN YOU(CX + 1, CY + T + 1) = -1
        IF CY + L < 10 AND T = L THEN YOU(CX, CY + L + 1) = -1
        YOU(CX, CY + T) = 2
      END IF
    NEXT
    YOUTOA
    REDRAW
    SHIP(L + 1) = SHIP(L + 1) + 1
    IF SHIP(4) = 1 THEN
      L = 3
      IF SHIP(3) = 2 THEN
        L = 2
        IF SHIP(2) = 3 THEN
          L = 1
          IF SHIP(1) = 4 THEN
            L = 0
          END IF
        END IF
      END IF
    END IF
  END IF
  SETSHIP = L
END FUNCTION
 
SUB SETSHIPAI (L AS INTEGER, N AS INTEGER)
  DIM K AS INTEGER, R  AS INTEGER, X AS INTEGER, Y AS INTEGER
  L = L - 1
  K = 10 - L
  DO WHILE N > 0
'=============================================
    R = INT(RND * 2)
    IF R THEN
      X = INT(RND * K) + 1
      Y = INT(RND * 10) + 1
      IF VALIDATE(X, Y, L, R) THEN
        N = N - 1
        FOR T = 0 TO L
          A(X + T, Y) = 2
          IF T = 0 AND X > 1 THEN A(X - 1, Y) = -1
          IF Y > 1 THEN
            IF X + T > 1 THEN A(X + T - 1, Y - 1) = -1
            A(X + T, Y - 1) = -1
            IF X + T < 10 THEN A(X + T + 1, Y - 1) = -1
          END IF
          IF Y < 10 THEN
            IF X + T > 1 THEN A(X + T - 1, Y + 1) = -1
            A(X + T, Y + 1) = -1
            IF X + T < 10 THEN A(X + T + 1, Y + 1) = -1
          END IF
          IF T = L AND X + T < 10 THEN A(X + T + 1, Y) = -1
        NEXT T
      END IF
    ELSE
      X = INT(RND * 10) + 1
      Y = INT(RND * K) + 1
      IF VALIDATE(X, Y, L, R) THEN
        N = N - 1
        FOR T = 0 TO L
          A(X, Y + T) = 2
          IF T = 0 AND Y > 1 THEN A(X, Y - 1) = -1
          IF X > 1 THEN
            IF Y + T > 1 THEN A(X - 1, Y + T - 1) = -1
            A(X - 1, Y + T) = -1
            IF Y + T < 10 THEN A(X - 1, Y + T + 1) = -1
          END IF
          IF X < 10 THEN
            IF Y + T > 1 THEN A(X + 1, Y + T - 1) = -1
            A(X + 1, Y + T) = -1
            IF Y + T < 10 THEN A(X + 1, Y + T + 1) = -1
          END IF
          IF T = L AND Y + T < 10 THEN A(X, Y + T + 1) = -1
        NEXT T
      END IF
    END IF
  LOOP
END SUB
 
SUB SHOWCUR (CX AS INTEGER, CY AS INTEGER, L AS INTEGER, R AS INTEGER)
  DIM X AS INTEGER, Y AS INTEGER
  X = CX + 8
  Y = CY + 4
  IF VALIDATE(CX, CY, L, R) THEN
    COLOR 15
  ELSE
    COLOR 12
  END IF
  FOR T = 0 TO L
    IF R THEN
      LOCATE Y, X + T
    ELSE
      LOCATE Y + T, X
    END IF
    PRINT "±";
  NEXT T
  PAUSE 5
  COLOR 15
  FOR T = 0 TO L
    IF R THEN
      LOCATE Y, X + T
        IF YOU(CX + T, CY) = 2 THEN
          PRINT "Ы";
        ELSE
          PRINT " ";
        END IF
    ELSE
      LOCATE Y + T, X
        IF YOU(CX, CY + T) = 2 THEN
          PRINT "Ы";
        ELSE
          PRINT " ";
        END IF
    END IF
  NEXT T
  PAUSE 5
END SUB
 
SUB SHOWCURSOR (X AS INTEGER, Y AS INTEGER)
  COLOR 15
  LOCATE Y + 4, X + 22
  PRINT "±";
  PAUSE 5
  LOCATE Y + 4, X + 22
  SELECT CASE ENEMY(X, Y)
    CASE 1
      PRINT "ъ";
    CASE 3
      PRINT "X";
    CASE ELSE
      PRINT " ";
  END SELECT
  PAUSE 5
END SUB
 
FUNCTION VALIDATE% (X AS INTEGER, Y AS INTEGER, L AS INTEGER, R AS INTEGER)
  VALIDATE = 1
  FOR T = 0 TO L
    IF R THEN
      IF A(X + T, Y) <> 0 THEN
        VALIDATE = 0
        EXIT FOR
      END IF
    ELSE
      IF A(X, Y + T) <> 0 THEN
        VALIDATE = 0
        EXIT FOR
      END IF
    END IF
  NEXT T
END FUNCTION
 
SUB YOUTOA
  DIM X AS INTEGER, Y AS INTEGER
  FOR Y = 1 TO 10
    FOR X = 1 TO 10
      A(X, Y) = YOU(X, Y)
    NEXT X
  NEXT Y
END SUB
2
vlisp
455 / 424 / 103
Регистрация: 10.08.2015
Сообщений: 1,435
Завершенные тесты: 1
19.01.2018, 01:55 #60
Цитата Сообщение от PAnT0P Посмотреть сообщение
DIM SHARED A(1 TO 10, 1 TO 10)
Цитата Сообщение от PAnT0P Посмотреть сообщение
A = SQR(PI / I)
запутался в типах
0
19.01.2018, 01:55
MoreAnswers
Эксперт
37091 / 29110 / 5898
Регистрация: 17.06.2006
Сообщений: 43,301
19.01.2018, 01:55

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

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

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


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

Или воспользуйтесь поиском по форуму:
60
Ответ Создать тему
Опции темы

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