I am trying to use rules for an agriculture based system
So for example,
based on location --> list crops --> based on crop selected --> select seed
This is a forward chaining problem
I am only able to define the rules statically. Meaning, defining rules for every possible scenario
Is there a way to code, say if I select a location, I get a list of all crops, and when the user selects the crop , I get the list of seeds
How do I make sure, the rules are fired based on the output of the previous rule?
One approach you can take is to represent the questions as facts and then write general rules for processing those facts. First define some deftemplates to represent the questions, the branching from one question to another based on the user's response, and the user's response.
(deftemplate question
(slot name)
(slot text)
(slot display-answers (allowed-values yes no))
(slot last-question (default none)))
(deftemplate branch
(slot question)
(slot answer)
(slot next-question)
(multislot next-answers))
(deftemplate response
(slot question)
(slot answer))
Next, define your questions and the branches between them:
(deffacts questions
(question (name location)
(text "Country")
(display-answers no)
(last-question none))
(question (name crop-type)
(text "Crop Type")
(display-answers yes)
(last-question location))
(question (name seed)
(text "Seed")
(display-answers yes)
(last-question crop-type)))
(deffacts locations
(branch (question location)
(answer "United States")
(next-question crop-type)
(next-answers food fiber))
(branch (question location)
(answer "India")
(next-question crop-type)
(next-answers food fiber))
(branch (question location)
(answer "China")
(next-question crop-type)
(next-answers food fiber))
(branch (question location)
(answer "Brazil")
(next-question crop-type)
(next-answers food fiber))
(branch (question location)
(answer "Pakistan")
(next-question crop-type)
(next-answers fiber)))
(deffacts crop-types
(branch (question crop-type)
(answer fiber)
(next-question seed)
(next-answers cotton hemp flax))
(branch (question crop-type)
(answer food)
(next-question seed)
(next-answers corn wheat rice)))
Define some utility deffunctions for processing user responses. These will allow the program to ignore differences in alphabetic case in the user response.
(deffunction lenient-eq (?v1 ?v2)
(if (eq ?v1 ?v2)
then
(return TRUE))
(if (eq (lowcase (str-cat ?v1)) (lowcase (str-cat ?v2)))
then
(return TRUE))
(return FALSE))
(deffunction lenient-member$ (?value $?allowed-values)
(loop-for-count (?i (length$ ?allowed-values))
(bind ?v (nth$ ?i ?allowed-values))
(if (lenient-eq ?value ?v)
then
(return ?i)))
(return FALSE))
(deffunction ask-question (?question $?allowed-values)
(printout t ?question)
(bind ?answer (lowcase (readline)))
(while (not (lenient-member$ ?answer ?allowed-values)) do
(printout t ?question)
(bind ?answer (lowcase (readline))))
?answer)
Add some rules to handle the case where the list of valid answers are not displayed when the question is asked (because there may be a large number of them).
;;; Ask question without valid answers displayed or checked
(defrule ask-question-without-answers
;; There is a question that should be
;; displayed without valid answers.
(question (name ?question)
(text ?text)
(display-answers no)
(last-question ?last-question))
;; There is no prior question or
;; the prior question has a response.
(or (test (eq ?last-question none))
(response (question ?last-question)))
;; There is no response to the question.
(not (response (question ?question)))
=>
;; Ask the question
(printout t ?text ": ")
;; Assert a response with the question and answer.
(assert (response (question ?question)
(answer (lowcase (readline))))))
;;; Check for valid response to a question
(defrule bad-answer-to-question
;; There is a question that should be
;; displayed without valid answers.
(question (name ?question)
(display-answers no))
;; There is a response to the question.
?r <- (response (question ?question)
(answer ?answer))
;; The response to the question does
;; not branch to another question.
(not (branch (question ?question)
(answer ?a&:(lenient-eq ?a ?answer))))
=>
;; Print the list of valid answers for the question.
(printout t "Valid answers are:" crlf)
(do-for-all-facts ((?b branch))
(eq ?b:question ?question)
(printout t " " ?b:answer crlf))
;; Retract the response so that the
;; question will be asked again.
(retract ?r))
Finally, add a rule to handle the case where the question is asked with the list of valid answers displayed and is immediately check by the ask-question deffunction.
;;; Ask questions with valid answers displayed and checked
(defrule ask-question-with-answers
;; There is a question that should be
;; displayed including valid answers.
(question (name ?question)
(text ?text)
(display-answers yes)
(last-question ?last-question))
;; The preceding question has been answered.
(response (question ?last-question)
(answer ?last-answer))
;; There is a branch from the preceding question
;; and its answer to this question and the allowed
;; values for the answer.
(branch (answer ?a&:(lenient-eq ?a ?last-answer))
(next-question ?question)
(next-answers $?next-answers))
=>
;; Construct the question text including the possible answers.
(bind ?text (str-cat ?text " [" (implode$ ?next-answers) "]: "))
;; Ask the question.
(bind ?answer (ask-question ?text ?next-answers))
;; Assert a response fact with the question and answer.
(assert (response (question ?question) (answer ?answer))))
The output when this program is run:
CLIPS (6.31 6/12/19)
CLIPS> (load "seeds.clp")
%%%$$$!!!***
TRUE
CLIPS> (reset)
CLIPS> (run)
Country: Sweden
Valid answers are:
United States
India
China
Brazil
Pakistan
Country: China
Crop Type [food fiber]: food
Seed [corn wheat rice]: wheat
CLIPS>
To allow the first question to display the valid responses, redefine the questions deffacts to include an initial question that has already been answered:
(deffacts questions
(question (name location)
(text "Country")
(display-answers yes)
(last-question start-program))
(question (name crop-type)
(text "Crop Type")
(display-answers yes)
(last-question location))
(question (name seed)
(text "Seed")
(display-answers yes)
(last-question crop-type))
(response (question start-program)
(answer yes))
(branch (question start-program)
(answer yes)
(next-question location)
(next-answers "United States" "India" "China" "Brazil" "Pakistan")))
The output will then look like this:
CLIPS> (run)
Country ["United States" "India" "China" "Brazil" "Pakistan"]: Sweden
Country ["United States" "India" "China" "Brazil" "Pakistan"]: China
Crop Type [food fiber]: food
Seed [corn wheat rice]: wheat
CLIPS>
Related
I am having a template of
(deftemplate Product
(slot productId (type INTEGER))
(slot uom (default EA))
(slot quantity (type INTEGER))
(slot amount))
I'm using the code for
(defrule sum_of_quantity
(exists (Product (productId 1 | 2 | 3)(amount ?amount)))
=>
(bind ?totalQuantity 0)
(do-for-all-facts ((?p Product))
(or (eq ?p:productNumber 1)
(eq ?p:productNumber 2)
(eq ?p:productNumber 3))
(bind ?totalQuantity (+ ?totalQuantity ?p:quantity)))
(if (>= ?amount 5000) then
(printout t "TotalQuantity is " ?totalQuantity crlf)))
Here i am getting an error saying that:
Undefined variable amount referenced in RHS of defrule.
I have to check if the amount of each product is greater than 5000. How do we do that.
A simple fact pattern that can be matched by several different facts can cause multiple activations of a rule:
CLIPS>
(deftemplate product
(slot id)
(slot amount))
CLIPS>
(deffacts products
(product (id 1) (amount 1000))
(product (id 2) (amount 3000))
(product (id 3) (amount 6000)))
CLIPS>
(defrule print-amount
(product (id ?id) (amount ?amount))
=>
(printout t ?id ": " ?amount crlf))
CLIPS> (reset)
CLIPS> (agenda)
0 print-amount: f-3
0 print-amount: f-2
0 print-amount: f-1
For a total of 3 activations.
CLIPS> (run)
3: 6000
2: 3000
1: 1000
CLIPS>
When each activation is allowed to executed, the variable amount is retrieved from the product fact associated with activation. So there are three rule firings where amount is 6000, 3000, and 1000 respectively.
An exists conditional element is matched just once regardless of the number of time the fact patterns it contains are matched:
CLIPS>
(defrule exists
(exists (product (id ?id) (amount ?amount)))
=>)
CLIPS> (agenda)
0 exists: *
For a total of 1 activation.
CLIPS>
When the agenda is listed, an * is displayed indicating that the pattern is matched, but not by a specific fact. If you tried accessing the variable amount in the actions of the rule, you'd get an error. This is because the variable amount has no meaning outside of the pattern because it has no specific value. You'd get unpredictable behavior if one of the facts matching the fact pattern was arbitrarily chosen to provide the value for amount.
The simplest way to rewrite your rule is to move the amount check from the actions of the rule to the exists pattern:
(defrule sum_of_quantity
(exists (Product (productId 1 | 2 | 3)
(amount ?amount&:(>= ?amount 5000))))
=>
(bind ?totalQuantity 0)
(do-for-all-facts ((?p Product))
(or (eq ?p:productId 1)
(eq ?p:productId 2)
(eq ?p:productId 3))
(bind ?totalQuantity (+ ?totalQuantity ?p:quantity)))
(printout t "TotalQuantity is " ?totalQuantity crlf))
Your do-for-all-facts query was also referencing productNumber rather than productId.
I'm trying to code small program, ancient game Hamurabi in Scheme (guile to be exact). I want to learn about preferred approach to "design" of such program, extensively dealing with user input. E.g. using loops, mutable or immutable variables etc.
I have some working variants which I don't like well. I believe I miss some better approach. Below are details. Sorry for long explanations.
The game itself is simple "economics" simulation - we have 3 values, for population of our kingdom, land area and amount of grain (also serving as currency). Player rules for several years, choosing each year consecutively:
how many land to buy or sell for grain
then how many grain to use for feeding people
at last how many grain to use for sowing
So we have outer loop with iterations representing years. Inside we have three steps. First changes amounts of area and grain. Second
changes amounts of grain and population. Third is changing amount of grain (with respect to available land and people to tend fields). The fourth step (without user input) determines how many new crops we gathered and what was eaten by rats (i.e. increases amount of grain).
This can easily be done with using global variables and (set! ...) forms. However I wonder to find way to code this in more "functional style". It seems I then need to use several mutually recursive (tail-optimized) functions to represent steps. And pass changed values as parameters each time. Here is gist with this approach implemented with only step of buying/selling land. And it works like this:
You have 100 people, 700 acres of land and 9600 bushels of grain.
Land trades at 24 bushels of grain for acre
How many acres to buy? -100
You have 100 people, 600 acres of land and 12000 bushels of grain.
Land trades at 21 bushels of grain for acre
How many acres to buy? 200
It is not very convenient as there would be many small functions and most of them need all variables even though some are passed through. And besides the pop, area and grain we need some accumulators (e.g. total people died of starvation).
So I created two functions to maintain immutable key-value structure like
(list (cons 'pop 100) (cons 'area 1000) (cons 'grain 2800))
And use them as state passed to every function. prop-get fetches value by key from the state while prop-set returns modified copy (I suspect there is some similar structure already implemented in library).
(load "props.scm")
(define (one-year state)
(map display
(list "You have "
(prop-get state 'pop) " people, "
(prop-get state 'area) " acres of land and "
(prop-get state 'grain) " bushels of grain."))
(newline)
(let ((state-upd (buy-land state)))
(step-2 state-upd)))
(define (buy-land state)
(let ((price (+ (random 10) 17))
(area (prop-get state 'area))
(grain (prop-get state 'grain)))
(map display
(list "Land trades at " price " bushels of grain for acre"))
(newline)
(display "How many acres to buy? ")
(let ((b (read)))
(prop-set (prop-set state 'area (+ area b)) 'grain (- grain (* price b))))))
Please here is the complete code in another gist.
This is somewhat better but still the complete code is a bit verbose with all those prop-gets, lets and mutual recursion.
What other options could be here? I think there is "intermediate" solution between mutable global variables and immutables with tail recursion - like using named let for outer loop and some mutable structure to hold the state in a local variable. But I feel like I may be miss something more simple and elegant.
If you want to use a purely functionnal approach, you need to pass a state variable from one place to another.
We can use an association list to store elements, and since in Hammurabi the game finishes in 10 steps, we can easily use the state variable as a journal, a log of all events that happened in the game.
Association lists have the property that mappings can occur multiple times, but only the first match is returned.
So basically, if the state is ((population . 100) (population . 30)), then it means the current population is 100, and at the previous turn it was 30. We store all values in slots, which means we can perfom statistics on the resulting game as much as we want.
For exemple, the initial state is:
(define initial-state '((population . 100)
(acres . 1000)
(grain . 3000)
(year . 0)))
We can hide the specific implementation details behind auxiliary accessor functions:
(define (value state slot)
(cdr (assoc slot state)))
And also, we can use a useful syntax to add multiple elements at once in a state:
(define (extend0 state key/values)
(if (null? key/values)
state
(let ((key (car key/values))
(val (cadr key/values))
(tail (cddr key/values)))
(extend0 (acons key val state) tail))))
(define (extend state . key/values)
(extend0 state key/values))
So, for example, you can do:
(extend initial-state 'grain 1000 'population 200)
$1 = ((population . 200) (grain . 1000) (population . 100) (acres . 1000) (grain . 3000) (year . 0))
We can also define accessors for common slots:
(define (getter slot)
(lambda (state)
(value state slot)))
(define (setter slot)
(lambda (state value)
(acons slot value state)))
(define population (getter 'population))
(define set-population (setter 'population))
(define acres (getter 'acres))
(define set-acres (setter 'acres))
(define grain (getter 'grain))
(define set-grain (setter 'grain))
(define price (getter 'price))
(define set-price (setter 'price))
(define year (getter 'year))
(define set-year (setter 'year))
You could also shorten the above with a macro. The approach here consists in designing little auxiliary functions along the way, to ensure that the actual code we write is as expressive as we want it to be.
Also, test often and in isolation, which is easier to do when no internal state is involved.
Define also a smart object printer:
(define (echo items state)
(if (list? items)
(map (lambda (u)
(cond
((null? u) (newline))
((symbol? u) (display (value state u)))
((procedure? u) (display (u)))
(else (display u))))
items)
(begin (display items) (newline)))
state)
... and a generic prompt:
(define (prompt state message tester setter)
(echo message state)
(let ((value (read)))
(if (tester value)
(setter state value)
(prompt state message tester setter))))
Once all the vocabulary is in place, here is how you could write buy-land:
(define (buy-land state)
(let ((max-acres (floor/ (grain state) (price state))))
(if (zero? max-acres)
(echo "You cannot buy any acre." state)
(prompt state
`("Land trades at " price " bushels of grain for acre." ()
"You have " grain " bushel(s) of grain." ()
"How many acres to buy (0-" ,max-acres ")? ")
(lambda (v) (and (integer? v) (<= 0 v max-acres)))
(lambda (state buy)
(extend state
'buy buy
'acres (+ (acres state) buy)
'grain (- (grain state)
(* buy (price state)))))))))
You can split functions into little ones that do less things, but that compose better:
(define (random-events state)
(let ((starve (random 20)))
(extend state
'starve starve
'price (+ 17 (random 10))
'population (max 0 (- (population state) starve)))))
(define (game-step state)
(if (= (year state) 10)
(end-game state)
(let ((state (set-year state (+ 1 (year state)))))
(display-new-year-text state)
(let ((state (random-events state)))
(game-step (buy-land state))))))
(define hammurabi
(game-step initial-state))
I have this rule that fires thousands of other same rule:
(defrule calculate-temperature
?zone <- (object (is-a ZONE) (id ?id-zone) (dew-temperature ?dew-temperature) (delta-R ?delta-R))
(process-action (is cooling))
=>
(bind ?supply-temperature (+ ?delta-R ?dew-temperature))
(modify-instance ?zone (supply-temperature ?supply-temperature))
(printout ?*debug-print* "supply-temperature:", ?supply-temperature crlf))
What I want to do is to modify my zone's supply-temperature when I can calculate it, i.e. when inside zone are defined delta-R and dew-temperature.
But the modification of the object keeps on firing in a recursice neverendless cycle.
What are best practices to avoid these annoying loops, please?
Thank you
Nicola
By itself this rule doesn't loop:
CLIPS> (clear)
CLIPS>
(defclass ZONE
(is-a USER)
(slot id)
(slot dew-temperature)
(slot supply-temperature)
(slot delta-R))
CLIPS>
(definstances start-instances
(z1 of ZONE (id 1) (dew-temperature 100) (delta-R 10)))
CLIPS>
(deftemplate process-action
(slot is))
CLIPS>
(deffacts start-facts
(process-action (is cooling)))
CLIPS> (defglobal ?*debug-print* = nil)
CLIPS>
(defrule calculate-temperature
?zone <- (object (is-a ZONE)
(id ?id-zone)
(dew-temperature ?dew-temperature)
(delta-R ?delta-R))
(process-action (is cooling))
=>
(bind ?supply-temperature (+ ?delta-R ?dew-temperature))
(modify-instance ?zone (supply-temperature ?supply-temperature))
(printout ?*debug-print* "supply-temperature:", ?supply-temperature crlf))
CLIPS> (watch slots)
CLIPS> (reset)
::= local slot id in instance z1 <- 1
::= local slot dew-temperature in instance z1 <- 100
::= local slot delta-R in instance z1 <- 10
::= local slot supply-temperature in instance z1 <- nil
CLIPS> (run)
::= local slot supply-temperature in instance z1 <- 110
CLIPS>
So it's the interactions between your rules that are causing the loop.
There are three general techniques to prevent rule looping. First, you can remove one of the facts/instances matching the conditions of the rule. For example, the process-action fact:
(defrule calculate-temperature
?zone <- (object (is-a ZONE)
(id ?id-zone)
(dew-temperature ?dew-temperature)
(delta-R ?delta-R))
?p <- (process-action (is cooling))
=>
(retract ?p)
(bind ?supply-temperature (+ ?delta-R ?dew-temperature))
(modify-instance ?zone (supply-temperature ?supply-temperature))
(printout ?*debug-print* "supply-temperature:", ?supply-temperature crlf))
Second, you can modify a fact/instance slot value to prevent a pattern from matching. For example, delta-R:
(defrule calculate-temperature
?zone <- (object (is-a ZONE)
(id ?id-zone)
(dew-temperature ?dew-temperature)
(delta-R ?delta-R&~0))
(process-action (is cooling))
=>
(bind ?supply-temperature (+ ?delta-R ?dew-temperature))
(modify-instance ?zone (supply-temperature ?supply-temperature) (delta-R 0))
(printout ?*debug-print* "supply-temperature:", ?supply-temperature crlf))
Third (and this is only applicable for object pattern matching), rules are only triggered by changes to slots that are explicitly matched in the conditions of the rules. So if you want changes to delta-R to trigger the rule, but not changes to dew-temperature, you'd write the rule like this:
(defrule calculate-temperature
?zone <- (object (is-a ZONE)
(id ?id-zone)
(delta-R ?delta-R))
(process-action (is cooling))
=>
(bind ?supply-temperature (+ ?delta-R (send ?zone get-dew-temperature)))
(modify-instance ?zone (supply-temperature ?supply-temperature))
(printout ?*debug-print* "supply-temperature:", ?supply-temperature crlf))
I would greatly appreciate some assistance with my CLIPS project.
Okay so I'm attempting to create a dog breed adviser. The deftemplate looks like this:
(deftemplate breed
(multislot name)
(slot size)
(slot type-owner)
(slot Living_Space)
(slot children)
(slot grooming)
(slot exercise)
(slot noisiness)
(slot trainability)
(slot aggression)
(slot playfulness)
(slot excitability)
(slot score))
A deffacts looks like this:
(deffacts dog-breeds
(breed (name Great_Dane)
(size 5)
(type-owner No)
(Living_Space 5)
(children 5)
(grooming 1)
(exercise 4)
(noisiness 2)
(trainability 1)
(aggression 2)
(playfulness 2)
(excitability 3)
(score 0))
So I write two types of defrules: one retracts facts that do not meet the (user specified) criteria and the other type increments the "score" value every time the fact meets the criteria. Only a few rules retract, so it's important for me to get the increment rules working. The user input and criteria for each slot can be from 1 to 5.
My question is: how do I change the following code without going into an infinite loop? At the end I want to seek out the fact with the maximum score and display it.
(defrule children
(input 1)
?children <- (breed (name ?)(size ?)(type-owner ?)(Living_Space ?) (children 1|2)(grooming ?)(exercise ?)(noisiness ?)
(trainability ?)(aggression ?)(playfulness ?)(excitability ?)(score ?score)
=>
(bind ?sc (+ ?score 1))
(modify ?children (score ?sc))
If the sole purpose of the (input 1) fact is to increment the score and is no longer needed after the score is incremented, just retract that fact.
(defrule children
?f <- (input 1)
?children <- (breed (children 1|2) (score ?score))
=>
(retract ?f)
(bind ?sc (+ ?score 1))
(modify ?children (score ?sc)))
Note that I've removed all of the slots from the pattern containing the ? wildcard as these are unnecessary.
If the (input 1) fact is needed by other rules, you can create an intermediate fact that can be retracted.
(defrule create-intermediate
(input 1)
=>
(assert (increment)))
(defrule children
?f <- (increment)
?children <- (breed (children 1|2) (score ?score))
=>
(retract ?f)
(bind ?sc (+ ?score 1))
(modify ?children (score ?sc)))
You could also track what you've scored within the fact. Add a (multislot scored) to your breed deftemplate and then you can do this:
(defrule children
(input 1)
?children <- (breed (children 1|2) (score ?score) (scored $?scored))
(test (not (member$ children ?scored)))
=>
(bind ?sc (+ ?score 1))
(modify ?children (score ?sc) (scored children ?scored)))
Finally, object patterns do not retrigger when slots are changed that are not present in the pattern. So if you used defclasses instead of deftemplates, you could do this:
(defrule children
(input 1)
?children <- (object (is-a BREED) (children 1|2))
=>
(bind ?sc (+ (send ?children get-score) 1))
(send ?children put-score ?sc))
I have a single-slot deftemplate definition with a constraint on the allowed symbols. If I directly assert a fact from the top level, the constraints work as expected (i.e. I can only use one of the allowed symbols). However, if I do it from within a deffunction, the constraint is effectively non-existent (see code output below). How do I enforce the constraint from within my function?
CLIPS> (clear)
CLIPS> (deftemplate test-template (slot myslot (type SYMBOL) (allowed-symbols A B C)))
CLIPS> (deffunction test-function (?s) (assert (test-template (myslot ?s))))
CLIPS> (assert (test-template (myslot X)))
[CSTRNCHK1] A literal slot value found in the assert command
does not match the allowed values for slot myslot.
CLIPS> (test-function X)
<Fact-1>
CLIPS> (facts)
f-0 (initial-fact)
f-1 (test-template (myslot X))
For a total of 2 facts.
CLIPS>
Static constraint checking (which occurs during parsing) is enabled by default. Dynamic constraint checking (which occurs during code execution) is not (see section 11 of the Basic Programming Guide). If you enable it you'll get a constraint violation in your example (although you need to assert a fact with a slot value other than X--duplicate facts are not allowed and during execution this check will occur before the constraint check).
CLIPS> (clear)
CLIPS> (deftemplate test-template (slot myslot (type SYMBOL) (allowed-symbols A B C)))
CLIPS> (deffunction test-function (?s) (assert (test-template (myslot ?s))))
CLIPS> (assert (test-template (myslot X)))
[CSTRNCHK1] A literal slot value found in the assert command
does not match the allowed values for slot myslot.
CLIPS> (test-function Y)
<Fact-1>
CLIPS> (set-dynamic-constraint-checking TRUE)
FALSE
CLIPS> (test-function Z)
[CSTRNCHK1] Slot value Z found in fact f-2
does not match the allowed values for slot myslot.
[PRCCODE4] Execution halted during the actions of deffunction test-function.
<Fact-2>
CLIPS>