Option Compare Database
Option Explicit

'Class:   OrderedReeks ('reeks' is dutch for, er, array; it sounds like 'rakes')
'Goal:    Retrieve texts in a certain order after inserting/adding randomly
'          The order is not strict, ascertained is that pairs will have an order.
'          Since 'greater than' is transitive, this will usually imply a sorted result.
'Use:     Add to add data
'         AddPair to order data
'         Write2File to store data (in a file, yes)
'         Loop through all elements with
'           FirstItem
'           Do While Valid
'              dosomethingwith CurrentItem / CurrentContents
'              NextItem
'           Loop
'USES     StringObj.

Private Type Elem
   tekst As String
   titel As String
End Type
'The data stored is in a dictionary-format: titel (title) is like a tag, and is/can be sorted
' tekst (text) is free-form data with any link to titel

Dim elements() As Elem, ptr As Integer, deze As Integer

Private Sub Class_Initialize()
'ROUTINE : Initialize
'PURPOSE : Sorry, I don't see the point of this line.
'INPUT   :
'OUTPUT  :
'CALLS   : .
   ptr = 0
   ReDim elements(ptr)
End Sub

Property Get size() As Integer
'ROUTINE : Size
'PURPOSE : see how many elements we contain
'INPUT   : -
'OUTPUT  : Integer: number of elements
'CALLS   : .

   size = ptr 'now that is hard working
End Property

Sub Add(ByVal cTitel As String, cTekst As String)
'ROUTINE : Add
'PURPOSE : add element under 'titel'
'INPUT   : string: cTitel, titel to add
'          string: cTekst, item to add
'OUTPUT  : -
'CALLS   : inReeks, Replace
'EFFECT  :  if titel already exists: supply item data
'           else add new titel with item data

Dim nPtr As Integer
   If inReeks(cTitel, nPtr) Then
      Replace nPtr, cTekst
   Else
      ptr = ptr + 1
      ReDim Preserve elements(ptr)
      With elements(ptr)
         .titel = cTitel
         .tekst = cTekst
      End With
   End If
End Sub

Sub Append2Current(ByVal cTekst As String)
'ROUTINE : Append2Current
'PURPOSE : extend titel with item data
'INPUT   : string: cTekst, data to add to titel
'OUTPUT  : -
'CALLS   : .

   With elements(deze)
      .tekst = .tekst & cTekst
   End With
End Sub

Sub Replace(ByVal nWhere As Integer, ByVal cTekst As String)
'ROUTINE : Replace
'PURPOSE : supply titel with new item data
'INPUT   : integer: nWhere, internal item position
'          string: cTekst, new item data
'OUTPUT  : -
'CALLS   : .

   If nWhere > ptr Then Exit Sub
   elements(nWhere).tekst = cTekst
End Sub

Function What(ByVal nWhere As Integer) As String
'ROUTINE : What
'PURPOSE : return value of the item
'INPUT   : integer: nWhere, internal item position
'OUTPUT  : string: item data found, or ""
'CALLS   : .

   If nWhere > ptr Then
      What = ""
   Else
      What = elements(nWhere).tekst
   End If
End Function

Sub write2file(ByVal cFile As String, Optional bReverse = False)
'ROUTINE : Write2File
'PURPOSE : store item data in a text file
'INPUT   : string: cFile, path+filename of file to create (this is not checked)
'OUTPUT  : (file)
'CALLS   : .

Dim i As Integer, nFile As Integer
   nFile = FreeFile
   Open cFile For Output As nFile
   If bReverse Then
      For i = ptr To 1 Step -1
         Print #nFile, elements(i).tekst
      Next
   Else
      For i = 1 To ptr
         Print #nFile, elements(i).tekst
      Next
   End If
   Close nFile
End Sub

Sub MoveUnder(ByVal nFrom As Integer, ByVal nTo As Integer)
'ROUTINE : MoveUnder
'PURPOSE : put a certain element under a certain block
'INPUT   : int nFrom: upper element; is moved
'          int nTo: lower element; the nFrom element ends up below this one
'OUTPUT  : .
'CALLS   : .

Dim i As Integer, h As Integer, t As Elem
   If nFrom > ptr Or nTo > ptr Then Exit Sub
   If nFrom > nTo Then h = nFrom: nFrom = nTo: nTo = h
   t = elements(nFrom)
   For i = nFrom To nTo - 1
      elements(i) = elements(i + 1)
   Next
   elements(nTo) = t
End Sub

Sub MoveOver(ByVal nFrom As Integer, ByVal nTo As Integer)
'ROUTINE : MoveOver
'PURPOSE : put a certain element above a certain block
'INPUT   : int nFrom: lower element; is moved
'          int nTo: upper element; the element at nFrom ends up above this one
'OUTPUT  : .
'CALLS   : .

Dim i As Integer, h As Integer, t As Elem
   If nFrom > ptr Or nTo > ptr Then Exit Sub
   If nFrom < nTo Then h = nFrom: nFrom = nTo: nTo = h
   t = elements(nFrom)
   For i = nFrom To nTo + 1 Step -1
      elements(i) = elements(i - 1)
   Next
   elements(nTo) = t
End Sub

