Penelusuran gejala memanfaatkan liner list (versi 2)

Menyambung versi 1, ada beberapa modul yang sama, ada juga sedikit modifikasi, seperti di bawah ini:

---------------------------------------------
form (versi 2)
---------------------------------------------
frmPenelusuran.bas

Option Explicit

Dim pertanyaan() As String 'array pertanyaan
Dim id_link() As String 'array id link list

Private Sub Command1_Click()
On Error Resume Next
If Val(textMB.Text) <= Val(textMD.Text) Then
MsgBox "MB harus lebih besar daripada MD"
textMB.SetFocus
Else
Unload Me
End If
End Sub

Private Sub Form_Load()
Dim i As Integer
Label2.Caption = "Keterangan: " & vbCrLf & "# MD dan MB bernilai antara 0 s.d 1" & vbCrLf & "# Nilai MD < MB"
pertanyaan = Split(str_tanya(1), ",") 'pertanyaan dalam format pertanyaan1, pertanyaan2, ..., pertanyaann dipecah ke dalam array
id_link = Split(str_tanya(0), ",") 'id link list dalam format id1, id2, ..., idn dipecah ke dalam array
Text1.Text = str_trace 'menampilkan pertanyaan yang pernah dijawab sebelumnya untuk kasus tertentu
For i = LBound(pertanyaan) To UBound(pertanyaan) 'tampilkan pertanyaan
List1.AddItem pertanyaan(i)
List1.ItemData(List1.ListCount - 1) = id_link(i) 'simpan id link list
Next i
If List1.ListCount > 0 Then List1.ListIndex = 0 'pilih jawaban pertama
If List1.ListCount = 1 Then Option2.Enabled = False
End Sub

Private Sub Form_Unload(Cancel As Integer)
If Option3.Value Then 'Tidak ada satupun gejala yang sesuai dengan daftar gejala [2]
set_semua_sudah_jawab id_link
jawab_penelusuran = -1
ElseIf List1.ListIndex <> -1 Then
If Option1.Value Then set_semua_sudah_jawab id_link 'Ya, tidak ada lagi gejala lain yang sesuai daftar gejala [2]
Else
Cancel = True
End If
MB = Val(textMB.Text)
MD = Val(textMD.Text)
Set frmPenelusuran = Nothing
End Sub

Private Sub List1_Click()
jawab_penelusuran = List1.ItemData(List1.ListIndex) 'set jawaban dari pertanyaan
End Sub

Private Sub textMB_LostFocus()
On Error Resume Next
If Not IsNumeric(textMB.Text) Then
MsgBox "MB harus berupa angka"
textMB.SetFocus
ElseIf Not (Val(textMB.Text) >= 0 And Val(textMB.Text) <= 1) Then
MsgBox "MB harus bernilai antara 0 sampai dengan 1"
textMB.SetFocus
End If
End Sub

Private Sub textMD_LostFocus()
On Error Resume Next
If Not IsNumeric(textMD.Text) Then
MsgBox "MD harus berupa angka"
textMD.SetFocus
ElseIf Not (Val(textMD.Text) >= 0 And Val(textMD.Text) <= 1) Then
MsgBox "MD harus bernilai antara 0 sampai dengan 1"
textMD.SetFocus
End If
End Sub

frmKesimpulan.bas

Option Explicit

Private Sub Form_Load()
initMemori memori
initMemori memori2
Dim i As Integer
initDatabase AdoAturan, "select aturan from aturan"
initDatabase AdoGejala, "select id_gejala, nama_gejala from gejala order by id_gejala asc"
initDatabase AdoKejadian, "select id_kejadian, nama_kejadian from kejadian order by id_kejadian asc"
initialize_list
With AdoAturan.Recordset
While Not .EOF
parsing ![aturan] 'memeriksa kebenaran aturan, kemudian memasukkan item-item ke dalam list
.MoveNext
Wend
End With
If Not terdapatError Then 'jika tidak ada error sewaktu proses parse
initialize_penelusuran
Trace 0, False 'mulai pelacakan, setiap kejadian akan disimpan
For i = 1 To UBound(str_kejadian) 'mendapatkan semua kejadian / kesimpulan, hasil dari tanya-jawab
Text1.Text = Text1.Text & str_kejadian(i) & vbCrLf
Next i
Else
Text1.Text = definisi_error 'tampilkan error
End If
End Sub

---------------------------------------------
modul
---------------------------------------------
TelusuriAturan.bas

Option Explicit

'area public
Public MB_Lama As Single 'nilai MB sebelumnya
Public MD_Lama As Single 'nilai MD sebelumnya
Public MB As Single 'nilai MB dari penelusuran
Public MD As Single 'nilai MD dari penelusuran
Public jawab_penelusuran As Long 'jawaban dari penelusuran
Public str_trace As String 'menampilkan daftar pertanyaan yang sudah pernah dilalui sebelumnya
Public str_tanya() As String 'daftar pertanyaan yang disajikan
Public str_kejadian() As String 'daftar kejadian yang dihasilkan

'area private
Private ketemu_kejadian As Boolean 'apakah kejadian ditemukan??

'inisialisai penelusuran aturan
Sub initialize_penelusuran()
ReDim str_kejadian(0)
reset_sudahjawab 0
MD_Lama = 0
MB_Lama = 0
MD = 0
MB = 0
End Sub

'penelusuran left to right
Sub LR(idx As Long)
Dim i As Long
For i = 0 To UBound(LinkList(idx).Links)
If LinkList(idx).Links(i) <> -1 Then LR LinkList(idx).Links(i)
Next i
End Sub

