[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

Expert System



Hi,

I have two questions again,
First is easy & second is difficult. The first question is how to make the
result of calculation into decimal, because when I type :
> (/ 7 2)
the result is 7/2 and not 3.5

The second difficult question is : I bought the book "Programming for
Artificial Intelligence" by Wolfgang Kreutzer & Bruce McKenzie. I was
interested to play with the shrink conversation program, so I typed the
program, but there was an error like this : 

-------------------------
Type (shrink) to talk to the the shrink
> (shrink)
Welcome to my sofa
...>(I'm depressed today !)

car: expects argument of type <pair>; given #f
> 
------------------------------
I typed (I'm depressed today !), the program should reply with "Tell me
more", but it gave an error. If anyone of you can make this program work,
would you send the program back to me? This is a big program, so it must be
difficult to find the error. But anyway, either you can or not, thanks for
the attention.

Here is the complete program listing :

;-------start of pattern toolbox---
(define MakeAssoc
  (lambda (asymbol avalue) (list asymbol avalue)))
(define getsymbol
  (lambda (anAssociation) (car anAssociation)))
(define getvalue (lambda (anassociation) (cadr anassociation)))
(define makealist (lambda anassoclist anassoclist))
(define getnextassoc (lambda (analist) (car analist)))
(define getrestofassoc
  (lambda (analist) (cdr analist)))
(define storeassocasitem
  (lambda (asymbol anitem analist)
    (append analist (list (makeassoc asymbol anitem)))))

(define storeassocaslist
  (lambda (asymbol anitem analist)
    (cond ((null? analist)
           (makealist (makeassoc asymbol (list anitem))))
          ((equal? asymbol (getsymbol (getnextassoc analist)))
           (cons (makeassoc
                  asymbol
                  (if (pair? (getvalue (getnextassoc analist)))
                      (append (getvalue (getnextassoc analist)) (list anitem))
                      (list anitem)))
                 (getrestofassoc analist)))
          (else (cons (getnextassoc analist)
                      (storeassocaslist asymbol anitem
                                        (getrestofassoc analist)))))))

(define getassociation
  (lambda (apatternvariable analist)
    (assoc apatternvariable analist)))
(define getassociationvalue
  (lambda (apatternvariable analist)
    (let ((association (getassociation apatternvariable analist)))
      (if (null? association)
          (display "getassociationvalue:" 
           "no previous binding for" apatternvariable)
      (getvalue association)))))

(define ? (lambda (var . predicates) (list ? var predicates)))
(define ?+ (lambda (var . predicates) (list ?+ var predicates)))
(define <-? (lambda (var . predicates) (list <-? var predicates)))
(define ?symbol? (lambda (asymbol) (equal? asymbol ?)))
(define ?+symbol? (lambda (asymbol) (equal? asymbol ?+)))
(define <-?symbol? (lambda (asymbol) (equal? asymbol <-?)))
(define pattern (lambda symbols symbols))

(define buildnewpattern
  (lambda (anitemorlist apattern)
    (if (pair? anitemorlist)
        (append anitemorlist apattern)
        (cons anitemorlist apattern))))

(define ismatchingoperator?
  (lambda (anoperator)
    (or (?symbol? anoperator)
        (?+symbol? anoperator)
        (<-?symbol? anoperator))))

(define printmatchingoperator
  (lambda (anoperator)
    (cond ((?symbol? anoperator) (display "?"))
          ((?+symbol? anoperator) (display "?+"))
          ((<-?symbol? anoperator) (display "<-?")))))

(define printpattern
  (lambda (apattern)
    (define printpatternaux
      (lambda (apattern)
        (define printpatternelement
          (lambda (apatternelement)
            (cond ((ismatchingoperator? apatternelement)
                   (printmatchingoperator apatternelement))
                  ((ismatchingelement? apatternelement)
                   (printmatchingelement apatternelement))
                  ((pair? apatternelement)
                   (printpattern apatternelement))
                  (else (display apatternelement)))))
        (if (null? apattern)
            #f
            (begin (printpatternelement (car apattern))
                   (display " ")
                   (printpatternaux (cdr apattern))))))
    (display "(")
    (printpatternaux apattern)
    (display ")")))

(define makevariablesubst
  (lambda (apattern analist)
    (if (null? apattern)
        (pattern)
        (let ((element (car apattern)))
          (cons (if (and (ismatchingelement? element)
                         (<-?symbol? (matchingoperator element)))
                    (getassociationvalue (matchingvariable element) analist)
                    element)
                (makevariablesubst (cdr apattern) analist))))))

(define matchingoperator
  (lambda (amatchingelement) (car amatchingelement)))

(define matchingvariable
  (lambda (amatchingelement) (cadr amatchingelement)))
  
(define matchingpredicatelist
  (lambda (amatchingelement) (caddr amatchingelement)))

(define ismatchingelement?
  (lambda (amatchingelement)
    (and (pair? amatchingelement)
         (>= (length amatchingelement) 2)
         (ismatchingoperator? (matchingoperator amatchingelement)))))

(define satisfiespredicates?
  (lambda (analist apredicatelist)
    (cond ((null? apredicatelist) #t)
          (((car apredicatelist) analist)
           (satisfiespredicates? analist (cdr apredicatelist)))
          (else #f))))

(define printmatchingelement
  (lambda (amatchingelement)
    (define printpredicatelist
      (lambda (apredicatelist)
        (if (null? apredicatelist)
            #f
            (begin (display (car apredicatelist))
                   (printpredicatelist (cdr apredicatelist))))))
    (display "(")
    (printmatchingoperator (car amatchingelement))
    (display " ")
    (display (cadr amatchingelement))
    (if (caddr amatchingelement)
        (begin (display " ")
               (printpredicatelist (caddr amatchingelement)))
        #f)
    (display ")")))

(define processmatchingelement
  (lambda (apattern astring analist)
    (let* ((patternelement (car apattern))
           (operator (matchingoperator patternelement))
           (variable (matchingvariable patternelement))
           (predicatelist (matchingpredicatelist patternelement))
           (restpattern (cdr apattern))
           (stringelement (car astring))
           (reststring (cdr astring))
           (newalist analist))
      (cond ((?symbol? operator)
             (set! newalist (storeassocasitem variable
                                             stringelement
                                             analist)))
            ((?+symbol? operator)
             (set! newalist (storeassocaslist variable
                                              stringelement
                                              analist)))
            (else #f))
      (if (or (null? predicatelist)
              (satisfiespredicates? newalist predicatelist))
          (cond ((?symbol? operator)
                 (matchwithalist restpattern reststring newalist))
                ((?+ symbol? operator)
                 (or (matchwithalist restpattern
                                     reststring
                                     newalist)
                     (matchwithalist apattern
                                     reststring
                                     newalist)))
                ((<-?symbol? operator)
                 (matchwithalist (buildnewpattern
                                  (getassociationvalue variable analist)
                                  restpattern)
                                 astring
                                 newalist)))
          #f))))

(define matchwithalist
  (lambda (apattern astring analist)
    (define reportsuccess
      (lambda (nalaist)
        (if analist analist #t)))
    (define reportfailure (lambda () #f))
    (cond ((and (null? apattern) (null? astring))
           (reportfailure))
          ((or (null? apattern) (null? astring))
           (reportfailure))
          ((?symbol? (car apattern))
           (matchwithalist (cdr apattern) (cdr astring) analist))
          ((?+ symbol? (car apattern))
           (or (matchwithalist (cdr apattern) (cdr astring) analist)
               (matchwithalist apattern (cdr astring) analist)))
          ((ismatchingelement? (car apattern))
           (processmatchingelement apattern astring analist))
          ((and (pair? (car astring)) (pair? (car apattern)))
           (let ((newalist (matchwithalist (car apattern) (car astring)
                                           analist)))
             (if newalist (matchwithalist (cdr apattern)
                                          (cdr astring)
                                          newalist)
                 (reportfailure))))
          ((equal? (car apattern) (car astring))
           (matchwithalist (cdr apattern) (cdr astring) analist))
          (else (reportfailure)))))

(define match
  (lambda (apattern astring . optionalalist)
    (cond ((null? optionalalist)
           (matchwithalist apattern astring (makealist)))
          ((null? (cdr optionalalist))
           (matchwithalist apattern astring (car optionalalist)))
          (else (display "Too many arguments")))))
            
;---------end of pattern toolbox---------------
  

(define pattern (lambda symbols symbols))
(define makekb (lambda initialfacts initialfacts))
(define getfact (lambda (aretrievedelement) (car aretrievedelement)))
(define getalist (lambda (aretrievedelement) (cadr aretrievedelement)))
(define emptykb? (lambda (akb) (null? akb)))
(define restofkb (lambda (akb) (cdr akb)))
(define firstinkb (lambda (akb) (car akb)))
(define selectwholefact (lambda (afact) afact))
(define makeretrievedelement (lambda (afact analist)
                               (if (null? analist) #f
                                   (list afact analist))))

(define retrievebystring
  (lambda (akb astring . optionalarguments)
    (let ((aselectorfn selectwholefact)
          (analist #f))
      (define retrieveaux
        (lambda (akb)
          (if (emptykb? akb)
              #f
              (let* ((fact (firstinkb akb))
                     (pattern (aselectorfn fact))
                     (result (match pattern astring analist)))
                (if result
                    (makeretrievedelement fact result)
                    (retrieveaux (restofkb akb)))))))
      (if (> (length optionalarguments) 2)
          (display "too many optional arguments" optionalarguments)
          #f)
      (do ((args optionalarguments (cdr args))
           (arg #f))
        ((null? args) #f)
        (set! arg (car args))
        (if (procedure? arg)
            (set! aselectorfn arg)
            (set! analist arg)))
      (retrieveaux akb))))

(define shrink
  (lambda ()
    (let ((shrink-kb #f)
          (alldone #f))
      
      (define makefact
        (lambda (apattern aprocedure) 
          (cons apattern aprocedure)))
      (define selectpattern car)
      (define selectproc cdr)
      
      (define verb?
        (lambda (anal)
          (member (GetAssociationValue 'verb anAL)
                  '(go have be try eat take help 
                       make get jump write type fill put turn
                       computer think drink blink crash crunch add))))
      
      (define whyword?
        (lambda(anal)
          (member (getassociationvalue 'why anal)
                  '(why where when what))))
      (define doword?
        (lambda (anal)
          (member (getassociationvalue 'do anal)
                  '(do can should would))))
      (define iword?
        (lambda (anal)
          (member (getassociationvalue 'i anal) '(i me))))
      (define changeperson
        (lambda (alist)
          (define 1<->2person
            (lambda (word)
              (cond ((eq? word 'i) 'you)
                    ((eq? word 'me) 'you)
                    ((eq? word 'you) 'me)
                    ((eq? word 'my) 'your)
                    ((eq? word 'your) 'my)
                    ((eq? word 'yours) 'mine)
                    ((eq? word 'mine) 'yours)
                    ((eq? word 'am) 'are)
                    (else word))))
        (map 1<->2person alist)))
    
    (define questionno 0)
    (define questionlist '(when why where))
    (define question
      (lambda ()
        (set! questionno (+ 1 questionNo))
        (if (= questionNo (length questionNo))
            (if (= questionNo (length questionList))
                (set! questionNo 0)
                #f)
            (list-ref questionlist questionno))))

      (define replyno 0)
      (define replylist '("Please go on"
                          "Tell me more"
                          "I see"
                          "What does that indicate?"
                          "But why be concerned about that?"
                          "Just tell me how you feel"))
      (define generalreply
        (lambda ()
          (set! replyno (+ 1 replyno))
          (if (= replyno (length replylist))
              (set! replyno 0)
              #f)
          (list-ref replylist replyno)))
      
      (define reply
        (lambda alist
          (define replyaux
            (lambda (alist)
              (do ((rest alist (cdr rest)))
                ((null? rest))
                (if (pair? (car rest))
                    (replyaux (car rest))
                    (display (car rest)))
                (display " "))))
          (replyaux alist)))
      
      (define initkb
        (lambda ()
          (set! 
           shrink-kb
               (makekb
                (makefact (pattern 'bye)
                          (lambda (al)
                            (set! alldone #t)
                            (reply "come back soon. Goodbye")
                            (newline)))
                (makefact (pattern 'I 'am ?+)
                          (lambda (al)
                            (reply "Please tell me" (question) "you are")))
                (makefact (pattern 'I 'feel ?+)
                          (lambda (al) (reply "I sometimes feel the same
way")))
                (makefact (pattern 'I 'have (?+ 'x))
                          (lambda (al)
                            (reply "How long have you had"
                                  (changeperson (getassociation value 'x
al)))))
                (makefact (pattern 'because ?+)
                          (lambda (al) (reply "Is that really the reason?")))
                (makefact (pattern 'yes ?+)
                          (lambda (al) (reply "How can you be so sure?")))
                (makefact (pattern)
                          (lambda (al) (reply "Please say something")))
                (makefact (pattern 'you 'are (?+ 'something))
                          (lambda (al)
                            (reply "O yeah. I am"
                                  (changeperson (getassociationvalue 'rest
al)))))
                (makefact (pattern (? 'verb verb?) (?+ 'rest))
                          (lambda (al)
                            (reply "So you want me to go and"
                                   (getassociationvalue 'verb al)
                                   (changeperson (getassociationvalue 'rest
al)))))
                (makefact (Pattern (? 'why whyword?) (?+ 'rest))
                          (lambda (al)
                            (reply "You tell me"
                                   (getassociationvalue 'why al))))
                (makefact (pattern ?+)
                          (lambda (al)
                            (reply (generalreply))))))))
    (define readsentence
      (lambda ()
        (let ((sentence #f))
          (newline)
          (display "...>")
          (set! sentence (read))
          (newline)
          (if (not (pair? sentence))
              (begin (display "Please give your replies as a list")
                     (readsentence))
              sentence))))
    
    (initkb)
    (set! alldone #f)
    (display "Welcome to my sofa")
    (do ((sentence #f)
         (element #f))
         (alldone #f)
         (set! sentence (readsentence))
         (set! element (retrievebystring shrink-kb
                                        sentence
                                        selectpattern))
         ((selectproc (getfact element))
          (getalist element))))))

(begin
  (display "Type (shrink) to talk to the the shrink") (newline))