prob3.lisp

using lisp to do the caculation, can parse the natural language,and can caculate the simple, like wh

(defvar operation '(plus minus multiply divide squareroot product sum))

(defvar *gram* '((s (qp vp) (vp))
		       (qp (q adv) (q))
		       (vp (v np))
		       (np (art n pp)(nm pp)(nm)(nm adj)(pron np) (nm adjp))
                                            (pp (prep np) (prep vp) (np))
                                            (adjp (adj pp))
		       (art a the)
		       (n product sum squareroot me result)
		       (nm that new1 2 3 4 5 6 7 8 9)
                                            (pron me)
                                            (q what how)
                                            (adv much)
                                            (adj divided new)
		       (prep of and by then plus minus )
		       (v is divide tell multiply call)))
(defun commend()
	   (setq s (read))
	   (unless (eq s '?)
	     (setq sent (append sent (list s)))
	     (commend)))

(defun receive()
	   (setq sent ())
	   (commend))


(defun match(s)
	   (setq op ())
	   (setq l (length s))
	    (loop for i from 0 to l do
		(unless (equal nil (member (nth i s) operation)) (setq op (push (nth i s) op)))))

 (defun result(number s)
	   (case number
	     (0 (progn (setq p (position 'plus s))(get2number p s)(+ a b)))
             (1 (progn (setq p (position 'minus s))(get2number p s)(- a b)))
             (2 (progn (setq p (position 'by s))(get2number p s) (* a b)))
             (3 (progn (setq p (position 'by s))(get2number p s) (/ a b)))
             (4 (progn (setq p (position 'of s))(sqrt (nth (incf p) s))))
             (5 (progn (setq p (position 'and s))(get2number p s) (* a b)))
             (6 (progn (setq p (position 'and s))(get2number p s) (+ a b)))))
	     
(defun get2number(p s)
	   (if (numberp (nth (- p 1) s)) (setq a (nth (- p 1) s)) (setq a that))
	   (if (numberp (nth (+ 1 p) s)) (setq b (nth (+ 1 p) s)) (setq b that)))

 (defun subsent(number s)
	   (case number
	     (0 (setq sent2 (subseq s (1+ (position 'plus s)) (length s))))
	     (1 (setq sent2 (subseq s (1+ (position 'minus s)) (length s))))
	     (2 (setq sent2 (subseq s (1+ (position 'by s)) (length s))))
	     (3 (setq sent2 (subseq s (1+ (position 'by s)) (length s))))
	     (4 (setq sent2 (subseq s (1+ (position 'of s)) (length s))))
	     (5 (setq sent2 (subseq s (1+ (position 'and s)) (length s))))
	     (6 (setq sent2 (subseq s (1+ (position 'and s)) (length s))))))
(defun getresult(s)
	   (match s)
	   (setq that (result (position (car op) operation) s)))

(defun subresult()
	  (subsent (position (car (reverse op)) operation) sent)
	  (setq result1 (getresult sent2))
          (setq sent (append (butlast sent (length sent2)) (list result1))))

(defun finalresult()
           (match sent)
	   (do ((l (length op)))
	       ((= l 1) (getresult sent))
	       (subresult)
	       (match sent)
	       (setq l (length op))))



(defun parse (sent)
  (prog (stack1 stack2 marker phrase exp)
     (setq stack1 (list sent))
     (setq stack2 (list '(s)))
     loop (or stack1 (return nil))
     (format t "matching phrase ~s with marker ~s~%" stack1 stack2)
     (setq phrase (pop stack1))
     (setq marker (pop stack2))
     (terpri)
     (cond((and (null phrase)(null marker))(return t))  
          ((or (null phrase)
		(null marker)
		(< (length phrase)(length marker)))
	    (go loop)))	    
     (setq exp (cdr (assoc (car marker) *gram*)))
     (and exp
	  (cond ((atom (car exp))
		 (and (member (car phrase) exp)
		      (progn (push (cdr phrase) stack1)
			     (push (cdr marker) stack2))))
		(t (loop for x in exp do
			 (push phrase stack1)
			 (push (append x (cdr marker)) stack2)))))
     (go loop)))

(defun ncl()
	   (receive)
           (setq po (position 'and sent))
	   (match sent)
	   (if (and (equal 'product (car (reverse op))) (numberp (nth (+ 1 po) sent))
		    (numberp (nth (- po 1) sent)))
	       (setq sent (push (result 5 sent)(subseq sent (+ 2 po) (length sent)))))
	   (finalresult))