VERSION 5.00
Begin VB.Form frmMain 
   BackColor       =   &H8000000A&
   BorderStyle     =   1  'Fest Einfach
   Caption         =   "Sorierung von Arrays bildlich dargestellt                 Copyright © 2002 white-"
   ClientHeight    =   2595
   ClientLeft      =   45
   ClientTop       =   330
   ClientWidth     =   6840
   Icon            =   "frmMain.frx":0000
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   2595
   ScaleWidth      =   6840
   StartUpPosition =   1  'Fenstermitte
   Begin VB.Frame fraConf 
      Caption         =   "Sortierung "
      Height          =   2535
      Left            =   2520
      TabIndex        =   1
      Top             =   0
      Width           =   4215
      Begin VB.CommandButton btnGFX 
         Caption         =   "gfx on"
         Height          =   255
         Left            =   2160
         TabIndex        =   14
         Top             =   240
         Width           =   615
      End
      Begin VB.TextBox edtTime 
         Appearance      =   0  '2D
         BackColor       =   &H80000003&
         Height          =   285
         Index           =   4
         Left            =   1920
         TabIndex        =   13
         Top             =   2160
         Width           =   855
      End
      Begin VB.TextBox edtTime 
         Appearance      =   0  '2D
         BackColor       =   &H80000003&
         Height          =   285
         Index           =   3
         Left            =   1920
         TabIndex        =   12
         Top             =   1800
         Width           =   855
      End
      Begin VB.TextBox edtTime 
         Appearance      =   0  '2D
         BackColor       =   &H80000004&
         Height          =   285
         Index           =   2
         Left            =   1920
         TabIndex        =   11
         Top             =   1440
         Width           =   855
      End
      Begin VB.TextBox edtTime 
         Appearance      =   0  '2D
         BackColor       =   &H80000003&
         Height          =   285
         Index           =   1
         Left            =   1920
         TabIndex        =   10
         Top             =   1080
         Width           =   855
      End
      Begin VB.CommandButton btnQuickSort 
         Caption         =   "QuikSort"
         Height          =   255
         Left            =   120
         TabIndex        =   9
         Top             =   2160
         Width           =   1695
      End
      Begin VB.ListBox lstValues 
         Appearance      =   0  '2D
         BackColor       =   &H8000000A&
         Height          =   2175
         ItemData        =   "frmMain.frx":08CA
         Left            =   2880
         List            =   "frmMain.frx":08CC
         TabIndex        =   8
         Top             =   240
         Width           =   1215
      End
      Begin VB.CommandButton btnAustausch 
         Caption         =   "Austauschverfahren"
         Height          =   255
         Left            =   120
         TabIndex        =   7
         Top             =   1440
         Width           =   1695
      End
      Begin VB.CommandButton btnAuswahl 
         Caption         =   "Auswahlverfahren"
         Height          =   255
         Left            =   120
         TabIndex        =   6
         Top             =   1080
         Width           =   1695
      End
      Begin VB.CommandButton btnShellSort 
         Caption         =   "ShellSort"
         Height          =   255
         Left            =   120
         TabIndex        =   5
         Top             =   1800
         Width           =   1695
      End
      Begin VB.CommandButton btnBuildArray 
         Caption         =   "Build Array"
         Height          =   255
         Left            =   120
         TabIndex        =   4
         Top             =   600
         Width           =   2655
      End
      Begin VB.TextBox edtAnzahl 
         Appearance      =   0  '2D
         BackColor       =   &H8000000A&
         Height          =   285
         Left            =   120
         TabIndex        =   2
         Text            =   "1000"
         Top             =   240
         Width           =   735
      End
      Begin VB.Line Line2 
         BorderColor     =   &H8000000C&
         X1              =   120
         X2              =   2750
         Y1              =   960
         Y2              =   960
      End
      Begin VB.Line Line1 
         BorderColor     =   &H80000005&
         BorderStyle     =   6  'Innen ausgefüllt
         BorderWidth     =   2
         X1              =   120
         X2              =   2750
         Y1              =   960
         Y2              =   960
      End
      Begin VB.Label lblAnzahl 
         Caption         =   "Anzahl (10-650)"
         Height          =   255
         Left            =   960
         TabIndex        =   3
         Top             =   240
         Width           =   1215
      End
   End
   Begin VB.PictureBox picDisplay 
      Appearance      =   0  '2D
      BackColor       =   &H80000006&
      ForeColor       =   &H80000007&
      Height          =   2415
      Left            =   50
      ScaleHeight     =   159
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   159
      TabIndex        =   0
      Top             =   120
      Width           =   2415
   End
