Chip 1999 May/Chip_1999-05_cd.bin/zkuste/vbasic/Data/Priklady/trideni.bas

BASIC Source File | 1999-03-08 | 6KB | 227 lines

Attribute VB_Name = "Module1"
'Modul: TRIDENI.BAS  Autor: Gⁿrtler Martin
'
'Modul vysv∞tluje na n∞kolika zßkladnφch algoritmech principy t°φd∞nφ
'prvk∙ v poli. Obsahuje Üest znßm²ch t°φdφcφch mechanism∙ ve form∞ procedur.
'Pokud najdete v algoritmech n∞jakΘ chyby, napiÜte mi prosφm na adresu
'[e-mail]

'Funkce zam∞nφ dva prvky v poli
Private Sub swap(ByRef a, ByRef b)
  Dim tmp

  tmp = a
  a = b
  b = tmp
End Sub


'╪azenφ v²b∞rem (select sort)
'Postup:
'
'1.      najdi nejmenÜφ prvek
'2.      dej ho na prvnφ mφsto
'3.      najdi druh² nejmenÜφ prvek
'4.      dej ho na druhΘ mφsto
'5.      à (atd)
'
'Zßkladnφ algoritmus
'
'Public Sub SelectSort(ByRef p As Variant)
'  Dim i As Long, j As Long
'
'  For i = 1 To UBound(p) - 1
'    For j = i + 1 To UBound(p)
'      If p(j) < p(i) Then swap p(i), p(j)
'    Next j
'  Next i
'End Sub
'
'Definujeme-li n jako poΦet prvk∙ vápoli. Potom je efektivita algoritmu nßsledujφcφ:
'
'poΦet porovnßnφ - (n-2)*(n-1), co₧ je asi n2
'poΦet v²m∞n     - (n-2)*(n-1), tedy takΘ n2
'Trvß-li jedna v²m∞na p°ibli₧n∞ 1/1000 sekundy, nenφ tento algoritmus moc
'efektivnφ. Proto jej upravφme tak, ₧e v²m∞na prvk∙ prob∞hne a₧ po nalezenφ
'minimßlnφho prvku.

Public Sub SelectSort(ByRef p As Variant)
  Dim i As Long, j As Long, x As Long, iMin As Long

  x = UBound(p)
  For i = 1 To x - 1
    iMin = i
    For j = i + 1 To x
      If p(j) < p(iMin) Then iMin = j
    Next j
    swap p(i), p(iMin)
  Next i
End Sub

'╪azenφ bublinkovΘ (bubble sort)
'Princip bublinkovΘho spoΦφvß vátzv. probublßvßnφ nejv∞tÜφch prvk∙ na svΘ mφsto.
'Zßkladnφ algoritmus vypadß takto:
'
'For i = 1 To ubound(p) - 1
'  For j = 1 To ubound(p) - 1
'    If p(j) > p(j + 1) Then swap x(j), x(j + 1)
'  Next j
'Next i
'
'Tento algoritmus by Üel zrychlit ·pravou druhΘho °ßdku na °ßdek For j=1 To n-i,
'stßle vÜak bude cyklus probφhat i kdy₧ u₧ bude pole se°azenΘ, proto algoritmus
'upravφme nßsl.: cyklus bude probφhat, jen kdy₧ probφhß v²m∞na.
'
Public Sub BubbleSort(ByRef p As Variant)
  Dim i As Long, j As Long
  Dim bez_Zmeny As Boolean

  i = 1
  Do
    bez_Zmeny = True
    For j = 1 To UBound(p) - 1
      If p(j) > p(j + 1) Then
        swap p(j), p(j + 1)
        bez_Zmeny = False
      End If
    Next j
    i = i + 1
  Loop Until bez_Zmeny
End Sub


