Оптимизировать цикл

[Tin]

Сабж...
Проблема в том, что массив PicBits ооооооооочень большой...

Код: Выделить всё

Do While Not Cnt >= UBound(PicBits)
       For I = 0 To 3
            PicBitsNew(Cnt2 + I) = PicBits(Cnt + I)
       Next
       Cnt2 = Cnt2 + 4
       Cnt = Cnt + ZM2
       BPLT = BPLT + 1
       If BPLT = C Then Cnt = Cnt + TpB: BPLT = 1
Loop


[Matew]

Код: Выделить всё

Ub = UBound(PicBits)
Do While Not Cnt >= Ub
...


Это в глаза бросается..

[alibek]

А почему Do...Loop, а не For...Next?

[Tin]

Вообще никак не ускоряет, ес честно - уже пробовал

[Matew]

А может расписать задачу? Возможно тогда мысли появятся...

[alibek]

Пусть не ускоряет, но смотреться будет красивее.
К тому же границы For...Next считаются только единожды, там вполне можно использовать UBound().

[uhm]

Что сразу вспомнилось - циклы от x до 0 работают немного быстрее, чем циклы от 0 до x. Вроде бы

[alibek]

Можно попробовать вместо битов работать с байтами. Должно помочь.

[Tin]

Что-то вроде... В Temp1 лежит БОЛЬШАЯ картинка, уменьшается на ZM и помещается Temp2

Код: Выделить всё

Sub PaintSmallPic2(Zm As Integer)
Temp2.Width = Temp1.Width / Zm
Temp2.Height = Temp1.Height / Zm

GetObject Temp1.Image, Len(PicInfo), PicInfo

BytesPerLine = (PicInfo.bmWidth * 3 + 3) And &HFFFFFFFC
ReDim PicBits(1 To BytesPerLine * PicInfo.bmHeight * 3) As Byte
ReDim PicBitsNew(1 To ((BytesPerLine * PicInfo.bmHeight * 3) / Zm ^ 2)) As Byte
Rem Загружаем картинку в массив
GetBitmapBits Temp1.Image, UBound(PicBits), PicBits(1)
Cnt2 = 1
Cnt = 1
Dim BPLT As Integer
BPLT = 1
Dim TpB As Integer
TpB = Temp1.Width + BytesPerLine
Dim C As Integer
C = Temp1.Width / 2
Dim I As Byte
Dim ZM2 As Byte
ZM2 = 4 * Zm
Dim UB As Double
UB = UBound(PicBits)
Dim TM As Long
TM = timeGetTime

Do While Not Cnt >= UB
       For I = 0 To 3
            PicBitsNew(Cnt2 + I) = PicBits(Cnt + I)
       Next
       Cnt2 = Cnt2 + 4
       Cnt = Cnt + ZM2
       BPLT = BPLT + 1
       If BPLT = C Then Cnt = Cnt + TpB: BPLT = 1
Loop
Me.Caption = timeGetTime - TM
'Set the bits back to the picture
SetBitmapBits Temp2.Image, UBound(PicBitsNew), PicBitsNew(1)

End Sub


[Tin]

Do...Loop потому что Cnt в цикле изменяется на TrB

[Andrey Fedorov]

Что-то вроде... В Temp1 лежит БОЛЬШАЯ картинка, уменьшается на ZM и помещается Temp2

Что-то не пойму - почему бы просто не поместь картинку сразу в Temp2 (PictureBox?) нужного размера? Для этого никаких циклов не нужно...

[Antonariy]

Код: Выделить всё

Ub = UBound(PicBits)
Do While Cnt < Ub

Больше нечего ускорять.

[Tin]

2Andrey Fedorov: Мне нужен этот массив в уменьшенном виде для последующих действий

[Andrey Fedorov]

2Andrey Fedorov: Мне нужен этот массив в уменьшенном виде для последующих действий

Ну и бери его уже из новой картинки.

[Tin]

Ну вообщем не то это... Мне нужно именно из большого массива сделать маленький - а это очень долго...

[alibek]

