Шашки
Отрисовка поля и шашек и ход по диагонали
Dim sh(8, 8), x1, y1, x2, y2
Private Sub Form_Activate()
kletka = 1000:Form1.Width = kletka * 8:Form1.Height = kletka * 8
Scale (0, 0)-(8, 8)
For i = 1 To 3
For j = 1 To 8
If (i + j) Mod 2 = 0 Then sh(i, j) = 14 Else sh(i + 5, j) = 8
Next
Next
draw_pole
End Sub
Sub draw_pole()
FillStyle = 0
For i = 1 To 8
For j = 1 To 8
If (i + j) Mod 2 = 0 Then c = 0 Else c = QBColor(15)
Line (j - 1, i - 1)-(j, i), c, BF
If sh(i, j) <> 0 Then FillColor = QBColor(sh(i, j)): Circle (j - 0.5, i - 0.5), 0.5, QBColor(sh(i, j))
Next j, i
End Sub
Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
If x1 = 0 Then ‘первый щелчок
x1 = Int(X) + 1: y1 = Int(Y) + 1
FillStyle = 1
If sh(y1, x1) <> 0 Then ‘не пустая клетка
Line (x1 - 1, y1 - 1)-(x1, y1), QBColor(12), B
Else
x1 = 0: y1 = 0
End If
Else ‘второй щелчок
x2 = Int(X) + 1: y2 = Int(Y) + 1
If sh(y2, x2) = 0 Then куда идем пусто
zn = Abs(x1 - x2)
If zn = (y1 - y2) Then
jump
End If
End If
End If
End Sub
Sub jump()
sh(y2, x2) = sh(y1, x1)
sh(y1, x1) = 0
x1 = 0
draw_pole
End Sub
Крестики нолики
Dim pole(3, 3), hod
Private Sub Form_Activate()
hod = 1
Form1.Height = 2000 * 3
Form1.Width = 2000 * 3
Scale (0, 0)-(3, 3)
For i = 1 To 2 //нарисовать поле
Line (0, i)-(3, i)
Line (i, 0)-(i, 3)
Next
End Sub
Sub draw_hod(x, y)
If pole(y, x) = 1 Then
Line (x - 1, y - 1)-(x, y)
Else
Circle (x - 0.5, y - 0.5), 0.4
End If
End Sub
Private Sub Form_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
X1 = Int(x) + 1: Y1 = Int(y) + 1
If pole(Y1, X1) = 0 Then
pole(Y1, X1) = hod: Call draw_hod(X1, Y1)
If endgame = True Then MsgBox ("Win!!!"): End
hod = (hod + 2) Mod 2 + 1
Else
MsgBox ("Занято")
End If
End Sub
Function endgame()
endgame = False
s = 0: s1 = 0
For i = 1 To 3
If pole(i, i) = hod Then s = s + 1
If pole(i, 4 - i) = hod Then s1 = s1 + 1
Next i
If s = 3 Or s1 = 3 Then endgame = True
End Function
Добавить проверку по строкам и столбцам
Вывести все треугольные матрицы
Футбол Строковые Звездный час
Звездный час и перевертыш
– Дописать еще 5 слов для «Звездного часа»
– Заданное слово распечатать лесенкой от 1 до всех букв
- Разбить на слоги, добавив тире (слогом называем любые две буквы)
Шифровка в центр
Шифровка. Заданная строка записывается в квадрат построчно, а считывается по столбикам.
Dim m(100, 100)
Private Sub Command1_Click()
s = Text1.Text
l = Len(s)
Print l
n = Int(Sqr(l)) + 1
k = 1
For i = 1 To n
For j = 1 To n
m(i, j) = Mid(s, k, 1)
k = k + 1
Next
Next
temp = ""
For j = 1 To n
For i = 1 To n
temp = temp + m(i, j)
m(i, j) = " "
Next
Next
Text2.Text = temp
End Sub
Как сделать, чтобы можно было расшифровать текст
Составьте из слова a=«ПРОГРАММИРОВАНИЕ», как можно больше слов используя команду mid. Например ? MID(a,1,8)+MID(a,13,1)
Шифр Цезаря
Сумма цифр числа
– Найти самое большое число, полученное из заданного перестановкой цифр.
Ребусы Бегущая строка
Dim a
Private Sub Command1_Click()
Label1.Visible = False
Text1.Visible = False
Command1.Visible = False
a = Text1.Text + " "
End Sub
Private Sub Form_Activate()
Open "text.txt" For Input As #1
Input #1, a
If a = "" Then Text1.Text = "Ура! КАНИКУЛЫ!" Else Text1.Text = a
Close #1
a = Text1.Text + " "
While True
Cls
Print a
a = Mid(a, 2, Len(a) - 1) + Mid(a, 1, 1)
DoEvents
For i = 1 To 10000000: Next
Wend
End Sub
Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
MsgBox ("Cпасибо за внимание!")
If KeyCode = 27 Then End
End Sub
Private Sub options_Click()
Label1.Visible = True
Text1.Visible = True
Command1.Visible = True
''''''''''''''''''''''
End Sub
Длинная арифметика
Поле чудес Файлы Загадать слово для поля чудес
Сгенерировать все возможные слова вида: согл+ гл+ согл +гл, записать в файл подсчитать их количество
Ломанная
Dim xt(100), yt(100), n
Private Sub Form_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
n = n + 1: xt(n) = x: yt(n) = y: Line -(x, y)
End Sub
Private Sub mnu_save_Click()
OpenBox.ShowSave
If OpenBox.filename <> "" Then
Open OpenBox.filename + ".txt" For Output As #1
For i = 1 To n
Print #1, xt(i), yt(i)
Next i
Close #1
Else
MsgBox ("нельзя сохранить!")
End If
End Sub
Private Sub mnu_open_Click()
OpenBox.ShowOpen
If OpenBox.filename <> "" Then
Open OpenBox.filename For Input As #1
Input #1, x, y : PSet (x, y)
While Not EOF(1) : Input #1, x, y : Line -(x, y): Wend
n = 0
Close #1
End If
End Sub
Отследить первое нажатие
Первое нажатие – левая кнопка мыши, второе нажатие правая кнопка мыши
Нарисовать ломанную, заданную парами координат в файле
Форматирование текста
не забыть шрифт Courier (моноширинный)
Dim kolsim, SpaceStr
Private Sub Form_Activate()
Open "…\text.txt" For Input As #1
Open "…\text1.txt" For Output As #2
Open "…\text2.txt" For Output As #3
kolsim = 40 : SpaceStr = " "
While Not EOF(1)
Input #1, s: Print s
' форматирование по ширине
k = kolsim - Len(s): d = formatstr(s): Print #3, d
'форматирование по левому краю
s = Mid(SpaceStr, 1, k) + s: Print #2, s
Wend
Close #1:Close #2:Close #3:End Sub
Function formatstr(s)
Dim mesto(100)
'подсчитать число пробелов
k = 0
For i = 1 To Len(s)
If Mid(s, i, 1) = " " Then k = k + 1
Next
'если есть пробелы
If k <> 0 Then
'найти число добавляемых пробелов
dob = (kolsim - Len(s)) \ k: ost = (kolsim - Len(s)) Mod k
ost1 = 0
For i = 1 To Len(s) ' в место пробела добавляем основные пробелы и остаточек
If Mid(s, i, 1) = " " Then
d = d + Mid(SpaceStr, 1, dob + 1)
If ost1 < ost Then d = d + " ": ost1 = ost1 + 1
Else
'переписываем все буквы
d = d + Mid(s, i, 1)
End If
Next
formatstr = d
Else
formatstr = s
End If
End Function
Лабиринт
Обозначения:
@ - начало лабиринта
# - стена лабиринта
. – проход в лабиринте
* - выход из лабиринта
Dim s, n, lab(100, 100), x0, y0, xk, yk
Private Sub Form_Activate()
Open "D:\Masha\Children\Новый курс по программированию\Числовая\80 волновой\labirint.txt" For Input As #1
Input #1, n
'Scale (0, 0)-(n, n)
For i = 1 To n
Input #1, s
'Print s
For j = 1 To n
If Mid$(s, j, 1) = "#" Then Line (j, i)-(j - 1, i - 1), QBColor(8), BF Else Line (j, i)-(j - 1, i - 1), QBColor(8), B
If Mid$(s, j, 1) = "@" Then Circle (j - 0.5, i - 0.5), 0.2: x0 = j: y0 = i
If Mid$(s, j, 1) = "*" Then Line (j, i)-(j - 1, i - 1), QBColor(2), BF: xk = j: yk = i
Next
Next
Close #1
End Sub
Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
Circle (x0 - 0.5, y0 - 0.5), 0.2, BackColor
If KeyCode = 37 Then x0 = x0 - 1
If KeyCode = 38 Then y0 = y0 - 1
If KeyCode = 39 Then x0 = x0 + 1
If KeyCode = 40 Then y0 = y0 + 1
Circle (x0 - 0.5, y0 - 0.5), 0.2
If xk = x0 And yk = y0 Then MsgBox ("Win!!!!"): End
End Sub
Записная книжка? Сортировка индексным файлом?
Доброжелатель
В первой строке файла задано слово, определить можно ли его составить из остального текста не меняя местами буквы.
Олипиадная задача “Антивирус”
Полярные координаты
Вычислительная геометрия (линия и окружность, треугольник и окружность)
Площадь многоугольника
Рекурсия
|
