[paip] Upload Twenty Questions and ELIZA
This commit is contained in:
parent
8bce84a8cc
commit
79487278f0
|
@ -0,0 +1,2 @@
|
|||
*~
|
||||
*.fasl
|
36
README.md
36
README.md
|
@ -2,15 +2,17 @@
|
|||
|
||||
Bài tập luyện tập thi Olympic, học sinh giỏi Tin học, trong đó:
|
||||
|
||||
| Thư mục | Nguồn đề bài |
|
||||
| ---------------------- | --------------------------------- |
|
||||
| `09`, `10`, `11`, `12` | Đề thi, kiểm tra phân theo lớp |
|
||||
| `COCI` | [Giải Tin học Croatia mở rộng][0] |
|
||||
| `NTU` | [Đại học Nha Trang][1] |
|
||||
| `THT` | Hội thi Tin học trẻ |
|
||||
| `codeforces` | [Codeforces][2] |
|
||||
| `daily` | [/r/dailyprogrammer][3] |
|
||||
| `others` | Các đề bài không rõ nguồn |
|
||||
| Thư mục | Nguồn đề bài |
|
||||
| ---------------------- | ------------------------------------------------- |
|
||||
| `09`, `10`, `11`, `12` | Đề thi, kiểm tra phân theo lớp |
|
||||
| `COCI` | [Giải Tin học Croatia mở rộng][0] |
|
||||
| `NTU` | [Đại học Nha Trang][1] |
|
||||
| `THT` | Hội thi Tin học trẻ |
|
||||
| `codeforces` | [Codeforces][2] |
|
||||
| `daily` | [/r/dailyprogrammer][3] |
|
||||
| `others` | Các đề bài không rõ nguồn |
|
||||
| `paip` | Paradigms of Artificial Intelligence Programming |
|
||||
| `sicp` | Structure and Interpretation of Computer Programs |
|
||||
|
||||
[0]: http://www.hsin.hr/coci/
|
||||
[1]: http://laptrinh.ntu.edu.vn/
|
||||
|
@ -23,12 +25,16 @@ nhật dần.
|
|||
|
||||
Phiên bản các trình dịch sử dụng test:
|
||||
|
||||
| Ngôn ngữ | Trình dịch |
|
||||
| -------- | ------------------ |
|
||||
| C | GNU GCC 4.9+ |
|
||||
| Pascal | Free Pascal 2.6.4+ |
|
||||
| Python | Python 3.5+ |
|
||||
| Scheme | GNU Guile 2.0.11+ |
|
||||
| Ngôn ngữ | Trình dịch |
|
||||
| ----------- | ------------------ |
|
||||
| C | GNU GCC 4.9+ |
|
||||
| Common Lisp | SBCL 1.4.8+ |
|
||||
| Pascal | Free Pascal 2.6.4+ |
|
||||
| Python | Python 3.5+ |
|
||||
| Scheme | GNU Guile 2.0.11+ |
|
||||
|
||||
SICP không chỉ dùng Guile để chạy Scheme mà còn sử dụng Racket (`#lang sicp`)
|
||||
trong các chương 1, 2 và 3.
|
||||
|
||||
Tất cả các bài làm được phát hành theo giấy phép [GPLv3](LICENSE), cho phép
|
||||
người dùng chạy, nghiên cứu, chia sẻ và chỉnh sửa tự do. Các đề bài hầu như
|
||||
|
|
|
@ -0,0 +1,346 @@
|
|||
(defconstant fail nil "Indicates pat-match failure.")
|
||||
(defconstant no-bindings '((t . t))
|
||||
"Indicates pat-match success with no variables.")
|
||||
|
||||
(defun variable? (x)
|
||||
"Is x a variable (a symbol beginning with '?')?"
|
||||
(and (symbolp x) (equal (char (symbol-name x) 0) #\?)))
|
||||
|
||||
(defun get-binding (var bindings)
|
||||
"Find a (var . val) pair in a binding list."
|
||||
(assoc var bindings))
|
||||
|
||||
(defun binding-val (binding)
|
||||
"Get the value part of a single binding."
|
||||
(cdr binding))
|
||||
|
||||
(defun lookup (var bindings)
|
||||
"Get the value part (for var) from a binding list."
|
||||
(binding-val (get-binding var bindings)))
|
||||
|
||||
(defun extend-bindings (var val bindings)
|
||||
"Add a (var . val) pair to a binding list."
|
||||
(cons (cons var val) (unless (eq bindings no-bindings) bindings)))
|
||||
|
||||
(defun match-variable (var input bindings)
|
||||
"Does VAR match input? Update and return bindings."
|
||||
(let ((binding (get-binding var bindings)))
|
||||
(cond ((not binding) (extend-bindings var input bindings))
|
||||
((equal (binding-val binding) input) bindings)
|
||||
(t fail))))
|
||||
|
||||
(defun first-match-pos (pat input start)
|
||||
"Find the first position that pat could possibly match input,
|
||||
starting at position start. If pat is non-constant, simply return start."
|
||||
(cond ((and (atom pat) (not (variable? pat)))
|
||||
(position pat input :start start :test #'equal))
|
||||
((< start (length input)) start)
|
||||
(t nil)))
|
||||
|
||||
(defun segment-match (pattern input bindings &optional (start 0))
|
||||
"Match the segment pattern ((:* var) . pat) against input."
|
||||
(let ((var (cadar pattern))
|
||||
(pat (rest pattern)))
|
||||
(if (null pat)
|
||||
(match-variable var input bindings)
|
||||
; Assume that a pattern cannot have 2 consecutive vars
|
||||
(let ((binding (get-binding var bindings))
|
||||
(pos (first-match-pos (first pat) input start)))
|
||||
(cond ((null pos) fail)
|
||||
((null binding)
|
||||
(let ((b2 (pat-match pat (subseq input pos)
|
||||
(extend-bindings var (subseq input 0 pos)
|
||||
bindings))))
|
||||
(if (eq b2 fail)
|
||||
(segment-match pattern input bindings (1+ pos))
|
||||
b2)))
|
||||
((eq (binding-val binding) (subseq input 0 pos))
|
||||
(pat-match pat (subseq input pos) bindings))
|
||||
(t fail))))))
|
||||
(setf (get :* 'segment-match) 'segment-match)
|
||||
|
||||
(defun segment-match-+ (pattern input bindings)
|
||||
"Match one or more elements of input."
|
||||
(segment-match pattern input bindings 1))
|
||||
(setf (get :+ 'segment-match) 'segment-match-+)
|
||||
|
||||
(defun segment-match-? (pattern input bindings)
|
||||
"Match zero or one element of input."
|
||||
(let ((var (cadar pattern))
|
||||
(pat (rest pattern)))
|
||||
(or (pat-match (cons var pat) input bindings)
|
||||
(pat-match pat input bindings))))
|
||||
(setf (get :? 'segment-match) 'segment-match-?)
|
||||
|
||||
(defun match-if (pattern input bindings)
|
||||
"Test an arbitrary expression involving variables.
|
||||
The pattern looks like ((:if code) . rest)."
|
||||
(and (eval (sublis bindings (cadar pattern)))
|
||||
(pat-match (rest pattern) input bindings)))
|
||||
(setf (get :if 'segment-match) 'match-if)
|
||||
|
||||
(defun segment-match-fn (x)
|
||||
"Get the segment-match function for x."
|
||||
(when (keywordp x) (get x 'segment-match)))
|
||||
|
||||
(defun segment-pattern? (pattern)
|
||||
"Is this a segment matching pattern: ((:* var) . pat) ?"
|
||||
(and (consp pattern) (consp (first pattern)) (symbolp (caar pattern))
|
||||
(segment-match-fn (caar pattern))))
|
||||
|
||||
(defun segment-matcher (pattern input bindings)
|
||||
"Calls the right function for this king of segment pattern."
|
||||
(funcall (segment-match-fn (caar pattern)) pattern input bindings))
|
||||
|
||||
(defun match-is (var-and-pred input bindings)
|
||||
"Succeed and bind var if the input satisfies pred,
|
||||
where var-and-pred is the list (var pred)."
|
||||
(let* ((var (first var-and-pred))
|
||||
(pred (second var-and-pred))
|
||||
(new-bindings (pat-match var input bindings)))
|
||||
(if (or (eq new-bindings fail)
|
||||
(not (funcall pred input)))
|
||||
fail
|
||||
new-bindings)))
|
||||
(setf (get :is 'single-match) 'match-is)
|
||||
|
||||
(defun match-and (patterns input bindings)
|
||||
"Succeed if all the patterns match the input."
|
||||
(cond ((eq bindings fail) fail)
|
||||
((null patterns) bindings)
|
||||
(t (match-and (rest patterns) input
|
||||
(pat-match (first patterns) input bindings)))))
|
||||
(setf (get :and 'single-match) 'match-and)
|
||||
|
||||
(defun match-or (patterns input bindings)
|
||||
"Succeed if any one of the patterns match the input."
|
||||
(if (null patterns)
|
||||
fail
|
||||
(let ((new-bindings (pat-match (first patterns) input bindings)))
|
||||
(if (eq new-bindings fail)
|
||||
(match-or (rest patterns) input bindings)
|
||||
new-bindings))))
|
||||
(setf (get :or 'single-match) 'match-or)
|
||||
|
||||
(defun match-not (patterns input bindings)
|
||||
"Succeed of none of the patterns match the input.
|
||||
This will never bind any variable."
|
||||
(if (match-or patterns input bindings)
|
||||
fail
|
||||
bindings))
|
||||
(setf (get :not 'single-match) 'match-not)
|
||||
|
||||
(defun single-match-fn (x)
|
||||
"Get the single-match function for x."
|
||||
(when (keywordp x) (get x 'single-match)))
|
||||
|
||||
(defun single-pattern? (pattern)
|
||||
"Is this a single-matching pattern?"
|
||||
(and (consp pattern) (single-match-fn (first pattern))))
|
||||
|
||||
(defun single-matcher (pattern input bindings)
|
||||
"Call the right function for this kind of single pattern."
|
||||
(funcall (single-match-fn (first pattern)) (rest pattern) input bindings))
|
||||
|
||||
(defun pat-match (pattern input &optional (bindings no-bindings))
|
||||
"Match pattern against input in the context of the bindings."
|
||||
(cond ((eq bindings fail) fail)
|
||||
((variable? pattern) (match-variable pattern input bindings))
|
||||
((eql pattern input) bindings)
|
||||
((segment-pattern? pattern) (segment-matcher pattern input bindings))
|
||||
((single-pattern? pattern) (single-matcher pattern input bindings))
|
||||
((and (consp pattern) (consp input))
|
||||
(pat-match (rest pattern) (rest input)
|
||||
(pat-match (first pattern) (first input) bindings)))
|
||||
(t fail)))
|
||||
|
||||
(defparameter *eliza-rules*
|
||||
'(((?x* hello ?y*)
|
||||
(How do you do? Please state your problem.))
|
||||
((?x* computer ?y*)
|
||||
(Do computers worry you?) (What do you think about machines?)
|
||||
(Why do you mention computers?)
|
||||
(What do you think machines have to do with your problem?))
|
||||
((?x* name ?y*)
|
||||
(I am not interested in names.))
|
||||
((?x* sorry ?y*)
|
||||
(Please don't apnologize.) (Apologies are not necessary.)
|
||||
(What feelings do you have when you apologize?))
|
||||
((?x* I remember ?y*)
|
||||
(Do you often think of ?y ?)
|
||||
(Does thinking of ?y bring anything else to mind?)
|
||||
(What else do you remember?) (Why do you recall ?y right now?)
|
||||
(What in the present situation reminds you of ?y ?)
|
||||
(What is the connection between you and ?y ?))
|
||||
((?x* do you remember ?y*)
|
||||
(Did you think I would forget ?y ?)
|
||||
(Why do you think I should recall ?y now ?)
|
||||
(What about ?y ?) (You mentioned ?y))
|
||||
((?x* if ?y*)
|
||||
(Do you really think its likely that ?y ?) (Do you wish that ?y ?)
|
||||
(What do you think about ?y ?) (Really-- if ?y))
|
||||
|
||||
((?x* I dreamt ?y*)
|
||||
(Really-- ?y) (Have you ever fantasized ?y while you were awake?)
|
||||
(Have you dreamt ?y before?))
|
||||
((?x* dream about ?y*)
|
||||
(How do you feel about ?y in reality?))
|
||||
((?x* dream ?y*)
|
||||
(What does this dream suggest to you?) (Do you dream often?)
|
||||
(What persons appear in your dreams?)
|
||||
(Don't you believe that dream has to do with your problem?))
|
||||
((?x* my mother ?y*)
|
||||
(Who else in your family ?y ?) (Tell me more about your family.))
|
||||
((?x* my father ?y*)
|
||||
(Your father) (Does he influence you strongly?)
|
||||
(What else comes to mind when you think of your father?))
|
||||
|
||||
((?x* I want ?y*)
|
||||
(What would it mean if you got ?y)
|
||||
(Why do you want ?y) (Suppose you got ?y soon))
|
||||
((?x* I am glad ?y*)
|
||||
(How have I helped you to be ?y) (What makes you happy just now)
|
||||
(Can you explain why you are suddenly ?y))
|
||||
((?x* I am sad ?y*)
|
||||
(I am sorry to hear you are depressed)
|
||||
(I'm sure its not pleasant to be sad))
|
||||
((?x* are like ?y*)
|
||||
(What resemblance do you see between ?x and ?y))
|
||||
((?x* is like ?y*)
|
||||
(In what way is it that ?x is like ?y)
|
||||
(What resemblance do you see?)
|
||||
(Could there really be some connection?) (How?))
|
||||
((?x* alike ?y*)
|
||||
(In what way?) (What similarities are there?))
|
||||
((?x* same ?y*)
|
||||
(What other connections do you see?))
|
||||
|
||||
((?x* I was ?y*)
|
||||
(Were you really?) (Perhaps I already knew you were ?y)
|
||||
(Why do you tell me you were ?y now?))
|
||||
((?x* was I ?y*)
|
||||
(What if you were ?y ?) (Do you think you were ?y ?)
|
||||
(What would it mean if you were ?y))
|
||||
((?x* I am ?y*)
|
||||
(In what way are you ?y ?) (Do you want to be ?y ?))
|
||||
((?x* am I ?y*)
|
||||
(Do you believe you are ?y) (Would you want to be ?y)
|
||||
(You wish I would tell you you are ?y)
|
||||
(What would it mean if you were ?y))
|
||||
((?x* am ?y*)
|
||||
(Why do you say "AM?") (I don't understand that))
|
||||
((?x* are you ?y*)
|
||||
(Why are you interested in whether I am ?y or not?)
|
||||
(Would you prefer if I weren't ?y)
|
||||
(Perhaps I am ?y in your fantasies))
|
||||
((?x* you are ?y*)
|
||||
(What makes you think I am ?y ?))
|
||||
|
||||
((?x* because ?y*)
|
||||
(Is that the real reason?) (What other reasons might there be?)
|
||||
(Does that reason seem to explain anything else?))
|
||||
((?x* were you ?y*)
|
||||
(Perhaps I was ?y) (What do you think?) (What if I had been ?y))
|
||||
((?x* I can't ?y*)
|
||||
(Maybe you could ?y now) (What if you could ?y ?))
|
||||
((?x* I feel ?y*)
|
||||
(Do you often feel ?y ?))
|
||||
((?x* I felt ?y*)
|
||||
(What other feelings do you have?))
|
||||
((?x* I ?y* you (:* ?z))
|
||||
(Perhaps in your fantasy we ?y each other))
|
||||
((?x* why don't you ?y*)
|
||||
(Should you ?y yourself?)
|
||||
(Do you believe I don't ?y) (Perhaps I will ?y in good time))
|
||||
((?x* yes ?y*)
|
||||
(You seem quite positive) (You are sure) (I understand))
|
||||
((?x* no ?y*)
|
||||
(Why not?) (You are being a bit negative)
|
||||
(Are you saying "NO" just to be negative?))
|
||||
|
||||
((?x* someone ?y*)
|
||||
(Can you be more specific?))
|
||||
((?x* everyone ?y*)
|
||||
(surely not everyone) (Can you think of anyone in particular?)
|
||||
(Who for example?) (You are thinking of a special person))
|
||||
((?x* always ?y*)
|
||||
(Can you think of a specific example) (When?)
|
||||
(What incident are you thinking of?) (Really-- always))
|
||||
((?x* what ?y*)
|
||||
(Why do you ask?) (Does that question interest you?)
|
||||
(What is it you really want to know?) (What do you think?)
|
||||
(What comes to your mind when you ask that?))
|
||||
((?x* perhaps ?y*)
|
||||
(You do not seem quite certain))
|
||||
((?x* are ?y*)
|
||||
(Did you think they might not be ?y)
|
||||
(Possibly they are ?y))
|
||||
((?x*)
|
||||
(Tell me more about you) ; to be replaced with info from dialog
|
||||
(Very interesting) (I am not sure if I understand you fully.)
|
||||
(What does that suggest to you?) (Please continue) (Go on)
|
||||
(Do you feel strongly about discussing such things?))))
|
||||
|
||||
(defun expand-pat-match-abbrev (pattern)
|
||||
"Expand out all pattern matching abbreviations in pattern."
|
||||
(cond ((and (symbolp pattern) (get pattern 'expand-pat-match-abbrev)))
|
||||
((atom pattern) pattern)
|
||||
(t (mapcar #'expand-pat-match-abbrev pattern))))
|
||||
|
||||
(defun pat-match-abbrev (symbol expansion)
|
||||
"Define symbol as a macro standing for a pat-match pattern."
|
||||
(setf (get symbol 'expand-pat-match-abbrev)
|
||||
(expand-pat-match-abbrev expansion)))
|
||||
|
||||
(pat-match-abbrev '?x* '(:* ?x))
|
||||
(pat-match-abbrev '?y* '(:* ?y))
|
||||
|
||||
(defun rule-pattern (rule) (expand-pat-match-abbrev (first rule)))
|
||||
(defun rule-responses (rule) (rest rule))
|
||||
|
||||
(defun random-elt (seq)
|
||||
"Pick a random element out of a sequence."
|
||||
(elt seq (random (length seq))))
|
||||
|
||||
(defun use-eliza-rules (input)
|
||||
"Find some rule with which to transform the input."
|
||||
(some (lambda (rule)
|
||||
(let ((result (pat-match (rule-pattern rule) input)))
|
||||
(unless (eq result fail)
|
||||
(let* ((response (random-elt (rule-responses rule)))
|
||||
(var (find-if #'variable? response))
|
||||
(pats (sublis '((I . you) (you . I) (me . you) (am . are))
|
||||
result)))
|
||||
(unless (null var)
|
||||
(let ((memory (lookup var pats)))
|
||||
(unless (null memory)
|
||||
(setf (cadar (last *eliza-rules*))
|
||||
`(Tell me more about ,memory)))))
|
||||
(sublis pats response)))))
|
||||
*eliza-rules*))
|
||||
|
||||
(defun flatten (the-list)
|
||||
"Append together elements (or lists) in the list."
|
||||
(unless (null the-list)
|
||||
(let ((a (first the-list)))
|
||||
(if (and (listp a) (not (eq (first a) 'quote)))
|
||||
(append a (flatten (rest the-list)))
|
||||
(cons a (flatten (rest the-list)))))))
|
||||
|
||||
(defun split (string)
|
||||
"Split string into symbols that can be inserted anywhere in a sentence."
|
||||
(read-from-string
|
||||
(format nil "(~a)"
|
||||
(substitute-if #\space (lambda (c) (find c ".!?")) string))))
|
||||
|
||||
(defun eliza ()
|
||||
"Respond to user input using pattern matching rules."
|
||||
(loop
|
||||
(print 'eliza>)
|
||||
(let ((input (split (read-line))))
|
||||
(if (equal input '(bye))
|
||||
(return)
|
||||
(mapc (lambda (x) (if (and (listp x) (eq (first x) 'quote))
|
||||
(write x :pretty t)
|
||||
(format t " ~a" x)))
|
||||
(flatten (use-eliza-rules input)))))))
|
|
@ -0,0 +1,43 @@
|
|||
; Because case doesn't like quotes
|
||||
(defconstant yes 'yes)
|
||||
(defconstant no 'no)
|
||||
(defconstant it 'it)
|
||||
|
||||
(defun random-elt (list)
|
||||
"Choose a random element from the given list."
|
||||
(if (null list)
|
||||
nil
|
||||
(elt list (random (length list)))))
|
||||
|
||||
(defun query-if (question &optional (pred (lambda (answer) t)))
|
||||
"Ask until receive a proper answer."
|
||||
(princ question)
|
||||
(let ((answer (read)))
|
||||
(if (funcall pred answer)
|
||||
answer
|
||||
(query-if question pred))))
|
||||
|
||||
(defun twenty-questions (db n)
|
||||
"Guess what's in the user's mind and return the updated database."
|
||||
(if (or (null db) (= n 0))
|
||||
(let ((answer (query-if "What is it? ")))
|
||||
(if (assoc answer db)
|
||||
db
|
||||
(cons (list answer) db)))
|
||||
(let* ((guess (random-elt db))
|
||||
(word (first guess))
|
||||
(remain (remove guess db)))
|
||||
(case (query-if (format nil "Is it a kind of ~a? " word)
|
||||
(lambda (answer) (member answer (list yes no it))))
|
||||
(yes (cons (cons word (twenty-questions (rest guess) (1- n))) remain))
|
||||
(no (cons guess (twenty-questions remain (1- n))))
|
||||
(it db)))))
|
||||
|
||||
(defun play (&optional (db nil))
|
||||
"Play again and again."
|
||||
(let ((n (query-if "How many questions can be asked? " #'integerp)))
|
||||
(if (>= n 0)
|
||||
(play (twenty-questions db n))
|
||||
(print db))))
|
||||
|
||||
(play)
|
Loading…
Reference in New Issue