Do...Loop потому что Cnt в цикле изменяется на TrB

Ну и что?
Кто мешает его менять в For...Next?

[Tin]

Все равно не особо помагло...

[GSerg]

А после этого скомпилируй с опцией Remove array bounds check.

[Captain]

Код: Выделить всё

       For I = 0 To 3
            PicBitsNew(Cnt2 + I) = PicBits(Cnt + I)
       Next


а если так?

Код: Выделить всё

CopyMemory PicBitsNew(Cnt2), PicBits(Cnt), 4

[Faust]

For I = 0 To 3

а четвертый канал используется?

[Tin]

Вот что-то более новое и что нуждается в ХОРОШЕЙ оптимизации - врмея выполнение на картинке 2048х1536 около 16 секунд на 2000 целере.

Что этот кусок делает:
Уменьшает картинку в Temp1 в Zm раз и помещает её в Temp2. При этом уменьшеная картинка не приобретает квадратиков... Блурится вообщем

Код: Выделить всё

Sub PaintSmallPic3(Zm As Integer)
Dim TM As Long
Dim TM2 As Long
Dim TpB As Integer
Dim C As Integer
Dim I As Byte
Dim I1 As Integer
Dim UB As Double
Dim X As Integer
Dim Y As Integer
Dim MyBitmap() As MBitmap
Dim TempSum() As Integer
TM = timeGetTime
Temp2.Width = Temp1.Width / Zm
Temp2.Height = Temp1.Height / Zm
GetObject Temp1.Image, Len(PicInfo), PicInfo
BytesPerLine = (PicInfo.bmWidth * 3 + 3) And &HFFFFFFFC
ReDim PicBits(1 To BytesPerLine * PicInfo.bmHeight * 3) As Byte
ReDim PicBitsNew(1 To BytesPerLine * PicInfo.bmHeight * 3) As Byte
'ReDim MyBitmap(1 To Temp1.Width, 1 To Temp1.Height) As MBitmap
ReDim TempSum((Temp1.Width / Zm) * 3) As Integer
Rem Загружаем картинку в массив
GetBitmapBits Temp1.Image, UBound(PicBits), PicBits(1)
C = Temp1.Width
UB = UBound(PicBits)
TM2 = timeGetTime
AddLog "Время загрузки в массив: " & TM2 - TM

TM = timeGetTime
Dim WPic As Integer
Dim XStp As Integer
Dim YStp As Integer
Dim ZmSQR As Integer
Dim PBNCount As Double
PBNCount = 1
ZmSQR = (Zm ^ 2)
WPic = 1
X = 1
Y = 1
XStp = 1
YStp = 1
For Cnt = 1 To UB - 1 Step 4
    For I = 0 To 2
        TempSum(X + I) = TempSum(X + I) + PicBits(Cnt + I)
    Next
    XStp = XStp + 1
    If XStp > Zm Then XStp = 1: X = X + 3
    WPic = WPic + 1
    If WPic > C Then
        WPic = 1
        X = 1
        YStp = YStp + 1
        If YStp > Zm Then
            Rem Обработан некий участок массива, подготовка и запись его в новый массив
            YStp = 1
            For I1 = 1 To UBound(TempSum) Step 3
                For I = 0 To 2
                    TempSum(I1 + I) = TempSum(I1 + I) / ZmSQR
                    PicBitsNew(PBNCount) = TempSum(I1 + I)
                    TempSum(I1 + I) = 0
                    PBNCount = PBNCount + 1
                Next
                PicBitsNew(PBNCount) = 0
                PBNCount = PBNCount + 1
            Next
        End If
    End If
Next

TM2 = timeGetTime
SetBitmapBits Temp2.Image, UBound(PicBitsNew), PicBitsNew(1)
AddLog "Время зарузки в Temp2: " & TM2 - TM


[Andrey Fedorov]

Компиляция в Native code может дать прирост где-то на порядок...
Попробуй.

[Tin]

После компиляции в Native код с галочкой Remove array bounds check скорость обработки стала около 2х секунд...