Форум программистов «Весельчак У»
  *
Добро пожаловать, Гость. Пожалуйста, войдите или зарегистрируйтесь.
Вам не пришло письмо с кодом активации?

  • Рекомендуем проверить настройки временной зоны в вашем профиле (страница "Внешний вид форума", пункт "Часовой пояс:").
  • У нас больше нет рассылок. Если вам приходят письма от наших бывших рассылок mail.ru и subscribe.ru, то знайте, что это не мы рассылаем.
   Начало  
Наши сайты
Помощь Поиск Календарь Почта Войти Регистрация  
 
Страниц: [1]   Вниз
  Печать  
Автор Тема: Задача на массивы и графику  (Прочитано 8721 раз)
0 Пользователей и 1 Гость смотрят эту тему.
vyacheslavovich
Гость
« : 18-11-2009 19:09 » 

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

Код:
Dim color(14) As Integer
Dim colorNotBlack(14) As Integer

Private Sub Mass_rnd()
Randomize

Dim i As Integer
For i = 0 To 14
color(i) = Int(14 * Rnd)
Next i
End Sub

Private Sub Draw()
Mass_rnd
Dim i As Integer
Picture1.FillStyle = 0
Picture1.Scale (0, 0)-(20, 10)
For i = 0 To 14
Select Case color(i)
Case 1
Picture1.FillColor = 16776960
Case 2
Picture1.FillColor = 255
Case 3
Picture1.FillColor = 65280
Case 4
Picture1.FillColor = 65535
Case 5
Picture1.FillColor = 16711680
Case 6
Picture1.FillColor = 16777215
Case 7
Picture1.FillColor = 16711935
Case 8, 9, 10, 11, 12, 13, 14
Picture1.FillColor = 0
End Select
Picture1.Circle (1 + 1 * i, 5), 0.3
Next i
End Sub

Private Sub Command1_Click()
Draw
Picture2.Cls
End Sub

Private Sub Command2_Click()
Picture2.FillStyle = 0
Dim i As Integer
Dim b As Integer
b = 0
For i = 0 To 14
If color(i) >= 8 Then
b = b + 1
Помогите, как далее реализовать сжатие массива со смещением всех кругов к левому краю в Picture2?Не понял??
« Последнее редактирование: 19-11-2009 07:21 от Джон » Записан
HandKot
Молодой специалист

ru
Offline Offline

« Ответ #1 : 19-11-2009 05:52 » 

сжатие массива видится так
1) методом "пузырька" передвинуть все чёрные элементы передвинуть в конец
2) переопределить массив с используя инструкцию Dim Preserve

если надо сжатие отображать в графическом виде, то можно отрисовывать круги в методе "пузырёк" 
должно получится красиво, я думаю
Записан

I Have Nine Lives You Have One Only
THINK!
Вад
Команда клуба

ru
Offline Offline
Пол: Мужской

« Ответ #2 : 19-11-2009 06:14 » 

Пузырёк можно заменить на копирование в себя с пропусками. Тоже должно быть эффектно Улыбаюсь И эффективно.
Записан
Алексей++
глобальный и пушистый
Глобальный модератор

ru
Offline Offline
Сообщений: 13


« Ответ #3 : 19-11-2009 06:26 » 

 копирование в себя с пропусками - это как так ? )
Записан

Вад
Команда клуба

ru
Offline Offline
Пол: Мужской

« Ответ #4 : 19-11-2009 06:40 » 

Это типа сиплюсплюсного std::remove_if Улыбаюсь
Два индекса инициализируются началом массива.
Если элемент по первому индексу нужно копировать (предикат истинный), то он копируется в позицию второго индекса. Соответственно, инкремент первого индекса делается всегда, а второго - только при копировании.
В результате, в хвосте массива останется мусор в количестве удалённых элементов (второй индекс будет указывать на первый такой элемент), и остаётся только удалить этот ненужный хвост.

То есть, за линейное время удаляем все ненужные элементы и заполняем пропуски. При желании, элементарная оптимизация позволяет не копировать элементы в ту же позицию, в которой они уже есть Улыбаюсь
« Последнее редактирование: 19-11-2009 06:42 от Вад » Записан
HandKot
Молодой специалист

ru
Offline Offline

« Ответ #5 : 19-11-2009 13:05 » 

Вад согласен
Записан

I Have Nine Lives You Have One Only
THINK!
vyacheslavovich
Гость
« Ответ #6 : 19-11-2009 15:59 » new

Спасибо всем.. Я сделал так:

Код:
Dim bw_array(13) As Integer

Private Sub random_array()
    Randomize
    Dim random_number, i As Integer
   
    For i = 0 To 13
        bw_array(i) = Round(Rnd * 6)
    Next i
End Sub

Private Sub Command1_Click()
    draw
    Picture2.Cls
End Sub

Private Sub Command2_Click()
    Picture2.FillStyle = vbSolid
    Dim i As Integer
   
    Dim count_black As Integer
    count_black = 0
    For i = 0 To 13
        If (bw_array(i) = 0) Then
            count_black = count_black + 1
        Else
            Select Case bw_array(i)
                Case 1: Picture2.FillColor = vbBlue
                Case 2: Picture2.FillColor = vbGreen
                Case 3: Picture2.FillColor = vbRed
                Case 4: Picture2.FillColor = vbYellow
                Case 5: Picture2.FillColor = vbWhite
                Case 6: Picture2.FillColor = &HC000C0
            End Select
           
            Picture2.Circle (250 + 500 * (i - count_black), 250), 250, vbBlack
        End If
    Next i
   
    If (count_black = 0) Then
        MsgBox "Нет кругов черного цвета."
    End If
   
    Refresh
End Sub


Private Sub Form_Load()
    draw
End Sub

Private Sub draw()
    random_array
   
    Dim i As Integer
   
    Picture1.FillStyle = vbSolid
   
    For i = 0 To 13
        Select Case bw_array(i)
            Case 0: Picture1.FillColor = vbBlack
            Case 1: Picture1.FillColor = vbBlue
            Case 2: Picture1.FillColor = vbGreen
            Case 3: Picture1.FillColor = vbRed
            Case 4: Picture1.FillColor = vbYellow
            Case 5: Picture1.FillColor = vbWhite
            Case 6: Picture1.FillColor = &HC000C0
        End Select
       
        Picture1.Circle (250 + 500 * i, 250), 250, vbBlack
    Next i
End Sub
« Последнее редактирование: 20-11-2009 07:29 от Джон » Записан
Страниц: [1]   Вверх
  Печать  
 

Powered by SMF 1.1.21 | SMF © 2015, Simple Machines