[Javaowl-commit] reasoner/design reasoner.scm,NONE,1.1 draft.scm,1.1.1.1,1.2

[Gerardo H. <ma...@us...>]

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))))