|
From: Gerardo H. <ma...@us...> - 2004-08-07 00:24:15
|
Update of /cvsroot/javaowl/reasoner/design In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv12965 Modified Files: draft.scm Added Files: reasoner.scm Log Message: Reasoner draft. Index: draft.scm =================================================================== RCS file: /cvsroot/javaowl/reasoner/design/draft.scm,v retrieving revision 1.1.1.1 retrieving revision 1.2 diff -C2 -d -r1.1.1.1 -r1.2 *** draft.scm 6 Aug 2004 16:48:44 -0000 1.1.1.1 --- draft.scm 7 Aug 2004 00:24:06 -0000 1.2 *************** *** 0 **** --- 1,55 ---- + ;($= C A) + ;($= C $TOP) + ;($= C $BOTTOM) + ;($= C ($intersection A B)) + ;($= C ($union A B)) + ;($= C ($complement A)) + ;($= C ($allValuesFrom R D)) + ;($= C ($someValuesFrom R D)) + ;($<= C D) + ;(R a b) + ;(C a) + + (define tbox1 + '(($= Woman ($intersection Person Female)) + ($= Woman2 Woman) + ($= Man ($intersection Person ($complement Woman2))) + ($= Mother ($intersection Woman ($someValuesFrom hasChild Person))) + ($= Father ($intersection Man ($someValuesFrom hasChild Person))) + ($= Parent ($union Father Mother)) + ($= Grandmother ($intersection Mother ($someValuesFrom hasChild Parent))))) + + (define tbox2 + '(($= Woman ($intersection Person Female)) + ($= Man ($intersection Person Male)) + ($= Mother ($intersection Woman ($allValuesFrom hasChild Person))) + ($= Father ($intersection Man ($allValuesFrom hasChild Person))))) + + (define tbox3 + '(($= Woman ($intersection Person Female)) + ($= Man ($intersection Person ($complement Female))) + ($= Undefined ($intersection Man Woman)) + ($= Test ($allValuesFrom hasChild Undefined)) + ($= Test2 ($allValuesFrom hasChild $TOP)))) + + ;(Woman x) + ;(Man y) + ;(Undefined z) + + (define abox1 + '((($intersection Person Female) x) + (($intersection Person ($complement Female)) y) + (($intersection Person Female ($complement Female)) z))) + + ;(($intersection Person Female) x) + ;(Person x) + ;(Female x) + ;(($intersection Person ($complement Female)) y) + ;(Person y) + ;(($complement Female) y) + ;(($intersection Person Female ($complement Female)) z) + ;(Person z) + ;(Female z) + ;(($complement Female) z) + + --- NEW FILE: reasoner.scm --- (require 'list-lib) (define (find-definition tbox predicate) (if (null? tbox) #f (if (predicate (car tbox)) (car tbox) (find-definition (cdr tbox) predicate)))) (define (definition? tbox-term) (equal? (first tbox-term) '$=)) (define (concept-definition? tbox-term concept) (and (definition? tbox-term) (equal? (second tbox-term) concept))) (define (get-concept-definition tbox concept) (let ((tbox-term (find-definition tbox (lambda (x) (concept-definition? x concept))))) (if tbox-term (third tbox-term) #f))) (define (replace-concept-definition tbox concept new-definition) (if (null? tbox) () (let ((tbox-term (car tbox)) (tbox-terms (cdr tbox))) (if (concept-definition? tbox-term concept) (cons `($= ,concept ,new-definition) tbox-terms) (cons tbox-term (replace-concept-definition tbox-terms concept new-definition)))))) (define (simplify definition) (letrec ((simplify-complement (lambda (concepts) `($complement ,@concepts))) (flatten-intersection (lambda (concepts) (if (null? concepts) () (let ((concept (car concepts)) (other-concepts (cdr concepts))) (if (and (pair? concept) (eq? (first concept) '$intersection)) (append (cdr concept) (flatten-intersection other-concepts)) (cons concept (flatten-intersection other-concepts))))))) (reduce-intersection (lambda (concepts) (cond ((memq '$BOTTOM concepts) '($BOTTOM)) ((null? concepts) ()) (#t (let ((concept (car concepts)) (other-concepts (cdr concepts))) (if (or (eq? concept '$TOP) (member concept other-concepts)) (reduce-intersection other-concepts) (cons concept (reduce-intersection other-concepts)))))))) (check-unary (lambda (concepts) (if (= (length concepts) 1) (first concepts) `($intersection ,@concepts)))) (simplify-intersection (lambda (concepts) (check-unary (reduce-intersection (flatten-intersection (map simplify concepts)))))) (simplify-allValuesFrom (lambda (concepts) (let ((sarg (simplify (second concepts))) (role (first concepts))) (cond ((and (pair? sarg) (eq? (first sarg) '$intersection)) `($intersection ,@(map (lambda (x) `($allValuesFrom ,role , x)) (cdr sarg)))) ((eq? sarg '$TOP) '$TOP) (#t `($allValuesFrom ,role ,sarg))))))) (if (symbol? definition) definition (let ((constr (car definition)) (concepts (cdr definition))) (cond ((eq? constr '$intersection) (simplify-intersection concepts)) ((eq? constr '$allValuesFrom) (simplify-allValuesFrom concepts)) ((eq? constr '$complement) (simplify-complement concepts)) (#t (error "unexpected constructor: " constr))))))) (define (expand-concept-definition tbox definition) (if (symbol? definition) (let ((expansion (get-concept-definition tbox definition))) (if expansion (expand-concept-definition tbox expansion) definition)) (cons (car definition) (map (lambda (x) (expand-concept-definition tbox x)) (cdr definition))))) (define (expand-tbox tbox) (letrec ((rec-expand-tbox (lambda (tbox exp-tbox) (if (null? tbox) exp-tbox (let ((tbox-term (car tbox)) (tbox-terms (cdr tbox))) (if (definition? tbox-term) (let* ((concept (second tbox-term)) (definition (third tbox-term)) (new-exp-tbox (replace-concept-definition exp-tbox concept (simplify (expand-concept-definition exp-tbox definition))))) (rec-expand-tbox tbox-terms new-exp-tbox)) (cons tbox-term (rec-expand-tbox tbox-terms exp-tbox)))))))) (rec-expand-tbox tbox tbox))) (define (apply-rules abox) (letrec ((apply-intersection (lambda (concepts instance r-abox) (if (null? concepts) r-abox (let* ((concept (car concepts)) (other-concepts (cdr concepts)) (term `(,concept ,instance))) (apply-intersection other-concepts instance (if (member term r-abox) r-abox (cons term r-abox))))))) (check-allValuesFrom (lambda (instances concept r-abox) (if (null? instances) r-abox (let* ((instance (car instances)) (other-instances (cdr instances)) (term `(,concept ,instance))) (check-allValuesFrom other-instances concept (if (member term r-abox) r-abox (cons term r-abox))))))) (apply-allValuesFrom (lambda (role-concept instance r-abox) (let ((role (first role-concept)) (concept (second role-concept))) (check-allValuesFrom (map third (filter (lambda (x) (and (equal? role (first x)) (eq? instance (second x)))) r-abox)) concept r-abox)))) (rec-apply-rules (lambda (abox r-abox) (if (null? abox) r-abox (let* ((term (car abox)) (concept (first term)) (instance (second term)) (terms (cdr abox))) (cond ((symbol? concept) (rec-apply-rules terms r-abox)) ((eq? (car concept) '$intersection) (rec-apply-rules terms (apply-intersection (cdr concept) instance r-abox))) ((eq? (car concept) '$allValuesFrom) (rec-apply-rules terms (apply-allValuesFrom (cdr concept) instance r-abox))) (#t (rec-apply-rules terms r-abox)))))))) (rec-apply-rules abox abox))) (define (consistent? abox) (not (has-contradiction? (apply-rules abox)))) |