150 lines
4.7 KiB
Scheme
150 lines
4.7 KiB
Scheme
(load "shared/util.scm")
|
|
(load "shared/sicp-query.scm")
|
|
|
|
(initialize-data-base microshaft-data-base)
|
|
|
|
(display "\nex-4.61 - next-to\n")
|
|
|
|
(eval-query '(append-to-form x y z))
|
|
(eval-query '(rule (append-to-form () ?y ?y)))
|
|
(eval-query
|
|
'(rule (append-to-form (?u . ?v) ?y (?u . ?z))
|
|
(append-to-form ?v ?y ?z)))
|
|
|
|
(eval-query '(append-to-form (a b) (c d) ?z)) (newline)
|
|
; (eval-query '(append-to-form (a b) ?y (a b c d))) (newline)
|
|
; (eval-query '(append-to-form ?x ?y (a b c d))) (newline)
|
|
|
|
(eval-query '(rule (?x next-to ?y in (?x ?y . ?u))))
|
|
|
|
(eval-query
|
|
'(rule (?x next-to ?y in (?v . ?z))
|
|
(?x next-to ?y in ?z)))
|
|
|
|
; (eval-query '(?x next-to ?y in (1 (2 3) 4))) (newline)
|
|
; (1 next-to (2 3))
|
|
; ((2 3) next-to 4)
|
|
|
|
; (eval-query '(?x next-to 1 in (2 1 3 1))) (newline)
|
|
; (2 next-to 1)
|
|
; (3 next-to 1)
|
|
|
|
(display "[answered]\n")
|
|
|
|
(display "\nex-4.62 - last-pair\n")
|
|
|
|
(eval-query '(rule (last-pair (?x . ()) (?x . ()))))
|
|
(eval-query
|
|
'(rule (last-pair (?u . ?v) ?x)
|
|
(last-pair ?v ?x)))
|
|
|
|
(eval-query '(last-pair (1 2 3) ?y))
|
|
(eval-query '(last-pair (3) ?y))
|
|
(eval-query '(last-pair (2 3 4 5 ?x) (3)))
|
|
(newline)
|
|
|
|
; (eval-query '(last-pair ?x (3))) results in an endless loop because there is
|
|
; no definite answer. Any arbitrary number of symbols before the 3 would form a
|
|
; solution.
|
|
|
|
(display "\nex-4.63 - genesis-family\n")
|
|
|
|
(eval-query '(rule (grandson ?grandparent ?grandson)
|
|
(and (nson ?grandparent ?son)
|
|
(nson ?son ?grandson))))
|
|
|
|
(eval-query '(rule (nson ?parent ?son)
|
|
(or (son ?parent ?son)
|
|
(and (wife ?parent ?wife)
|
|
(son ?wife ?son)))))
|
|
|
|
(eval-query '(grandson Cain ?x))
|
|
(eval-query '(nson Lamech ?x))
|
|
(eval-query '(grandson Methushael ?x))
|
|
(newline)
|
|
|
|
(display "\nex-4.64 - outranked-loop\n")
|
|
|
|
(eval-query
|
|
'(rule (outranked-by-2 ?staff-person ?boss)
|
|
(or (supervisor ?staff-person ?boss)
|
|
(and (outranked-by-2 ?middle-manager ?boss)
|
|
(supervisor ?staff-person ?middle-manager)))))
|
|
|
|
; The first part of the or-clause finds a single stream. When evaluating the
|
|
; second part of the and clause ?middle-manager and ?boss are not assigned to
|
|
; any values yet. Therefore, in the recursive application of the rule
|
|
; outranked-by-2 is invoked again. Again, with no assignments. By swapping the
|
|
; two patterns in the and-clause the rule first creates frames and then invokes
|
|
; the recursive call. If supervisor does not return any results outranked-by-2
|
|
; is not invoked again and there is no endless-loop.
|
|
|
|
; (eval-query '(outranked-by-2 (Bitdiddle Ben) ?who))
|
|
(display "[answered]\n")
|
|
|
|
(display "\nex-4.65 - four-wheels\n")
|
|
|
|
;(rule (wheel ?person)
|
|
; (and (supervisor ?middle-manager ?person)
|
|
; (supervisor ?staff ?middle-manager)))
|
|
|
|
; The wheel rule returns a match for each staff person that is under a
|
|
; middle-manager. Ben and Eben are under Oliver. Ben supervises Alyssa, Cy D,
|
|
; and Lem E. Eben supervises Robert. Hence, there are four results for Oliver.
|
|
; Louis works under Alyssa who works under Ben, which is why Ben only shows up
|
|
; once.
|
|
|
|
(eval-query '(wheel ?who))
|
|
(display "\n[answered]\n")
|
|
|
|
(display "\nex-4.66 - accumulation-function\n")
|
|
|
|
; Ben's solution would yield wrong results for a query like wheel where the
|
|
; same entry is returned multiple times. For the example provided, everything
|
|
; would work fine. So, I am not sure if this is what Ben has realized. A way to
|
|
; salvage the situation would be to apply a filter so that each ?x only occurs
|
|
; once.
|
|
|
|
(display "[answered]\n")
|
|
|
|
(display "\nex-4.67 - avoid-loops\n")
|
|
|
|
; Each application of a query generates a message that contains the rule name,
|
|
; the variables, and the variable bindings. Before we apply message we check if
|
|
; the message is in the message list in which case we skip the evaluation.
|
|
; Otherwise, we add message to the list and continue the evaluation.
|
|
|
|
(display "[answered]\n")
|
|
|
|
(display "\nex-4.68 - reverse\n")
|
|
|
|
(eval-query '(rule (reverse () ())))
|
|
|
|
(eval-query
|
|
'(rule (reverse (?x . ?xs) ?rs)
|
|
(and (reverse ?xs ?ys)
|
|
(append-to-form ?ys (?x) ?rs))))
|
|
|
|
(eval-query '(reverse (1 2 3) ?x))
|
|
(newline)
|
|
; (eval-query '(reverse ?x (1 2 3))) ; infinite loop
|
|
|
|
(display "\nex-4.69 - greats\n")
|
|
|
|
(eval-query
|
|
'(rule (greats ?relation ?parent ?grandson)
|
|
(and (grandson ?parent ?grandson)
|
|
(same ?relation (grandson)))))
|
|
|
|
(eval-query
|
|
'(rule (greats ?relation ?parent ?grandson)
|
|
(and (nson ?parent ?son)
|
|
(greats ?son-relation ?son ?grandson)
|
|
(append-to-form (great) ?son-relation ?relation))))
|
|
|
|
(eval-query '(greats ?x Adam Irad))
|
|
(eval-query '(greats ?x Adam Jabal))
|
|
(eval-query '(greats (great grandson) Adam ?ggs))
|
|
(newline)
|
|
|