'melakukan set ulang pada semua list menjadi belum menjawab
Sub reset_sudahjawab(idx As Long)
Dim i As Long
For i = 0 To UBound(LinkList(idx).Links)
LinkList(idx).SudahJawab = False
If LinkList(idx).Links(i) <> -1 Then LR LinkList(idx).Links(i)
Next i
End Sub

'melakukan pelacakan
Sub Trace(idx As Long, isBackTrace As Boolean)
Dim idx_jawab As Long
Dim str_temp As String
If Not isBackTrace Then 'jika bukan backtrace, maka menyimpan informasi yang dibutuhkan sewaktu terjadi back trace, dengan menyimpannya ke dalam stack
str_temp = ", CF = " & CF(MB_Lama, MB, MD_Lama, MD)
push memori, str_trace & " -> " & LinkList(idx).Id & str_temp
str_trace = str_trace & " -> " & LinkList(idx).Id & str_temp
push memori2, Array(MD_Lama, MB_Lama)
End If
'MsgBox str_trace
str_tanya = daftar_anak_belum_jawab(idx) 'mendaftar pertanyaan yang belum terjawab
If Trim(str_tanya(0)) <> "" Then 'jika ada pertanyaan
idx_jawab = pertanyaan 'berhenti, menanti jawaban, lanjut..
If idx_jawab <> -1 Then 'jika ada jawaban
Dim i As Long
'tampilkan kejadian / kesimpulan (jika ada)
For i = 0 To UBound(LinkList(idx_jawab).Links)
If Left(LinkList(LinkList(idx_jawab).Links(i)).Id, 1) = "=" Then
ReDim Preserve str_kejadian(UBound(str_kejadian) + 1)
str_kejadian(UBound(str_kejadian)) = str_trace & " -> " & LinkList(idx_jawab).Id & " " & LinkList(LinkList(idx_jawab).Links(i)).Id & ", CF = " & CF_(MB_Lama, MB, MD_Lama, MD)
'MsgBox LinkList(LinkList(idx_jawab).Links(0)).Id
End If
Next i
LinkList(idx_jawab).SudahJawab = True 'berarti pertanyaan yang ini sudah terjawab
Trace idx_jawab, False 'pertanyaan berikutnya
str_trace = pop_(memori) 'mempersiapkan urutan jawaban yang pernah dijawab (backtraking)
Dim Temp()
Temp = pop_(memori2)
MD_Lama = Temp(0)
MB_Lama = Temp(1)
Trace idx, True 'backtrace terjadi di sini
End If
End If
End Sub

Function CF(ByRef MB_Lama_ As Single, ByVal MB_ As Single, ByRef MD_Lama_ As Single, ByVal MD_ As Single) As Single
MB_Lama_ = MB_Lama_ + MB_ * (1 - MB_Lama_)
MD_Lama_ = MD_Lama_ + MD_ * (1 - MD_Lama_)
CF = MB_Lama_ - MD_Lama_
End Function

Function CF_(ByVal MB_Lama_ As Single, ByVal MB_ As Single, ByVal MD_Lama_ As Single, ByVal MD_ As Single) As Single
MB_Lama_ = MB_Lama_ + MB_ * (1 - MB_Lama_)
MD_Lama_ = MD_Lama_ + MD_ * (1 - MD_Lama_)
CF_ = MB_Lama_ - MD_Lama_
End Function


'melakukan set ulang pada semua list yang sesuai dengan daftar menjadi sudah menjawab
Sub set_semua_sudah_jawab(list_idx() As String)
Dim i As Long
For i = 0 To UBound(list_idx)
LinkList(list_idx(i)).SudahJawab = True
Next i
End Sub

'mendapatkan daftar anak yang belum menjawab
Function daftar_anak_belum_jawab(idx As Long) As String()
Dim i As Long
Dim Temp(1) As String
For i = 0 To UBound(LinkList(idx).Links)
If LinkList(idx).Links(i) <> -1 Then
If LinkList(LinkList(idx).Links(i)).SudahJawab = False And Not Left(LinkList(LinkList(idx).Links(i)).Id, 1) = "=" Then
Temp(0) = Temp(0) & LinkList(idx).Links(i) & ","
Temp(1) = Temp(1) & LinkList(LinkList(idx).Links(i)).Id & ","
End If
End If
Next i
If Trim(Temp(0)) <> "" Then
Temp(0) = Left$(Temp(0), Len(Temp(0)) - 1)
Temp(1) = Left$(Temp(1), Len(Temp(1)) - 1)
End If
daftar_anak_belum_jawab = Temp
End Function

'berhenti sejenak untuk mengajukan pertanyaan ke pengguna
Function pertanyaan() As Long
frmPenelusuran.Show vbModal
pertanyaan = jawab_penelusuran
End Function

VirtualMemory.bas

'are public
Public memori() As Variant 'virtual memori
Public memori2() As Variant 'virtual memori 2

'inisialisasi virtual memori
Sub initMemori(ByRef mem As Variant)
ReDim mem(0)
End Sub

'memasukkan nilai ke dalam stack
Sub push(ByRef mem As Variant, ByVal nilai As Variant)
ReDim Preserve mem(UBound(mem) + 1)
mem(UBound(mem)) = nilai
End Sub

'mendapatkan nilai dari puncak stack kemudian menghapus yang teratas
Function pop(ByRef mem As Variant) As Variant
pop = mem(UBound(mem))
ReDim Preserve mem(UBound(mem) - 1)
End Function

'menghapus yang teratas kemudian mendapatkan nilai dari puncak stack
Function pop_(ByRef mem As Variant) As Variant
ReDim Preserve mem(UBound(mem) - 1)
pop_ = mem(UBound(mem))
End Function