End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Option Base 0
'Private arrValues() As Integer
Private Declare Function GetTickCount Lib "kernel32" _
() As Long
Private StartTime As Long
Private bolSort As Boolean
Private bolBuild As Boolean


Private Sub btnBuildArray_Click()
    Dim z, i, intCurr As Integer
    
    bolBuild = False
    doDisBut
    z = CInt(edtAnzahl.Text)
    If btnGFX.Caption = "gfx on" Then
        If z < 10 Or z > 650 Then
            MsgBox "Es sind nur Werte zwischen 10 und 650 erlaubt" _
                , vbOKOnly, "Warnung"
            doEnBut
            Exit Sub
        End If
        
        '
        ' Das Formular vergrößern oder verkleinern
        ' abhängig von der Anzahl der Arrayelemente
        If picDisplay.ScaleWidth < z + 2 Then
            Do While picDisplay.ScaleWidth < z + 2
                frmMain.Width = frmMain.Width + 1
                If picDisplay.Height + 550 > frmMain.Height Then
                    frmMain.Height = frmMain.Height + 1
                End If
                picDisplay.Width = picDisplay.Width + 1
                picDisplay.Height = picDisplay.Height + 1
                fraConf.Left = fraConf.Left + 1
                If frmMain.Width + frmMain.Left > Screen.Width Then
                    doCenterForm
                End If
                DoEvents
            Loop
        Else
            Do While picDisplay.ScaleWidth > z + 2
                frmMain.Width = frmMain.Width - 1
                If Not frmMain.Height < fraConf.Height + 500 Then
                    frmMain.Height = frmMain.Height - 1
                End If
                picDisplay.Width = picDisplay.Width - 1
                picDisplay.Height = picDisplay.Height - 1
                fraConf.Left = fraConf.Left - 1
                DoEvents
            Loop
        End If
        doCenterForm
    End If
    
    '
    ' Das Array neu dimensionieren und mit zufälligen Werten füllen
    ' danach anzeigen
    lstValues.Clear
    frmBuildArray.Show 1, frmMain
    
    If btnGFX.Caption = "gfx on" Then
        doPaintValues (arrValues)
    End If
    
    bolSort = False
    bolBuild = True
    doEnBut
End Sub

'
' Prüft die Zufallszahl
' es dürfen nicht zwei mal die selben Werte verwendet werden
Public Function chkRndValue(Value As Integer)
    Dim i As Integer
       
    For i = 0 To UBound(arrValues)
        If arrValues(i) = Value Then
            chkRndValue = True
            Exit Function
        End If
    Next i
    chkRndValue = False
End Function


Public Function ShellSort(SortField As Variant)
    Dim tmp As Variant
    Dim i, j, k, Bis As Long
        
    Bis = UBound(SortField)
    k = Bis \ 2
        
    Do While k > 0
        For i = 0 To Bis - k
            j = i
            Do While j >= 0 And SortField(j) > SortField(j + k)
                tmp = SortField(j)
                Call doClearPoint(tmp, j)
                Call doClearPoint(SortField(j + k), j + k)
                SortField(j) = SortField(j + k)
                Call doSetPoint(SortField(j), j)
                SortField(j + k) = tmp
                Call doSetPoint(SortField(j + k), j + k)
                
                Call delay
                
                If j > k Then
                    j = j - k
                Else
                    j = 0
                End If
            Loop
            ' doPaintValues (SortField)
        Next i
        k = k \ 2
    Loop
    
    ShellSort = SortField
End Function


