diff options
| -rw-r--r-- | .gitignore | 2 | ||||
| -rw-r--r-- | README.md | 36 | ||||
| -rw-r--r-- | paip/eliza.lisp | 346 | ||||
| -rw-r--r-- | paip/twenty-questions.lisp | 43 |
4 files changed, 412 insertions, 15 deletions
diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..3d894d7 --- /dev/null +++ b/.gitignore @@ -0,0 +1,2 @@ +*~ +*.fasl diff --git a/README.md b/README.md index 9ec1ace..cebb12d 100644 --- a/README.md +++ b/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ư diff --git a/paip/eliza.lisp b/paip/eliza.lisp new file mode 100644 index 0000000..05c6cfc --- /dev/null +++ b/paip/eliza.lisp @@ -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))))))) diff --git a/paip/twenty-questions.lisp b/paip/twenty-questions.lisp new file mode 100644 index 0000000..fed4997 --- /dev/null +++ b/paip/twenty-questions.lisp @@ -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) |