Примеры использования PL-объектов

SWI-Prolog

pl_Examples

1. Option Explicit
2.  
3. Sub pl_Examples()
4.   Dim Title, Msg, Ret
5.   Title = "Гедымин - Пролог"
6.   Msg = _
7.         "/* Примеры использования PL-объектов */" & vbCrLf & vbCrLf & _
8.         "%%%%" & vbCrLf & _
9.         "%    pl_Examples" & vbCrLf & _
10.         "%      TgsPLClient: Initialise, IsInitialised"
11.  
12.   Dim PL
13.   Set PL = Designer.CreateObject(nil, "TgsPLClient", "")
14.   If Not PL.IsInitialised Then
15.     If Not PL.Initialise("") Then
16.       Msg = "Ошибка инициализации SWI-Prolog!"
17.       Call MsgBox(Msg, vbCritical + vbOkOnly, Title)
18.       PL.DestroyObject
19.       Exit Sub
20.     End If
21.   End If
22.  
23.   Dim FuncIndex, FuncName, FuncBegin, FuncEnd
24.   FuncName = "pl_Example"
25.   FuncBegin = 1
26.   FuncEnd = 8
27.   For FuncIndex = FuncBegin To FuncEnd
28.     PL.Debug = False
29.     Msg = Msg & vbCrLf & _
30.           Eval(FuncName & FuncIndex & "(PL)")
31.   Next
32.   Msg = Msg & vbCrLf & "%%%%"
33.   PL.DestroyObject
34.  
35.   Dim frmMsg, Creator
36.   Set Creator = New TCreator
37.   Set frmMsg = Creator.GetObject(nil, "usrf_Msg", "")
38.  
39.   frmMsg.Caption = Title
40.   frmMsg.GetComponent("usrg_Msg").Lines.Text = Msg
41.   frmMsg.ShowModal
42. End Sub
43.  
44. Function pl_Example1(ByRef PL)
45.   Dim Title, Msg
46.   Title = vbCrLf & _
47.           "%%" & vbCrLf & _
48.           "% 1. pl_Example1(PL)" & vbCrLf & _
49.           "%      TgsPLClient: Call" & vbCrLf & _
50.           "%      TgsPLTermv: PutAtom, ToString"
51.  
52.   pl_Example1 = ""
53.  
54.   Dim PredicateName, Params
55.   PredicateName = "current_prolog_flag"
56.   Set Params = Designer.CreateObject(2, "TgsPLTermv", "")
57.   Params.PutAtom 0, "executable"
58.  
59.   Msg = _
60.     "% Запрос" & vbCrLf & _
61.     "?- " & PredicateName & "(" & Params.ToString(0) & ", AppPath)."
62.  
63.   If PL.Call(PredicateName, Params) Then
64.     Dim AppPath
65.     AppPath = Params.ToString(1)
66.     Msg = Msg & vbCrLf & _
67.       "AppPath = " & AppPath & "."
68.   Else
69.     Msg = Msg & vbCrLf & "false."
70.   End If
71.  
72.  
73.   pl_Example1 = Title & vbCrLf & Msg & vbCrLf & "%" & vbCrLf & "%%"
74.  
75.   Params.DestroyObject
76. End Function
77.  
78. Function pl_Example2(ByRef PL)
79.   Dim Title, Msg
80.   Title = vbCrLf & _
81.           "%%" & vbCrLf & _
82.           "% 2. pl_Example2(PL)" & vbCrLf & _
83.           "%      TgsPLClient: Call2, Call" & vbCrLf & _
84.           "%      TgsPLTermv: PutAtom, ToString"
85.  
86.   pl_Example2 = ""
87.  
88.   Dim Code
89.   Code = "assertz( pl_Example(pl_Example2, 'Пример 2') )"
90.   Msg = _
91.     "% Выполнение кода" & vbCrLf & _
92.     "?- " & Code & "."
93.  
94.   If PL.Call2(Code) Then
95.     Msg = Msg & vbCrLf & "true."
96.   Else
97.     Msg = Msg & vbCrLf & "false."
98.   End If
99.  
100.   Dim PredicateName, Params
101.   PredicateName = "pl_Example"
102.   Set Params = Designer.CreateObject(2, "TgsPLTermv", "")
103.   Params.PutAtom 0, "pl_Example2"
104.  
105.   Msg = Msg & vbCrLf & _
106.     "% Запрос" & vbCrLf & _
107.     "?- " & PredicateName & "(" & Params.ToString(0) & ", Text)."
108.  
109.   If PL.Call(PredicateName, Params) Then
110.     Msg = Msg & vbCrLf & _
111.       "Text = " & Params.ToString(1) & "."
112.   Else
113.     Msg = Msg & vbCrLf & "false."
114.   End If
115.  
116.   pl_Example2 = Title & vbCrLf & Msg & vbCrLf & "%" & vbCrLf & "%%"
117.  
118.   Params.DestroyObject
119. End Function
120.  
121. Function pl_Example3(ByRef PL)
122.   Dim Title, Msg
123.   Title = vbCrLf & _
124.           "%%" & vbCrLf & _
125.           "% 3. pl_Example3(PL)" & vbCrLf & _
126.           "%      TgsPLClient: Compound, Term, Call" & vbCrLf & _
127.           "%      TgsPLTermv: PutAtom, ToString"
128.  
129.   pl_Example3 = ""
130.  
131.   Dim Goal, Functor, Termv
132.   Set Goal = Designer.CreateObject(1, "TgsPLTermv", "")
133.   Functor = "pl_Example"
134.   Set Termv = Designer.CreateObject(2, "TgsPLTermv", "")
135.   Termv.PutAtom 0, "pl_Example3"
136.   Termv.PutAtom 1, "Пример 3"
137.   Call PL.Compound(Goal.Term(0), Functor, Termv)
138.  
139.   Dim Code
140.   Code = "assertz"
141.   Msg = _
142.     "% Выполнение кода" & vbCrLf & _
143.     "?- " & Code & "( " & Goal.ToString(0) & " )."
144.  
145.   If PL.Call(Code, Goal) Then
146.     Msg = Msg & vbCrLf & "true."
147.   Else
148.     Msg = Msg & vbCrLf & "false."
149.   End If
150.  
151.   Dim PredicateName, Params
152.   PredicateName = "pl_Example"
153.   Set Params = Designer.CreateObject(2, "TgsPLTermv", "")
154.   Params.PutAtom 0, "pl_Example3"
155.  
156.   If PL.Call(PredicateName, Params) Then
157.     Msg = Msg & vbCrLf & _
158.       "% Запрос" & vbCrLf & _
159.       "?- " & PredicateName & "(" & Params.ToString(0) & ", Text)." & vbCrLf & _
160.       "Text = " & Params.ToString(1) & "."
161.   Else
162.     Msg = Msg & vbCrLf & "false."
163.   End If
164.  
165.   pl_Example3 = Title & vbCrLf & Msg & vbCrLf & "%" & vbCrLf & "%%"
166.  
167.   Termv.DestroyObject
168.   Goal.DestroyObject
169.   Params.DestroyObject
170. End Function
171.  
172. Function pl_Example4(ByRef PL)
173.   Dim Title, Msg
174.   Title = vbCrLf & _
175.           "%%" & vbCrLf & _
176.           "% 4. pl_Example4(PL)" & vbCrLf & _
177.           "%      TgsPLClient: LoadScriptByName, Call" & vbCrLf & _
178.           "%      TgsPLTermv: ToString"
179.  
180.   pl_Example4 = ""
181.  
182.   Dim ScriptName
183.   ScriptName = "pl_Examples_Script"
184.  
185.   PL.Debug = True
186.   If Not PL.LoadScriptByName(ScriptName) Then
187.     PL.Debug = False
188.     Exit Function
189.   End If
190.   PL.Debug = False
191.  
192.   Dim PredicateName, Params
193.   PredicateName = "hello_world"
194.   Set Params = Designer.CreateObject(1, "TgsPLTermv", "")
195.  
196.   Msg = _
197.     "% Запрос" & vbCrLf & _
198.     "?- " & PredicateName & "(Hello)."
199.  
200.   If PL.Call(PredicateName, Params) Then
201.     Msg = Msg & vbCrLf & _
202.       "Hello = " & Params.ToString(0) & "."
203.   Else
204.     Msg = Msg & vbCrLf & "false."
205.   End If
206.  
207.   pl_Example4 = Title & vbCrLf & Msg & vbCrLf & "%" & vbCrLf & "%%"
208.  
209.   Params.DestroyObject
210. End Function
211.  
212. Function pl_Example5(ByRef PL)
213.   Dim Title, Msg
214.   Title = vbCrLf & _
215.           "%%" & vbCrLf & _
216.           "% 5. pl_Example5(PL)" & vbCrLf & _
217.           "%      TgsPLClient: Debug, LoadScriptByName" & vbCrLf & _
218.           "%      TgsPLTermv: ToString" & vbCrLf & _
219.           "%      TgsPLQuery: OpenQuery, EOF, NextSolution, Close, Cut"
220.  
221.   pl_Example5 = ""
222.  
223.   Dim ScriptName
224.   ScriptName = "pl_Examples_Script"
225.  
226.   PL.Debug = True
227.   If Not PL.LoadScriptByName(ScriptName) Then
228.     PL.Debug = False
229.     Exit Function
230.   End If
231.   PL.Debug = False
232.  
233.   Dim Params
234.   Set Params = Designer.CreateObject(1, "TgsPLTermv", "")
235.   Dim PredicateName, Query
236.   PredicateName = "hello_world"
237.   Set Query = Designer.CreateObject(nil, "TgsPLQuery", "")
238.   Query.PredicateName = PredicateName
239.   Query.Termv = Params
240.   Query.OpenQuery
241.  
242.   Msg = _
243.     "% Запрос" & vbCrLf & _
244.     "?- " & PredicateName & "(Hello)."
245.  
246.   If Not Query.EOF Then
247.     Do Until Query.EOF
248.       Msg = Msg & vbCrLf & _
249.         "Hello = " & Params.ToString(0)
250.       Query.NextSolution
251.       If Query.EOF Then
252.         Msg = Msg & "."
253.       Else
254.         Msg = Msg & " ;"
255.       End If
256.     Loop
257.   Else
258.     Msg = Msg & vbCrLf & "false."
259.   End If
260.   Query.Close
261.  
262.   Msg = Msg & vbCrLf & _
263.     "% Запрос" & vbCrLf & _
264.     "?- " & PredicateName & "(Hello), !."
265.  
266.   Query.OpenQuery
267.  
268.   If Not Query.EOF Then
269.     Do Until Query.EOF
270.       Msg = Msg & vbCrLf & _
271.         "Hello = " & Params.ToString(0)
272.       Query.Cut
273.       Query.NextSolution
274.       If Query.EOF Then
275.         Msg = Msg & "."
276.       Else
277.         Msg = Msg & " ;"
278.       End If
279.     Loop
280.   Else
281.     Msg = Msg & vbCrLf & "false."
282.   End If
283.   Query.Close
284.  
285.   pl_Example5 = Title & vbCrLf & Msg & vbCrLf & "%" & vbCrLf & "%%"
286.  
287.   Query.DestroyObject
288.   Params.DestroyObject
289. End Function
290.  
291. Function pl_Example6(ByRef PL)
292.   'TERM-TYPE CONSTANTS
293.  Const PL_VARIABLE = 1
294.   Const PL_ATOM = 2
295.   Const PL_INTEGER = 3
296.   Const PL_FLOAT = 4
297.   Const PL_STRING = 5
298.   Const PL_TERM = 6
299.  
300.   Dim Title, Msg
301.   Title = vbCrLf & _
302.           "%%" & vbCrLf & _
303.           "% 6. pl_Example6(PL)" & vbCrLf & _
304.           "%      TgsPLClient: LoadScriptByName" & vbCrLf & _
305.           "%      TgsPLTermv: DataType, ReadInteger, ReadAtom, ReadDate, ReadString" & vbCrLf & _
306.           "%      TgsPLQuery: OpenQuery, EOF, NextSolution, Close"
307.  
308.   pl_Example6 = ""
309.  
310.   Dim ScriptName
311.   ScriptName = "pl_Examples_Script"
312.  
313.   PL.Debug = True
314.   If Not PL.LoadScriptByName(ScriptName) Then
315.     PL.Debug = False
316.     Exit Function
317.   End If
318.   PL.Debug = False
319.  
320.   Dim Params
321.   Set Params = Designer.CreateObject(2, "TgsPLTermv", "")
322.  
323.   Dim PredicateName, Query
324.   Dim Arg1, Arg2
325.   PredicateName = "some_fact"
326.   Set Query = Designer.CreateObject(nil, "TgsPLQuery", "")
327.   Query.PredicateName = PredicateName
328.   Query.Termv = Params
329.   Query.OpenQuery
330.  
331.   Msg = _
332.     "% Запрос" & vbCrLf & _
333.     "?- " & PredicateName & "(Arg1, Arg2)."
334.  
335.   Msg = Msg & vbCrLf & _
336.     "% Обработка фактов"
337.   If Not Query.EOF Then
338.     Do Until Query.EOF
339.       Select Case Params.DataType(0)
340.         Case PL_INTEGER
341.           Arg1 = Params.ReadInteger(0) & ": "
342.         Case PL_ATOM
343.           If IsDate(Params.ReadAtom(0)) Then
344.             Arg1 = Year(Params.ReadDate(0)) & " - "
345.           Else
346.             Arg1 = ""
347.           End If
348.         Case Else
349.           Arg1 = ""
350.       End Select
351.       If Not Arg1 = "" Then
352.         Select Case Params.DataType(1)
353.           Case PL_ATOM
354.             Arg2 = Params.ReadAtom(1)
355.           Case PL_STRING
356.             Arg2 = Params.ReadString(1)
357.           Case Else
358.             Arg2 = ""
359.         End Select
360.         Msg = Msg & vbCrLf & _
361.           "%   " & Arg1 & Arg2
362.       End If
363.       Query.NextSolution
364.     Loop
365.   Else
366.     Msg = Msg & vbCrLf & "false."
367.   End If
368.   Query.Close
369.  
370.   pl_Example6 = Title & vbCrLf & Msg & vbCrLf & "%" & vbCrLf & "%%"
371.  
372.   Query.DestroyObject
373.   Params.DestroyObject
374. End Function
375.  
376. Function pl_Example7(ByRef PL)
377.   Dim Title, Msg
378.   Title = vbCrLf & _
379.           "%%" & vbCrLf & _
380.           "% 7. pl_Example7(PL)" & vbCrLf & _
381.           "%      TgsPLClient: LoadScriptByName, Debug, MakePredicatesOfSQLSelect" & vbCrLf & _
382.           "%      TgsPLTermv: PutAtom, ReadString, PutString" & vbCrLf & _
383.           "%      TgsPLQuery: OpenQuery, EOF, NextSolution, Close"
384.  
385.   pl_Example7 = ""
386.  
387.   Dim ScriptName
388.   ScriptName = "pl_Examples_Script"
389.  
390.   PL.Debug = True
391.   If Not PL.LoadScriptByName(ScriptName) Then
392.     PL.Debug = False
393.     Exit Function
394.   End If
395.   PL.Debug = False
396.  
397.   Dim P_sql, Tv_sql, Q_sql
398.   Dim FactName, SQL
399.   P_sql = "gd_sql"
400.   Set Tv_sql = Designer.CreateObject(2, "TgsPLTermv", "")
401.   Set Q_sql = Designer.CreateObject(nil, "TgsPLQuery", "")
402.   Q_sql.PredicateName = P_sql
403.   Q_sql.Termv = Tv_sql
404.   FactName = "gd_place"
405.   Tv_sql.PutAtom 0, FactName
406.   Q_sql.OpenQuery
407.  
408.   Msg = _
409.     "% Запрос" & vbCrLf & _
410.     "?- " & P_sql & "(" & FactName & ", SQL)."
411.  
412.   Dim Ret
413.  
414.   Msg = Msg & vbCrLf & _
415.     "% Обработка фактов, наполнение базы знаний"
416.   If Not Q_sql.EOF Then
417.     Do Until Q_sql.EOF
418.       SQL = Tv_sql.ReadString(1)
419.       Msg = Msg & vbCrLf & _
420.             "/*" & SQL & "*/" & vbCrLf
421.  
422.       PL.Debug = True
423.       Ret = PL.MakePredicatesOfSQLSelect( _
424.               SQL, _
425.               gdcBaseManager.ReadTransaction, _
426.               FactName, FactName, False)
427.       PL.Debug = False
428.  
429.       Msg = Msg & _
430.             "% Добавлено " & Ret & " фактов " & FactName
431.       Q_sql.NextSolution
432.     Loop
433.   Else
434.     Msg = Msg & vbCrLf & "false."
435.   End If
436.   Q_sql.Close
437.   Q_sql.DestroyObject
438.   Tv_sql.DestroyObject
439.  
440.   Dim P_info, Tv_info, Q_info
441.   Dim PlaceNameIn, PlaceNameOut, PlaceTypeOut
442.   P_info = "place_info"
443.   Set Tv_info = Designer.CreateObject(3, "TgsPLTermv", "")
444.   Set Q_info = Designer.CreateObject(nil, "TgsPLQuery", "")
445.   Q_info.PredicateName = P_info
446.   Q_info.Termv = Tv_info
447.   PlaceNameIn = "Минск"
448.   Tv_info.PutString 0, PlaceNameIn
449.   Q_info.OpenQuery
450.  
451.   Msg = Msg & vbCrLf & _
452.     "% Запрос" & vbCrLf & _
453.     "?- " & P_info & "(""" & PlaceNameIn & """, PlaceNameOut, PlaceTypeOut)."
454.   Msg = Msg & vbCrLf & _
455.     "% Поиск решений"
456.   If Not Q_info.EOF Then
457.     Do Until Q_info.EOF
458.       Msg = Msg & vbCrLf & _
459.             "%   " & Tv_info.ReadString(1) & " (" & Tv_info.ReadString(2) & ")"
460.       Q_info.NextSolution
461.     Loop
462.   Else
463.     Msg = Msg & vbCrLf & "false."
464.   End If
465.   Q_info.Close
466.   Q_info.DestroyObject
467.   Tv_info.DestroyObject
468.  
469.   pl_Example7 = Title & vbCrLf & Msg & vbCrLf & "%" & vbCrLf & "%%"
470. End Function
471.  
472. Function pl_Example8(ByRef PL)
473.   Dim Title, Msg
474.   Title = vbCrLf & _
475.           "%%" & vbCrLf & _
476.           "% 8. pl_Example8(PL)" & vbCrLf & _
477.           "%      TgsPLClient: LoadScriptByName, ExtractData, MakePredicatesOfDataSet" & vbCrLf & _
478.           "%      TgsPLTermv: PutInteger, ReadInteger, ReadString" & vbCrLf & _
479.           "%      TgsPLQuery: OpenQuery, EOF, NextSolution, Close"
480.  
481.   pl_Example8 = ""
482.  
483.   Dim ScriptName
484.   ScriptName = "pl_Examples_Script"
485.   If Not PL.LoadScriptByName(ScriptName) Then
486.     Exit Function
487.   End If
488.  
489.   Dim P_rec, Tv_rec, RecNum
490.   P_rec = "generate_some_rec"
491.   Set Tv_rec = Designer.CreateObject(3, "TgsPLTermv", "")
492.   RecNum = 8
493.   Tv_rec.PutInteger 2, RecNum
494.  
495.   Msg = _
496.     "% Запрос" & vbCrLf & _
497.     "?- " & P_rec & "(ID, Name, " & RecNum & ")."
498.  
499.   Dim CDS
500.   Set CDS = Designer.CreateObject(nil, "TClientDataset", "")
501.   CDS.FieldDefs.Add "ID", ftInteger, 0, True
502.   CDS.FieldDefs.Add "Name", ftString, 20, True
503.   CDS.CreateDataSet
504.   CDS.Open
505.  
506.   Msg = Msg & vbCrLf & _
507.     "% Заполнение клиентского набора данных из Пролог-запроса"
508.   Call PL.ExtractData(CDS, P_rec, Tv_rec)
509.   Msg = Msg & vbCrLf & _
510.     "% Добавлено записей: " & CDS.RecordCount
511.  
512.   If Not CDS.RecordCount = 0 Then
513.     Msg = Msg & vbCrLf & _
514.       "% Считывание клиентского набора данных"
515.       Msg = Msg & vbCrLf & _
516.             "%   ID   Name"
517.     CDS.First
518.     Do Until CDS.Eof
519.       Msg = Msg & vbCrLf & _
520.             "%   " & CDS.FieldByName("ID").AsInteger & _
521.             "    " & CDS.FieldByName("Name").AsString
522.       CDS.Next
523.     Loop
524.   End If
525.   Tv_rec.DestroyObject
526.  
527.   Dim P_cds, Tv_cds, Q_cds
528.   P_cds = "gd_some_rec"
529.   Set Tv_cds = Designer.CreateObject(2, "TgsPLTermv", "")
530.   Set Q_cds = Designer.CreateObject(nil, "TgsPLQuery", "")
531.   Q_cds.PredicateName = P_cds
532.   Q_cds.Termv = Tv_cds
533.  
534.   Dim I, DelCount
535.   DelCount = 3
536.   CDS.First
537.   For I = 1 To DelCount
538.     CDS.Delete
539.   Next
540.   Msg = Msg & vbCrLf & _
541.     "% Удалено первых записей: " & DelCount
542.  
543.   Msg = Msg & vbCrLf & _
544.     "% Наполнение базы знаний из клиентского набора данных"
545.   Dim Ret
546.  
547.   PL.Debug = True
548.   Ret = PL.MakePredicatesOfDataSet(CDS, "ID,Name", P_cds, P_cds, False)
549.   PL.Debug = False
550.    
551.   Msg = Msg & vbCrLf & _
552.     "% Добавлено фактов " & P_cds & ": " & Ret
553.  
554.   CDS.Close
555.   CDS.DestroyObject
556.  
557.   Msg = Msg & vbCrLf & _
558.     "% Запрос" & vbCrLf & _
559.     "?- " & P_cds & "(ID, Name)"
560.   Q_cds.OpenQuery
561.  
562.   Msg = Msg & vbCrLf & _
563.     "% Обработка фактов"
564.   If Not Q_cds.EOF Then
565.     While Not Q_cds.EOF
566.       Msg = Msg & vbCrLf & _
567.             "%   " & Tv_cds.ReadInteger(0) & ": " & Tv_cds.ReadString(1)
568.       Q_cds.NextSolution
569.     Wend
570.   Else
571.     Msg = Msg & vbCrLf & "false."
572.   End If
573.   Q_cds.Close
574.   Q_cds.DestroyObject
575.   Tv_cds.DestroyObject
576.  
577.   pl_Example8 = Title & vbCrLf & Msg & vbCrLf & "%" & vbCrLf & "%%"
578. End Function

pl_Examples_Script

1. % Примеры использования PL-объектов
2.  
3. hello_world(Msg) :-
4.     format(atom(Msg), '~w~w~w', ['Hello', ' ', 'World']).
5. hello_world(Msg) :-
6.     findall(X, some_fact(X), Xs),
7.     atomic_list_concat(Xs, Msg).
8. hello_world("Hello last World").
9.  
10. some_fact(hello).
11. some_fact('Next').
12. some_fact("World").
13.  
14. some_fact(1, 'Delphi').
15. some_fact(2, 'VBScript').
16. some_fact(3, 'Firebird').
17. some_fact(4, 'FastReport').
18. some_fact(5, 'SWI-Prolog').
19. some_fact(none, 0).
20. some_fact('1995-01-01', "Анжелика").
21. some_fact('2003-01-01', "Гедымин").
22. some_fact('2015-01-01', 2.6).
23.  
24. :- dynamic([gd_place/4]).
25.  
26. % gd_place(ID, Parent, Name, PlaceType)
27.  
28. place_info(Name, PlaceName, PlaceType) :-
29.     place_name_type(_, Name, PlaceName, PlaceType).
30.  
31. place_name_type(ID, Name, Name, PlaceType) :-
32.     gd_place(ID, _, Name, PlaceType).
33. place_name_type(ID, Name, PlaceName, PlaceType) :-
34.     gd_place(ID, Parent, Name, _),
35.     place_name_type(Parent, _, PlaceName, PlaceType).
36.  
37. :-  style_check(-atom).
38.  
39. gd_sql(gd_place,
40. "
41. SELECT
42.  p.ID, p.PARENT, p.NAME, p.PLACETYPE
43. FROM
44.  GD_PLACE p
45. "
46. ).
47.  
48. generate_some_rec(ID, Name, Number) :-
49.     integer(Number),
50.     between(1, Number, ID),
51.     atomic_list_concat(["Record", ID], Name).