'╪azenφ vklßdßnφm (insert sort)
'Princip tohoto t°φd∞nφ spoΦφvß váumφst∞nφ aktußlnφho prvku na jeho sprßvnou
'pozici. Algoritmus prochßzφ pole od prvnφho prvku a aktußlnφ prvek vklßdß
'na sprßvnΘ mφsto (tj. na nejbli₧Üφ pozici vlevo, kde je prvek vlevo menÜφ
'ne₧ aktußlnφ prvek).
'
'Public Sub InsertSort(ByRef p As Variant)
'  Dim i As Long, j As Long
'  Dim tmp
'
'  For i = 2 To UBound(p)
'    tmp = p(i)
'    j = i - 1
'    Do While (tmp < p(j) And (j > 0))
'      p(j + 1) = p(j)
'      j = j - 1
'    Loop
'    p(j + 1) = tmp
'  Next i
'End Sub
'
'Aby byl algoritmus efektivn∞jÜφ, m∙₧eme sekvenΦnφ vyhledßvßnφ sprßvnΘho mφsta
'pro vlo₧enφ prvku nahradit binßrnφm vyhledßvßnφm:

Public Sub InsertSort(ByRef p As Variant)
  Dim i As Long, j As Long, l As Long, r As Long, m As Long
  Dim tmp

  For i = 2 To UBound(p)
    l = 1: r = i - 1
    tmp = p(i)
    Do While l <= r
      m = (l + r) \ 2   'CeloΦφselnΘ d∞lenφ
      If tmp < p(m) Then
        r = m - 1
      Else
        l = m + 1
      End If
    Loop
    For j = i - 1 To l Step -1
      p(j + 1) = p(j)
    Next j
    p(l) = tmp
  Next i
End Sub

'VÜechny v²Üe uvedenΘ algoritmy majφ pom∞rn∞ velkou Φasovou slo₧itost û n2
'Nynφ se budeme zab²vat efektivn∞jÜφmi (rychlejÜφmi) algoritmy. Proto₧e by byl
'popis, jak algoritmus funguje, p°φliÜ obsßhl², odkazuji Φtenß°e na n∞jakou
'odbornou literaturu, kde najdete kompletnφ popis funkce t∞chto algoritm∙

Public Sub ShellSort(ByRef p As Variant)
  Dim gap As Long, i As Long, j As Long, x As Long

  x = UBound(p)
  gap = x \ 2

  Do While gap > 0
    For i = gap To x - 1
      j = i - gap + 1
      Do While (j >= 1)
        If (p(j) > p(j + gap)) Then Exit Do
        swap p(j), p(j + gap)
        j = j - gap
        If j < 1 Then j = 0
      Loop
    Next i
    gap = gap \ 2
  Loop
End Sub

'Procedura potrebna pro proceduru HeapSort
Private Sub Sift(l As Long, r As Long, ByRef p As Variant)
  Dim j As Long, i As Long, pom
  Dim jeste As Boolean

  j = 2 * l
  pom = p(l)
  i = l
  jeste = j < r
  Do While jeste
    If p(j + 1) > p(j) Then j = j + 1
    If p(j) > pom Then
      swap p(j), p(i)
      i = j
      j = 2 * i
      jeste = j < r
    Else
      jeste = False
    End If
  Loop
End Sub

Public Sub HeapSort(ByRef p As Variant)
  Dim i As Long, n As Long

  n = UBound(p)
  For i = n \ 2 To 1 Step -1
    Sift i, n, p
  Next i
  For i = n To 3 Step -1
    swap p(i), p(1)
    Sift 1, i - 1, p
  Next i
  If p(1) > p(2) Then swap p(1), p(2)
End Sub

'Procedura potrebna pro proceduru QuickSort
Private Sub Sorting(l As Long, r As Long, ByRef p As Variant)
  Dim i As Long, j As Long, pom

  i = l
  j = r
  pom = p((l + r) \ 2)
  Do
    Do While p(i) < pom
      i = i + 1
    Loop
    Do While p(j) > pom
      j = j - 1
    Loop
    If i <= j Then
      swap p(i), p(j)
      i = i + 1
      j = j - 1
    End If
  Loop Until i > j
  If l < j Then Sorting l, j, p
  If i < r Then Sorting i, r, p
End Sub

Public Sub QuickSort(ByRef p As Variant)
  Sorting 1, UBound(p), p
End Sub