home *** CD-ROM | disk | FTP | other *** search
Text File | 1998-01-29 | 35.6 KB | 1,096 lines
; CLIPS assignment Justin Fletcher ; ================ <Gerph@innocent.com> ; ; Obviously this assignment is not written as well as it might, and as much ; of the database was written before I had learnt about many of the features ; of clips it has lead to some curious representations of the data. The major ; example of this is the 'buy' routines in the 'do' section of stage which ; could be massively simplified by making a generic format. ; ; Acknowledgement and disclaimer ; ------------------------------ ; Also, whilst I've based the ideal of how the questions work on those ; examples supplied with clips, the code is all my own. These provided ; a lot of insights into techiniques I could used. The particular examples ; which I have used as the basis for the principles (although I had the ; idea for how I /wanted/ to do it, honest) are the Animals and Wine ; examples. ;************************************************************************** ;*** The templates *** ;************************************************************************** ; A template for the question we'll need for storing the question ; the questions consist of an id (is) which is used to reference each of them ; with the initial question being triggered being 'question-1'. ; The question itself is the 'ask', and the outcome is in 'true' or 'false', ; both of which consist of a condition which will be set followed by a ; question id which should be asked later. Regardless of the choice, the ; 'next' field will be followed to trigger the next question ; These are parsed by stage 2 (deftemplate question (slot is (default none) ) ; our question id (multislot true (default none none) ) ; (what to set) (question to ask) (multislot false (default none none) ) ; ditto, but if they answer no (slot ask (default "No question specified!") ) ; the question to ask (slot next (default none) ) ; the next id to go to ) ; A requirements template - used to do boring if-then's without all that ; tedious mucking about in defrule's ; The case section must have all its entries satisfied before the require ; section will be executed. The require section is quite complex, but mostly ; consists of 'buy <something>', 'set <variable>' or 'inc <entry>' which ; try to buy an item, set an condition flag, or increment a variable ; respectively. ; These are parsed by stage 3 (deftemplate requires (multislot case (default none)) ; we can say we /always/ need something (multislot require (default none)) ; we may want to add more things ) ;************************************************************************** ;*** The database *** ;************************************************************************** ; How much is VAT atm (easier than fiddling with lots of variables) ? (deffacts vat (vat 1.175) ) ; Computer itself ; computer name price mem vram monitor HD extras... (deffacts computer (computer 699 rpc700 4 0 14 210) (computer 899 rpc700 4 1 14 540) (computer 1099 rpc700 8 2 14 540) (computer 1399 rpc700 8 2 17 540) (computer 499 a7000 4 0 14 0) ) ; Additional internals ; memory price size (deffacts memory (memory 170 32) (memory 89 16) (memory 49 8) (memory 35 4) ) ; Strong ARM processor and PC Card (price with computer) (deffacts processor (strongarm 100) (pccard 275) ) ; cd rom drives ; price speed (deffacts cdroms (cdrom 125 4) (cdrom 205 6) ) ; interfaces (deffacts interfaces (ethernet 74) (midi 54) (scsi 165) ) ; harddiscs ; price type size (deffacts harddiscs (hd 345 scsi 2000) (hd 145 ide 1200) (hd 190 scsi 1000) (hd 120 ide 850) (hd 108 ide 540) (hd 80 ide 300) (hd 60 ide 210) ; if you need a bigger disc then you probably know what you want anyhow... ) ; other hardware (deffacts misc-hardware (scanner 128) (scanner_digitiser 188) (speakers 34) ) ; modems ; price speed (deffacts modems (modem 96 14.4) (modem 153 28.8) ) ; printer price type (deffacts printers (printer 138 bw) (printer 149 colour) (printer 10 refils) ) ; applications ; app type name price (requires) (deffacts software (app dtp "Ovation" 163) (app dtp "Style" 75) (app music "Sibelius 7" 829) (app music "Sibelius 6" 154) (app accounts "Home accounts" 27) (app accounts "Prophet business accounts" 143) (app spreadsheet "Eureka" 91) (app database "Datapower" 98) (app comms "ArcFax" 28) (app comms "ANT Suite II" 98) (app design "HTMLEdit v2" 38) (app design "Web designers toolkit" 56) (app util "SparkFS" 20) (app util "MacFS" 85) (app util "MovieFS" 20) (app prog "JFShared programming library" 0) (app prog "Zap text editor" 0) (app prog "PRMs" 105) (app prog "PRMs supplement" 35) (app prog "C development" 89) (app design "Artworks" 98) (app design "Photodesk 2" 228) (app network "Access +" 25) (app school-primary "10/10 disc sets" 40) (app school-second "Sciences teach-yourself pack" 40) ) ; PC Software :-) (deffacts pc-software-yuck-yuck-yuck (app encarta "Encarta" 112) (app prog "Visual C++" 85) ) ; Questions ; question number "question" (assert if true) (assert if false (deffacts toplevel-questions (question (is question-1) (ask "Are you wanting to use the computer for the home ?") (true home home-1) (false work work-1) (next question-2) ) (question (is question-2) (ask "Do you wish to do design work on the computer ?") (true design design-1) (next question-3) ) (question (is question-3) (ask "Will you be using the computer for programming ?") (true programming program-1) (next question-4) ) (question (is question-4) (ask "Are you wanting to do publishing work ?") (true publishing none) (next question-5) ) (question (is question-5) (ask "Lots of the larger software recently has been provided on CD ROM ranging from games to large publications. Do you think you would need a CD ROM ?") (true need-cdrom none) (next question-6) ) (question (is question-6) (ask "Will you want to use the internet ?") (true internet internet-1) (next question-7) ) (question (is question-7) (ask "Are you going to be doing music scoring ?") (true music none) ) ) (deffacts internet-questions (question (is internet-1) (ask "Will you be wanting to view 'foreign' files (Mac/Zip's) ?") (true archivers none) (next internet-2) ) (question (is internet-2) (ask "Will you be wanting to view movie files on the net ?") (true movies none) ) ) ; work questions (deffacts work-questions (question (is work-1) (ask "Will you be using the computer for business acounts ?") (true accounts none) (next work-2) ) (question (is work-2) (ask "Will you be wanting to use a database (keep records of people or stocks) ?") (true database none) (next work-3) ) (question (is work-3) (ask "Will you be wanting to produce a published work ?") (true dtp dtp-1) (next work-4) ) (question (is work-4) (ask "Are you wanting to send Faxes ?") (true fax none) (next work-5) ) (question (is work-5) (ask "Will the computer want to be networked ?") (true network none) ) ) ; dtp style questions (deffacts dtp-questions (question (is dtp-1) (ask "Does the published work need to be colour ?") (true printer-colour none) (false printer-bw none) (next scanner) ) ) ; home (deffacts home-questions (question (is home-1) (ask "Will you be using the computer for home acounting ?") (true accounts none) (next home-2) ) (question (is home-2) (ask "Will the computer be used for educational things ?") (true school school-1) ) ) ; education (deffacts education-questions (question (is school-1) (ask "Will it be used for primary school work ?") (true school-primary none) (next school-2) ) (question (is school-2) (ask "Will it be used for KS 2 and 3 ?") (true school-secondary secondary-1) (next school-3) ) (question (is school-3) (ask "Will it be used for sixth form work ?") (true school-sixth sixth-1) ) (question (is secondary-1) (ask "Will it be used for presentation work ?") (true dtp dtp-1) (next secondary-2) ) (question (is secondary-2) (ask "Will it be used for information gathering (encyclodepia) ?") (true encarta none) ) ) ; design work (deffacts design-work-questions (question (is design-1) (ask "Will the design work be graphical (as opposed to web based) ?") (true graphics design-2) (false webeditstuff none) ) (question (is design-2) (ask "Will you be wanting to print out your design work ?") (true none dtp-1) (next scanner) ) (question (is scanner) (ask "Will you be wanting to scan pictures in ?") (true scanner none) ) ; bit of a cheat this one, bit who cares ) ; programming work (deffacts programming-work-questions (question (is program-1) (ask "Will you be wanting to program in BASIC ?") (true program-basic program-arc-1) (next program-2) ) (question (is program-2) (ask "Will you be wanting to program in C ?") (true program-c none) (next program-3) ) (question (is program-3) (ask "Will you be wanting to program in Visual C++ ?") (true program-vcc none) ) (question (is program-arc-1) (ask "Would you like to do some desktop programming then ?") (true program-jfs none) ) ) ; the dependancy type thingies (deffacts what_needs_what (requires (case) (require inc computer 0 inc memory 4 inc vram 0 inc harddisc 0) ) (requires (case music) (require buy midi) ) (requires (case music work) (require buy app music "Sibelius 7" inc memory 8 inc computer 1) ) (requires (case music home) (require buy app music "Sibelius 6" inc memory 4 inc computer 1) ) (requires (case accounts home) (require buy app accounts "Home accounts") ) (requires (case database) (require buy app database "Datapower") ) (requires (case accounts work) (require buy app accounts "Prophet business accounts") ) (requires (case home) (require inc computer 0) ) (requires (case work) (require inc computer 1) ) (requires (case design webeditstuff) (require set internet) ) (requires (case design webeditstuff home) (require buy app design "HTMLEdit v2") ) (requires (case design webeditstuff work) (require buy app design "Web designers toolkit") ) (requires (case internet) (require set need-modem buy app comms "ANT Suite II" inc harddisc 256 inc computer 1) ) (requires (case fax) (require set need-modem buy app comms "ArcFax" inc harddisc 128) ) (requires (case printer-bw) (require buy printer bw) ) (requires (case printer-colour) (require buy printer colour) ) (requires (case scanner) (require buy scanner) ) (requires (case need-modem work) (require buy modem 28.8) ) (requires (case need-modem home) (require buy modem 14.4) ) (requires (case archives) (require buy app util "SparkFS" buy app util "MacFS") ) (requires (case movies) (require buy app util "MovieFS" buy speakers) ) (requires (case programming) (require buy app prog "Zap text editor" inc harddisc 80) ) (requires (case program-c) (require buy app prog "C development" set need-prms inc memory 4 inc harddisc 64) ) (requires (case program-jfs) (require buy app prog "JFShared programming library" set need-prms) ) (requires (case dtp work) (require buy app dtp "Ovation") ) (requires (case dtp home) (require buy app dtp "Style") ) (requires (case program-vcc) (require buy app prog "Visual C++" set need-pccard set need-cdrom inc harddisc 512) ) (requires (case need-prms) (require buy app prog "PRMs" buy app prog "PRMs supplement") ) (requires (case design work) (require buy app design "Photodesk 2" set strongarm inc memory 8 inc vram 2 inc harddisc 256 set need-cdrom) ) (requires (case design home) (require buy app design "Artworks" inc memory 4 inc vram 1) ) (requires (case encarta) (require buy app encarta "Encarta" set need-pccard inc harddisc 512 set need-cdrom) ) (requires (case strongarm) (require buy strongarm inc computer 1) ); can't fit SA to a7k (requires (case need-pccard) (require buy pccard inc memory 4 inc computer 1) ) (requires (case need-cdrom work) (require buy cdrom 6) ) (requires (case need-cdrom home) (require buy cdrom 4) ) (requires (case network) (require buy ethernet buy app network "Access +") ) ) ;************************************************************************** ;*** The Rules - Round 1 : How much have they got spend? *** ;************************************************************************** ; start by introducing the program (defrule initial_rule ?fact <- (initial-fact) => (printout t " ======================" crlf " Computer picker thingy" crlf " ======================" crlf crlf "Please answer the following questions to find the " "computer you could have..." crlf crlf) (retract ?fact) (assert (stage 1) ) (assert (next question-1) ) ) ; find out how much they want to spend (defrule how_much_have_they ?fact <- (stage 1) (vat ?vat) => (printout t "How much money do you have to spend ? ") (assert (money (/ (read) ?vat) ) ) ; so that we don't have to fiddle (retract ?fact) ; too much later on... (assert (stage 2)) ) ;************************************************************************** ;*** The Rules - Round 2 : What do they want ? *** ;************************************************************************** ; ask the main questions (defrule scan_questions (stage 2) ?f-next <- (next ?id) ?f-q <- (question (is ?id) (ask ?ask) (true $?true) (false $?false) (next ?next) ) => (retract ?f-next) (retract ?f-q) (assert (q-next ?next) ) (assert (q-asknow ?ask) ) (assert (q-iftrue $?true) ) (assert (q-iffalse $?false) ) (assert (askquestion) ) ; (printout t "Asking " ?id " : " ?ask crlf) ) ; asks the question specified in q-asknow (defrule ask_questions ?f-ask <- (askquestion) (q-asknow ?ask) => (retract ?f-ask) (printout t ?ask) (assert (q-answer (read)) ) ) ; two little aliases, to stop my hands aching :-) (defrule alias_reply_y ?f-reply <- (q-answer y) => (retract ?f-reply) (assert (q-answer yes) ) ) (defrule alias_reply_n ?f-reply <- (q-answer n) => (retract ?f-reply) (assert (q-answer no) ) ) ; checks that the reply was valid (defrule check_reply_yes ?f-reply <- (q-answer yes) ?f-next <- (q-next ?next) ?f-true <- (q-iftrue ?value ?question) ?f-false <- (q-iffalse $?) ?f-q <- (q-asknow ?) => ; (printout t "Answer Yes..." crlf) (assert (toask ?question) ) (assert (set ?value) ) (assert (next ?next) ) (retract ?f-reply) (retract ?f-next) (retract ?f-false) (retract ?f-true) (retract ?f-q) ) ; checks that the reply was valid (defrule check_reply_no ?f-reply <- (q-answer no) ?f-next <- (q-next ?next) ?f-true <- (q-iftrue $?) ?f-false <- (q-iffalse ?value ?question) ?f-q <- (q-asknow ?) => ; (printout t "Answer No..." crlf) (assert (toask ?question) ) (assert (set ?value) ) (assert (next ?next) ) (retract ?f-reply) (retract ?f-next) (retract ?f-false) (retract ?f-true) (retract ?f-q) ) ; catch any other reply (defrule check_reply_unknown ?f-reply <- (q-answer ?invalid) => (printout t "I'm a bear of very little brain and I don't understand " ?invalid "." crlf "Please can you answer 'yes' or 'no'..." crlf) (assert (askquestion) ) (retract ?f-reply) ) ; Round 2b - Ask them questions based on their answers ; now to assert any questions which are required due to earlier questions ; (ie the 'toask' sections) ; this will cause the additional questions to always be asked after ; the 'main' questions (defrule additional_questions ?f-next <- (toask ?next) => ; (printout t "Trying to ask " ?next crlf) (assert (next ?next) ) (retract ?f-next) ) ;************************************************************************** ;*** The Rules - Round 3 : What do they need ? *** ;************************************************************************** ; if we get to this point we know we've passed the stage at which questions ; can be asked so we have to move on to stage 3 - what do we actually need ? (defrule move_to_stage_3 ?f-stage <- (stage 2) => (printout t crlf "Please wait..." crlf) (printout t " Calculating requirements..." crlf) ; (printout t "Moving to stage 3, what do we need ?" crlf) (retract ?f-stage) (assert (stage 3) ) ) ; we've completely fulfilled a requirement - so we need to do it's require ; section (defrule dependancies_statisified (stage 3) ?f-item <- (requires (case) (require $?sets) ) => ; (printout t "Requirement fulfilled, firing " $?sets crlf) (assert (do $?sets)) (retract ?f-item) ) ; we've fulfilled the first of a set of requirements - remove it from ; the list so we can check the other ones (defrule dependancies_partial (stage 3) ?f-item <- (requires (case ?first $?also) (require $?sets) ) (set ?first) => ; (printout t "Shrinking " ?first " " $?also " for " $?sets crlf) (modify ?f-item (case $?also) ) ) ; obey the 'do' clause of the requirements (multiple stages) ; buy the thing (defrule obey_do_buy_app ?f-match <- (do buy app ?section ?product $?rest) (app ?section ?product ?price) => (retract ?f-match) (assert (do $?rest) ) ; (printout t "Trying to buy " ?product crlf) (assert (please-buy ?price ?product app ?section ?product ?price) ) ) ; buy a pccard (defrule obey_do_buy_pccard ?f-match <- (do buy pccard $?rest) (pccard ?price) => (retract ?f-match) (assert (do $?rest) ) ; (printout t "Trying to buy PC Card" crlf) (assert (please-buy ?price "PC Card" pccard ?price) ) ) ; buy a Modem (defrule obey_do_buy_modem ?f-match <- (do buy modem ?speed $?rest) (modem ?price ?speed) => (retract ?f-match) (assert (do $?rest) ) ; (printout t "Trying to buy Modem (" ?speed ")" crlf) (assert (please-buy ?price (str-cat "Modem (" ?speed " kbaud)") modem ?price ?speed) ) ) ; buy a CDRom drive (defrule obey_do_buy_cdrom ?f-match <- (do buy cdrom ?speed $?rest) (cdrom ?price ?speed) => (retract ?f-match) (assert (do $?rest) ) ; (printout t "Trying to buy CD ROM (x" ?speed ")" crlf) (assert (please-buy ?price (str-cat "CD ROM (x" ?speed ")") cdrom ?price ?speed) ) ) ; buy a strongarm (defrule obey_do_buy_strongarm ?f-match <- (do buy strongarm $?rest) (strongarm ?price) => (retract ?f-match) (assert (do $?rest) ) ; (printout t "Trying to buy StrongARM processor" crlf) (assert (please-buy ?price StrongARM strongarm ?price) ) ) ; buy a speakers (defrule obey_do_buy_speakers ?f-match <- (do buy speakers $?rest) (speakers ?price) => (retract ?f-match) (assert (do $?rest) ) ; (printout t "Trying to buy external speakers" crlf) (assert (please-buy ?price "External speakers" speakers ?price) ) ) ; buy a MIDI interface (defrule obey_do_buy_midi ?f-match <- (do buy midi $?rest) (midi ?price) => (retract ?f-match) (assert (do $?rest) ) ; (printout t "Trying to buy MIDI interface" crlf) (assert (please-buy ?price "MIDI interface" midi ?price) ) ) ; buy a scanner (defrule obey_do_buy_scanner ?f-match <- (do buy scanner $?rest) (scanner ?price) => (retract ?f-match) (assert (do $?rest) ) ; (printout t "Trying to buy Scanner" crlf) (assert (please-buy ?price Scanner scanner ?price) ) ) ; buy a printer (defrule obey_do_buy_printer ?f-match <- (do buy printer ?type $?rest) (printer ?price ?type) => (retract ?f-match) (assert (do $?rest) ) ; (printout t "Trying to buy Printer (" ?type ")" crlf) (assert (please-buy ?price (str-cat "Printer ("?type")") printer ?price ?type) ) ) ; increment a variable (existing) (defrule obey_do_inc_var_exists ?f-match <- (do inc ?var ?by $?rest) ?f-val <- (val ?var ?value) => (retract ?f-match) (assert (do $?rest) ) (retract ?f-val) (assert (val ?var (+ ?value ?by)) ) ) ; increment a variable (non-existant) (defrule obey_do_inc_var_notexists ?f-match <- (do inc ?var ?value $?rest) => (retract ?f-match) (assert (do $?rest) ) (assert (val ?var ?value)) ) ; we've aleady got the variable set ! (defrule obey_do_set_already_set ?f-match <- (do set ?var $?rest) (set ?var) => (retract ?f-match) (assert (do $?rest) ) ; (printout t "Set ignored (already done) " ?var crlf) ) ; we've aleady got the variable set ! (defrule obey_do_set ?f-match <- (do set ?var $?rest) => (retract ?f-match) (assert (do $?rest) ) (assert (set ?var)) ; (printout t "Set " ?var crlf) ) ; last item in a list has been obeyed (defrule obey_do_item_done ?f-match <- (do) => (retract ?f-match) ) ;************************************************************************** ;*** The Rules - Round 4 : What computer do they need ? *** ;************************************************************************** (defrule move_to_stage_4 ?f-stage <- (stage 3) => (printout t " Picking a computer..." crlf) ; (printout t "Move to stage 4, buy things" crlf) (retract ?f-stage) (assert (stage 4) ) ; (facts) ; (agenda) ) ; you can't have computers >1 (defrule check_silly_computer_numbers (stage 4) ?f-comp <- (val computer ?num) (test (< 1 ?num)) => (retract ?f-comp) (assert (val computer 1)) ; (printout t "Downgrading to a sensible computer number" crlf) ) ; you can't have vram >2 (defrule check_silly_vram (stage 4) ?f-vram <- (val vram ?num) (test (< 2 ?num)) => (retract ?f-vram) (assert (val vram 2)) ; (printout t "Downgrading to a sensible vram from " ?num crlf) ) ; ignore small HD's if we've already got one (defrule ignore_small_hd_sizes (stage 4) ?f-hd <- (val harddisc ?need-hd) (comp harddisc ?size) (test (> ?size 0) ) (test (< ?need-hd 210) ) => (retract ?f-hd) ; (printout t "Ignoring hard disc (" ?need-hd "Mb)" crlf) ) ; Buy some HD space if we need it (defrule buy_more_hd (stage 4) ?f-hd <- (val harddisc ?need-hd) (hd ?price ?type ?size) ?f-comp <- (comp harddisc ?oldsize) (test (<= ?size ?need-hd) ) => (retract ?f-hd) (assert (val harddisc (- ?need-hd ?size)) ) (retract ?f-comp) (assert (comp harddisc (+ ?oldsize ?size)) ) (assert (please-buy ?price (str-cat ?size "Mb extra HD") hd ?price ?type ?size) ) ; (printout t "Buying some more HD space (" ?size "Mb)" crlf) ) ; Buy the lowest of the low hd's (cheating really) (defrule buy_diddly_hd (stage 4) ?f-hd <- (val harddisc ?need-hd) ?f-comp <- (comp harddisc 0) (hd ?price ?type 210) (test (< ?need-hd 210) ) => (retract ?f-hd) (assert (val harddisc (- ?need-hd 210)) ) (retract ?f-comp) (assert (comp harddisc 210) ) (assert (please-buy ?price "210 Mb extra HD" hd ?price ?type 210) ) ; (printout t "Buying a small HD (210Mb)" crlf) ) ; if we need a rpc, get one (from the list) (defrule we_need_a_rpc (stage 4) ?f-comp <- (val computer 1) ?f-vram <- (val vram ?vram) ?f-mem <- (val memory ?need-mem) (computer ?price rpc700 ?memory ?vram ?monitor ?hd) (test (>= ?memory ?need-mem)) ?f-hd <- (val harddisc ?need-hd) => (retract ?f-mem) (assert (val memory (- ?need-mem ?memory) ) ) (retract ?f-hd) (assert (val harddisc (- ?need-hd ?hd) ) ) (assert (please-buy ?price (str-cat "RPC700 " ?memory "Mb, " ?hd "HD, " ?vram "VRAM") computer ?price rcp700 ?memory ?vram ?monitor ?hd) ) (assert (comp memory ?memory) ) (assert (comp harddisc ?hd) ) (assert (comp vram ?vram) ) (retract ?f-comp) (retract ?f-vram) (assert (gotcomputer) ) ; (printout t "Bought that gorgeous RPC" crlf) ) (defrule we_need_a_a7000 (stage 4) ?f-comp <- (val computer 0) (computer ?price a7000 ?memory ?vram ?monitor ?hd) ?f-vram <- (val vram ?vram) ?f-mem <- (val memory ?need-mem) ?f-hd <- (val harddisc ?need-hd) (test (>= ?memory ?need-mem)) => (retract ?f-mem) (assert (val memory (- ?need-mem ?memory) ) ) (retract ?f-hd) (assert (val harddisc (- ?need-hd ?hd) ) ) (assert (please-buy ?price (str-cat "A7000 " ?memory "Mb, " ?hd "HD, " ?vram "VRAM") computer ?price a7000 ?memory ?vram ?monitor ?hd) ) (assert (comp memory ?memory) ) (assert (comp harddisc ?hd) ) (assert (comp vram ?vram) ) (retract ?f-comp) (retract ?f-vram) ; (printout t "Bought that nice a7000" crlf) (assert (gotcomputer) ) ) ; buy some more memory (defrule we_need_more_memory (stage 4) ?f-need <- (val memory ?need-mem) ?f-buy <- (memory ?price ?amount) ; (test (<= ?amount ?need-mem)) => (retract ?f-need) (assert (val memory (- ?need-mem ?amount)) ) (assert (please-buy ?price (str-cat ?amount "Mb extra memory")) ) ) ;************************************************************************** ;*** The Rules - Round 5 : Can we buy it ? *** ;************************************************************************** ; The please-buy <price> <description> <data...> are converted to ; got <data> and bought <price> <description> whilst the money is reduced ; if it is not possible to buy the item then the item ; broke <price> <description> is created instead of the (defrule move_to_stage_5 ?f-temp <- (gotcomputer) ?f-stage <- (stage 4) => (printout t " Calculating prices..." crlf) ; (printout t "Move to stage 5, buy things" crlf) (retract ?f-stage) (assert (stage 5) ) (retract ?f-temp) ) ; this rule shouldn't be called because of the strategy employed, but ; it's better to have it just in case :-) (defrule please_buy_this_for_me_no_youve_got_one_already (stage 5) ?f-match <- (please-buy ?price ?product $?rest) (got $?rest) => ; (printout t "Ignoring " ?product " - already got it") (retract ?f-match) ) ; /yeah/ we can buy it ! (defrule please_buy_this_for_me_ok (stage 5) ?f-match <- (please-buy ?price ?product $?rest) ?f-oldmoney <- (money ?money) (test (> ?money ?price) ) => (retract ?f-oldmoney) (assert (money (- ?money ?price) ) ) (assert (got $?rest) ) (assert (bought ?price ?product) ) (retract ?f-match) ; (printout t "Bought " ?product crlf) ) ; can't buy 'cos not enough money, ok so the names a bit long, but I got ; carried away, and it looks good when the file loads :-) (defrule please_buy_this_for_me_no_way_laddy_youre_skint (stage 5) ?f-match <- (please-buy ?price ?product $?rest) ?f-oldmoney <- (money ?money) (test (< ?money ?price) ) => (assert (broke ?price ?product) ) (assert (got $?rest) ) ; we need to pretend that we have got this now (retract ?f-match) ; (printout t "Couldn't buy " ?product crlf) ) ;************************************************************************** ;*** The Rules - Round 6 : Tell them what they have got *** ;************************************************************************** ; display those things we've bought (defrule move_to_stage_6 ?f-stage <- (stage 5) => (printout t crlf "Processing complete..." crlf crlf) ; (printout t "Move to stage 6, display what we've bought" crlf) (format t "%-60s %6s %9s%n" Item "ex VAT" "inc VAT") (printout t "------------------------------------------------------------------------------" crlf) (assert (stage 6)) (assert (display_basket)) (assert (exc-total 0)) (retract ?f-stage) ) (defrule display_basket_add_vat (stage 6) (display_basket) ?f-bought <- (bought ?cost ?name) (vat ?vat) ?f-total <- (exc-total ?todate) => (retract ?f-bought) (format t "%-60s %6d %9d%n" ?name ?cost (* ?cost ?vat)) (retract ?f-total) (assert (exc-total (+ ?todate ?cost)) ) ) ; clear the display basket bit, 'cos it's done now (defrule clear_basket_flag ?f-stage <- (stage 6) ?f-basket <- (display_basket) (exc-total ?exc) (vat ?vat) => (retract ?f-basket) (printout t " -----------------" crlf) (format t "%-60s %6d %9d%n" "" ?exc (* ?exc ?vat) ) (printout t "------------------------------------------------------------------------------" crlf crlf) (retract ?f-stage) (assert (stage 7)) ) ;************************************************************************** ;*** The Rules - Round 7 : Explain that stuff about birds and bees *** ;************************************************************************** ; tell them they are bankrupt (defrule summarise_bankrupt (stage 7) (broke $?) => (printout t "Very sorry, sir/madam, I could not match your requirements" " - probably you are aiming too high. You could always try" " with a bigger budget..." crlf crlf) (printout t "I could not buy the following items :" crlf crlf) (format t "%-60s %6s %9s%n" Item "ex VAT" "inc VAT") (printout t "------------------------------------------------------------------------------" crlf crlf) (assert (exc-total 0) ) (assert (bankrupt) ) ) ; tell them what they couldn't buy (defrule summarise_bankrupt_statement (bankrupt) ?f-bought <- (broke ?cost ?name) (vat ?vat) ?f-total <- (exc-total ?todate) => (retract ?f-bought) (format t "%-60s %6d %9d%n" ?name ?cost (* ?cost ?vat)) (assert (exc-total (+ ?todate ?cost)) ) (retract ?f-total) ) ; display the footer of that shopping list (defrule summarise_bankrupt_total (bankrupt) ?f-stage <- (stage 7) (exc-total ?exc) (vat ?vat) => (printout t " -----------------" crlf) (format t "%-60s %6d %9d%n" "" ?exc (* ?exc ?vat) ) (printout t "------------------------------------------------------------------------------" crlf crlf) (assert (stage 8) ) (retract ?f-stage) ) ; if they did ok, tell them how much they have left (defrule summarise_success (stage 7) (money ?left) (vat ?vat) => (format t "That setup leaves you with %d" (* ?left ?vat) ) (printout t " which you can obviously spend on other" " interesting things..." crlf) (assert (summarised)) ) ; if they are using the net and have not much money left, tell them (defrule summarise_success_internet_warning (stage 7) (set internet) (money ?left) (test (> 200 ?left) ) => (printout t crlf "As a warning, however, I'd like to point out that " "you have less than 200 pounds left which needs to be " "spent on an internet provider and local phone calls. " "You will probably have to be very careful about how " "much time you spend on the 'net if you are not to go " "over budget." crlf) ) ; if they have a bit of money left, warn them anyhow (defrule summarise_success_internet_warning_the_sequel (stage 6) (set internet) (money ?left) (test (< 200 ?left) ) => (printout t crlf "I haven't, however, taken into account the cost of " "/using/ the internet. The main reason for this is that " "when using the 'net it is very likely that estimates " "of the time (and cost) are far too low. Bare this in " "mind." crlf) ) ; ... and regardless, give them some idea of the cost (defrule summarise_success_internet_warning_general (set internet) (stage 7) => (printout t crlf "Generally internet providers charge about 10 per " "month, with a initial setup fee of about 25. This is " "then compounded by the actual calls themselves." crlf) ) ; either way, it's time for rounding up... (defrule summarise_success_exit ?f-stage <- (stage 7) => (assert (stage 8)) (retract ?f-stage) ) ;************************************************************************** ;*** The Rules - Round 8 : Say goodbye and wait for the next person *** ;************************************************************************** ; you see, boomerang's fly away from you... (defrule boomerang_throw (stage 8) => (printout t "That's all folks" crlf crlf "Press a key then return to continue...") (assert (restart (read)) ) ) ; ... and stop dead if they hit you (type quit to end) ... (defrule boomerang_hit_head (stage 8) ?f-restart <- (restart quit) => (retract ?f-restart) ) ; ... or get caught to be thrown again (back to the beginning) (defrule boomerang_caught (stage 8) (restart ?) => (reset) ) 