Public Function SortAuswahl(SortField As Variant)
    Dim Bis, i, j, k, l As Long
    Dim tmp As Variant
    
    Bis = UBound(SortField)
        
    For i = 0 To Bis - 1
        tmp = SortField(i)
        k = i
        For j = i + 1 To Bis
            If SortField(j) < tmp Then
                tmp = SortField(j)
                k = j
            End If
        Next j
        Call doClearPoint(SortField(k), k)
        Call doClearPoint(SortField(i), i)
        SortField(k) = SortField(i)
        Call doSetPoint(SortField(k), k)
        SortField(i) = tmp
        Call doSetPoint(SortField(i), i)
        delay
    Next i
    
    SortAuswahl = SortField
End Function


Public Function SortAustausch(SortField As Variant)
    Dim i, j, Bis As Long
    Dim tmp As Variant
    
    Bis = UBound(SortField)
    
    For i = 0 To Bis - 1
        For j = i + 1 To Bis
                If SortField(i) > SortField(j) Then
                        Call doClearPoint(SortField(i), i)
                        Call doClearPoint(SortField(j), j)
                        tmp = SortField(i)
                        SortField(i) = SortField(j)
                        Call doSetPoint(SortField(i), i)
                        SortField(j) = tmp
                        Call doSetPoint(SortField(j), j)
                        delay2
                End If
        Next j
    Next i
    
    SortAustausch = SortField
End Function


Public Function SortQuickSort(vSort As Variant, _
  Optional ByVal lngStart As Variant, _
  Optional ByVal lngEnd As Variant)

  ' Wird die Bereichsgrenze nicht angegeben,
  ' so wird das gesamte Array sortiert
  
  If IsMissing(lngStart) Then lngStart = LBound(vSort)
  If IsMissing(lngEnd) Then lngEnd = UBound(vSort)
  
  Dim i As Long
  Dim j As Long
  Dim h As Variant
  Dim x As Variant
  
  i = lngStart: j = lngEnd
  x = vSort((lngStart + lngEnd) / 2)
  
  ' Array aufteilen
  Do
  
    While (vSort(i) < x): i = i + 1: Wend
    While (vSort(j) > x): j = j - 1: Wend
        
    If (i <= j) Then
      ' Wertepaare miteinander tauschen
      Call doClearPoint(vSort(i), i)
      Call doClearPoint(vSort(j), j)
      h = vSort(i)
      vSort(i) = vSort(j)
      Call doSetPoint(vSort(i), i)
      vSort(j) = h
      Call doSetPoint(vSort(j), j)
      delay
      
      i = i + 1: j = j - 1
    End If
  Loop Until (i > j)
  
  ' Rekursion (Funktion ruft sich selbst auf)
  If (lngStart < j) Then vSort = SortQuickSort(vSort, lngStart, j)
  If (i < lngEnd) Then vSort = SortQuickSort(vSort, i, lngEnd)
  
  SortQuickSort = vSort
End Function


Private Sub btnGFX_Click()
    If btnGFX.Caption = "gfx on" Then
        btnGFX.Caption = "gfx off"
        lblAnzahl.Caption = "Anzahl"
    Else
        btnGFX.Caption = "gfx on"
        lblAnzahl.Caption = "Anzahl (10-650)"
    End If
End Sub

Private Sub btnShellSort_Click()
    Dim i As Integer
    doDisBut
    chkIsSort
    If Not chkIsBuild Then
        btnBuildArray_Click
        DoEvents
        If Not chkIsBuild Then Exit Sub
    End If
    DoEvents
    doDisBut
    
    doStartTimer
    arrValues = ShellSort(arrValues)
    doStopTimer (3)
    bolSort = True
    
    lstValues.Clear
    For i = 0 To UBound(arrValues)
        'picDisplay.PSet (i + 1, arrValues(i))
        lstValues.AddItem (CStr(arrValues(i)))
    Next i
    doEnBut
End Sub


Private Sub btnAuswahl_Click()
    Dim i As Integer
    chkIsSort
    If Not chkIsBuild Then
        btnBuildArray_Click
        DoEvents
        If Not chkIsBuild Then Exit Sub
    End If
    DoEvents
    doDisBut
    
    doStartTimer
    arrValues = SortAuswahl(arrValues)
    doStopTimer (1)
    bolSort = True
    
    lstValues.Clear
    For i = 0 To UBound(arrValues)
        lstValues.AddItem (CStr(arrValues(i)))
    Next i
    doEnBut
