FC2ブログ
--.--
--
上記の広告は1ヶ月以上更新のないブログに表示されています。
新しい記事を書く事で広告が消せます。

09.23
Sun
prologって面白い言語ですねー

いままでさわったのとは全然違いまして.

ということで勉強中のLispでprologっぽい挙動をするなんかを作ってみました



(setq allrule (make-hash-table))
(setq allogicalexpr (make-hash-table))
(setq keyname (make-hash-table))


(defun getllst (lst leng)
	(if (null lst)
		nil
		(if (= (length (car lst)) leng)
			(cons (car lst) (getllst (cdr lst) leng))
			(getllst (cdr lst) leng)
		)
	)
)

(defun isymbol (atm)
	(if (equal (substring (symbol-name atm) 0 1) "?")
		t
		nil
	)
)
(defun isinsymbol (lst)
	(if (null lst)
		nil
		(if (isymbol(car lst))
			t
			(isinsymbol (cdr lst))
		)
	)
)

(defun isin (lst factor)
	(if (null lst)
		0
      	(progn
			(if (listp (car lst))
	    		(+ (isin (car lst) factor) (isin (cdr lst) factor))
	    		(progn
	      			(if (equal (car lst) factor)
		  				(+ 1 (isin (cdr lst) factor))
						(isin (cdr lst) factor)
	      			)
	    		)
			)
		)
	)
)

(defun getdata (lst symbolname)
	(if (null lst)
		nil
		(if (equal (caar lst) symbolname)
			(cdar lst)
			(getdata (cdr lst) symbolname)
		)
	)
)

(defun compare-val-lis (fact-lst ques-lst &optional (rule nil))
	(if (null fact-lst)
		rule
		(if (not (equal (car fact-lst) (car ques-lst)))
			(if (isymbol (car ques-lst))
				(if (< (isin rule (car ques-lst))  1)
					(compare-val-lis (cdr fact-lst) (cdr ques-lst) (cons (list (car ques-lst) (car fact-lst)) rule))
					(if (equal (car fact-lst) (car (getdata rule (car ques-lst))))
						(compare-val-lis (cdr fact-lst) (cdr ques-lst) rule)
						nil
					)
				)
				nil
			)
			(compare-val-lis (cdr fact-lst) (cdr ques-lst) rule)
		)
	)
)



(defun comparelst (fact-lst ques-lst)
	(if (equal fact-lst ques-lst)
		t
		(if (isinsymbol ques-lst)
			(compare-val-lis fact-lst ques-lst)
			nil
		)
	)
)


(defun matchwithlst (target fact &optional (result nil))
    (if (null fact)
		result
		(let ((res (comparelst (car fact) target)))
			(if (not (null res))
				(matchwithlst target (cdr fact) (cons res result))
				(matchwithlst target (cdr fact) result)
			)
		)
	)
)



(defun solve (queslst)
    (if (null queslst)
        nil
		(let ((setname (car queslst)))
        	(if (null (gethash setname allrule))
				(if (null (gethash setname keyname))
					(progn
						(print "undefined predicate1")
						nil
					)
					(if (/= (length (cdr queslst)) (length (gethash (car queslst) keyname)))	
						(progn
							(print "undefined predicate2")
							nil
						)
						(let ((factlst (gethash (car queslst) allogicalexpr)))
							(lexpcompare (makequery (cdr queslst) (gethash (car queslst) keyname) ) factlst)
						)
					)
				)
				(let  ((fact (getllst (gethash setname allrule) (- (length queslst) 1))))
					(if (null fact)
						(progn
							(print "undefined predicate3")
							nil
						)
						(matchwithlst (cdr queslst) fact)
					)
				)
			)
		)
    )
)

(defun defact (factlst)
	(if (null factlst)
		nil
		(let ((predicate-name (caar factlst)))
			(setf (gethash predicate-name allrule) (append (list (cdr (car factlst)))(gethash predicate-name allrule)))
			(defact (cdr factlst))
		)
	)
)

(defun deflexpr (fst snd)
	(setf (gethash (car fst) allogicalexpr) (append (gethash (car fst) allogicalexpr) (solve snd) ))
	(setf (gethash (car fst) keyname) (cdr fst))
)


(defun makequery (target valst)
	(if (null target)
		nil
		(reverse (cons (list (car valst) (car target)) (makequery (cdr target) (cdr valst))))
	)
)



(defun lexvalcompare (target eachfact &optional (status nil))
    (if (null target)
        status
        (let ((result (matchwithlst (cdar target) (list (cdar eachfact)))))
            (if (not (null result))
                (if (not (equal result '(t)))
                    (lexvalcompare (cdr target) (cdr eachfact) (setq status (cons result status)))
                    (lexvalcompare (cdr target) (cdr eachfact) status)
                )
                (lexvalcompare (cdr target) (cdr eachfact) (setq status nil))
            )
        )
    )
)



(defun lexpcompare (target factlst)
	(if (null factlst)
		nil
        (let ((eachfact (car factlst)))
            (if (equal target eachfact)
                t
                (let ((result (lexvalcompare target eachfact)))
                    (if (not (null result))
                        (cons  result (lexpcompare target (cdr factlst)))
                        (lexpcompare target (cdr factlst))
                    )
                )
            )
        )
    )
)


まず、prologをある程度できるようになってからじゃなきゃ書くのむずいなぁと思いました

以下のようにして事実や論理式?を定義します


(defact 
    '(
        (like Jhon   Lisp)
        (like Smith  Python)
        (like Alan   C)
        (like Albert Java)
        (like Taylor Haskell)
        (like Curry  Haskell)
        (human sokrates)
        (person MartinFrost Sweden Clarinet)
        (person Asahina Japan Clarinet)
     )
)

(deflexpr '(Haskeller ?X) '(like ?X Haskell))
(deflexpr '(die ?X) '(human ?X))
(deflexpr '(cl-player ?X ?Y) '(person ?X ?Y Clarinet))


で質問します


;Where was Martin born? 
(print (solve '(cl-player MartinFrost ?X)))

;Does Jhon like Lisp ?
(print (solve '(like Jhon Lisp)))

;Is Taylor a Haskeller ?
(print (solve '(Haskeller Taylor)))

;Who is Haskeller ?
(print (solve '(Haskeller ?X)))

;Does sokrates die ?
(print (solve '(die sokrates)))

;Who do die ?
(print (solve '(die ?X)))


参考にしたサイト
スポンサーサイト

comment 0 trackback 0
トラックバックURL
http://telracsmoratori.blog.fc2.com/tb.php/140-798f28a2
トラックバック
コメント
管理者にだけ表示を許可する
 
上記広告は1ヶ月以上更新のないブログに表示されています。新しい記事を書くことで広告を消せます。