Задача на массивы и графику

[vyacheslavovich]

В общих чертах... Необходимо создать массив из 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???

[HandKot]

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

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

[Вад]

Пузырёк можно заменить на копирование в себя с пропусками. Тоже должно быть эффектно И эффективно.

[Алексей++]

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

[Вад]

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

То есть, за линейное время удаляем все ненужные элементы и заполняем пропуски. При желании, элементарная оптимизация позволяет не копировать элементы в ту же позицию, в которой они уже есть

[HandKot]

Вад согласен

[vyacheslavovich]

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

Код:

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