Sub Insert(ByVal cName As String, ByVal nWhere As Integer)
'ROUTINE : Insert
'PURPOSE : insert new titel above known internal position; item data remains empty
'           (this is like building a new chapter)
'INPUT   :  string cName: titel to add
'           int nWhere: insert above this position
'OUTPUT  : .
'CALLS   : Add, MoveOver

   If nWhere > ptr Or nWhere < 1 Then Exit Sub
   Add cName, ""
   MoveOver ptr, nWhere
End Sub

Function inReeks(ByVal cWhat As String, nvWhere As Integer) As Boolean
'ROUTINE : inReeks
'PURPOSE : search. check whether a title exists
'INPUT   : string cWhat: titel to seek
'           int nvWhere: VAR index (internal position) that was found
'OUTPUT  : bool: was it found? if not, nvWhere is invalid of course
'CALLS   : .

Dim i As Integer
   inReeks = False
   For i = 1 To ptr
      If elements(i).titel = cWhat Then
         nvWhere = i
         inReeks = True
         Exit For
      End If
   Next
End Function

Function dump() As String
'ROUTINE : dump
'PURPOSE : create long string of all titel elements
'INPUT   : .
'OUTPUT  : string: all 'titel's
'CALLS   : class StringObj

Dim i As Integer, cRes As New StringObj
   cRes.Init "", " : "
   For i = 1 To ptr
      cRes.Add elements(i).titel
   Next
   dump = cRes.Value
End Function

Sub Clear()
'ROUTINE : Clear
'PURPOSE : clear object, make it empty
'INPUT   : .
'OUTPUT  : .
'CALLS   : .

   ptr = 0
End Sub

Sub AddPair(ByVal cAbove As String, cBelow As String)
'ROUTINE : AddPair
'PURPOSE : put two titels in respective order (insert titel tags where necessary)
'INPUT   : string cAbove: first titel to add/order
'           string cBelow: second titel to add/order
'OUTPUT  : .
'CALLS   : inReeks, MoveUnder, Add, Insert
'EFFECT  :
' if neither in list: add both anywhere (but cAbove first)
' if cabove occurs: append cbelow at bottom
' if cbelow occurs: insert cabove immediate above
' if both in list, and in wrong order: move cbelow just below cabove
' otherwise, leave alone

Dim nAbove As Integer, nBelow As Integer
   If inReeks(cAbove, nAbove) Then
      If inReeks(cBelow, nBelow) Then
         If nAbove > nBelow Then
            MoveOver nAbove, nBelow
         Else
            'do nothing
         End If
      Else
         Add cBelow, ""
      End If
   Else
      If inReeks(cBelow, nBelow) Then
         Insert cAbove, nBelow
      Else
         Add cAbove, ""
         Add cBelow, ""
      End If
   End If
End Sub

Function CurrentItem() As String
'ROUTINE : CurrentItem
'PURPOSE : loop utility: current titel
'INPUT   : .
'OUTPUT  : string: titel of current element
'CALLS   : .
'EFFECT  : .
   CurrentItem = elements(deze).titel
End Function

Function CurrentContents() As String
'ROUTINE : CurrentContents
'PURPOSE : loop utility: current item data
'INPUT   : .
'OUTPUT  : string: contents of current item
'CALLS   : .
'EFFECT  : .
   CurrentContents = elements(deze).tekst
End Function

Sub FirstItem()
'ROUTINE : FirstItem
'PURPOSE : loop utility: init
'INPUT   : .
'OUTPUT  : .
'CALLS   : .
'EFFECT  : loop pointer starts at begin
   deze = 1
End Sub

Sub NextItem()
'ROUTINE : NextItem
'PURPOSE : loop utility: increment
'INPUT   : .
'OUTPUT  : .
'CALLS   : .
'EFFECT  : loop pointer moves
   If deze <= ptr Then deze = deze + 1
End Sub

Function Valid() As Boolean
'ROUTINE : Valid
'PURPOSE : loop utility: termination
'INPUT   : .
'OUTPUT  : bool: are currentItem and/or currentContents valid?
'CALLS   : .
'EFFECT  : .
   Valid = (deze <= ptr)
End Function

Sub Flush()
'ROUTINE : Flush
'PURPOSE : remove elements with empty titel tags
'INPUT   : .
'OUTPUT  : .
'CALLS   : .
'EFFECT  : what do you think?

Dim i As Integer, j As Integer, sig As Boolean
   i = 1
   Do While i <= ptr 'This is actually a For statement, but I want to be able to exit
                     ' the inner For without using GOTO
                     'Is that really a problem?
      If elements(i).tekst = "" Then
         sig = True
         For j = i + 1 To ptr
            If elements(j).tekst <> "" Then
               'copy this one to empty found above
               elements(i).titel = elements(j).titel
               elements(i).tekst = elements(j).tekst
               elements(j).tekst = ""
               sig = False
               Exit For
            End If
            If sig Then Exit Do 'If so, all rest is empty!
         Next
      End If
      i = i + 1
   Loop
   ptr = i - 1
   ReDim Preserve elements(ptr) 'kill empty elements
End Sub

Sub Reverse()
'ROUTINE : Reverse
'PURPOSE : put whole array in backwards order
'INPUT   : .
'OUTPUT  : .
'CALLS   : .
'EFFECT  : what do you think?

Dim i As Integer, hold As Elem
   For i = 1 To Int(ptr / 2)
      hold = elements(i)
      elements(i) = elements(ptr - i + 1)
      elements(ptr - i + 1) = hold
   Next
End Sub