End Sub


Private Sub btnAustausch_Click()
    Dim i As Integer
    
    doDisBut
    chkIsSort
    If Not chkIsBuild Then
        btnBuildArray_Click
        DoEvents
        If Not chkIsBuild Then Exit Sub
    End If
    DoEvents
    doDisBut
    
    doStartTimer
    arrValues = SortAustausch(arrValues)
    doStopTimer (2)
    bolSort = True
    
    lstValues.Clear
    For i = 0 To UBound(arrValues)
        lstValues.AddItem (CStr(arrValues(i)))
    Next i
    doEnBut
End Sub


Private Sub btnQuickSort_Click()
    Dim i As Integer
    
    doDisBut
    chkIsSort
    If Not chkIsBuild Then
        btnBuildArray_Click
        DoEvents
        If Not chkIsBuild Then Exit Sub
    End If
    DoEvents
    doDisBut
    
    doStartTimer
    arrValues = SortQuickSort(arrValues)
    doStopTimer (4)
    bolSort = True
    
    lstValues.Clear
    For i = 0 To UBound(arrValues)
        lstValues.AddItem (CStr(arrValues(i)))
    Next i
    doEnBut
End Sub


Public Sub doPaintValues(Values As Variant)
    Dim i As Integer
    
    picDisplay.Cls
    For i = 0 To UBound(Values)
        Call doSetPoint(Values(i), i)
    Next i
End Sub

'
' Löscht einen einzellnen Punkt
Public Sub doClearPoint(ByVal Wert, ByVal Pos As Integer)
    If btnGFX.Caption = "gfx on" Then
        picDisplay.PSet (Pos, Wert), &H0&
    End If
End Sub

'
' Setzt einen einzellnen Punkt
Public Sub doSetPoint(ByVal Wert, ByVal Pos As Integer)
    ' grün      -> &H00008000&
    ' grau      -> &H8000000A&
    ' schwarz   -> &H00000000&
    ' rot       -> &H000000FF&
    ' gelb      -> &H0000FFFF&
    If btnGFX.Caption = "gfx on" Then
        picDisplay.PSet (Pos, Wert), &HFFFF&
    End If
End Sub

'
' Pausiert für eine bestimmte zeit
Public Sub delay()
    Dim Start, Check
    
    If btnGFX.Caption = "gfx on" Then
        Start = GetTickCount()
        Do Until Check >= Start + 5
            Check = GetTickCount()
            DoEvents
        Loop
    End If
End Sub


Public Sub delay2()
    Dim i As Integer
    If btnGFX.Caption = "gfx on" Then
        For i = 0 To 10
            DoEvents
        Next i
    End If
End Sub


Public Sub doCenterForm()
    Dim ScreenW, ScreenH, FrmW, FrmH
    
    ScreenW = Screen.Width
    ScreenH = Screen.Height
    FrmW = frmMain.Width
    FrmH = frmMain.Height
    
    
    frmMain.Left = ScreenW / 2 - FrmW / 2
    frmMain.Top = (ScreenH / 2 - FrmH / 2) - 150
End Sub



Private Sub Form_Load()
    doCenterForm
    bolSort = False
    bolBuild = False
End Sub

Public Sub doDisBut()
    btnAustausch.Enabled = False
    btnAuswahl.Enabled = False
    btnBuildArray.Enabled = False
    btnQuickSort.Enabled = False
    btnShellSort.Enabled = False
End Sub


Public Sub doEnBut()
    btnAustausch.Enabled = True
    btnAuswahl.Enabled = True
    btnBuildArray.Enabled = True
    btnQuickSort.Enabled = True
    btnShellSort.Enabled = True
End Sub


Private Sub doStartTimer()
    StartTime = GetTickCount
End Sub


Private Sub doStopTimer(Index As Integer)
    Dim StopTime As Long
    
    StopTime = GetTickCount - StartTime
    edtTime(Index).Text = StopTime & " ms"
End Sub


Private Sub chkIsSort()
    If bolSort Then
        btnBuildArray_Click
    End If
End Sub

Private Function chkIsBuild()
    If bolBuild Then
        chkIsBuild = True
    Else
        chkIsBuild = False
    End If
End Function
