javaowl-commit

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

Update of /cvsroot/javaowl/reasoner/design
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv11171

Modified Files:
	draft.scm reasoner.scm 
Added Files:
	AL-Reasoner.scm 
Log Message:
Working AL reasoner.


Index: draft.scm
===================================================================
RCS file: /cvsroot/javaowl/reasoner/design/draft.scm,v
retrieving revision 1.6
retrieving revision 1.7
diff -C2 -d -r1.6 -r1.7
*** draft.scm	7 Aug 2004 03:18:00 -0000	1.6
--- draft.scm	7 Aug 2004 04:06:31 -0000	1.7
***************
*** 7,10 ****
--- 7,11 ----
  ;($= C ($allValuesFrom R D))
  ;($= C ($someValuesFrom R D))
+ ;($= C ($someValue R))
  ;($<= C D)
  ;(R a b)
***************
*** 54,55 ****
--- 55,67 ----
      (Childless Gerardo)))
  
+ (define tbox6
+   '(($= Woman ($intersection Person Female))
+     ($= Man ($intersection Person ($complement Female)))
+     ($= Childless ($allValuesFrom hasChild $BOTTOM))
+     ($= Parent ($someValue hasChild))))
+ 
+ (define abox6
+   '((Parent Gerardo)
+     (Childless Gerardo)))
+ 
+ 

Index: reasoner.scm
===================================================================
RCS file: /cvsroot/javaowl/reasoner/design/reasoner.scm,v
retrieving revision 1.4
retrieving revision 1.5
diff -C2 -d -r1.4 -r1.5
*** reasoner.scm	7 Aug 2004 03:18:00 -0000	1.4
--- reasoner.scm	7 Aug 2004 04:06:31 -0000	1.5
***************
*** 75,79 ****
                     `($intersection ,@(map (lambda (x) `($allValuesFrom ,role , x)) (cdr sarg))))
                    ((eq? sarg '$TOP) '$TOP)
!                   (#t `($allValuesFrom ,role ,sarg)))))))
      
      (if (symbol? definition)
--- 75,83 ----
                     `($intersection ,@(map (lambda (x) `($allValuesFrom ,role , x)) (cdr sarg))))
                    ((eq? sarg '$TOP) '$TOP)
!                   (#t `($allValuesFrom ,role ,sarg))))))
! 
!        (simplify-someValue
!         (lambda (role)
!           `($someValue ,@role))))
      
      (if (symbol? definition)
***************
*** 84,87 ****
--- 88,92 ----
                  ((eq? constr '$allValuesFrom) (simplify-allValuesFrom concepts))
                  ((eq? constr '$complement) (simplify-complement concepts))
+                 ((eq? constr '$someValue) (simplify-someValue concepts))
                  (#t (error "unexpected constructor: " constr)))))))
        
***************
*** 144,147 ****
--- 149,161 ----
                                                                       (equal? instance (second x)))) r-abox))
                                   concept r-abox))))
+ 
+        (apply-someValue
+         (lambda (role instance r-abox)
+           (let ((roles (filter (lambda (x) (and (equal? role (first x))
+                                                 (equal? instance (second x)))) r-abox)))
+             (if (= (length roles) 0)
+                 (let ((tmp (gentemp)))
+                   (apply-rules `(($TOP ,tmp) (,role ,instance ,tmp) ,@r-abox)))
+                 r-abox))))
          
          (apply-concept
***************
*** 167,170 ****
--- 181,186 ----
                        ((eq? (car concept) '$allValuesFrom)
                         (rec-apply-rules terms (apply-allValuesFrom (cdr concept) instance r-abox)))
+                       ((eq? (car concept) '$someValue)
+                        (rec-apply-rules terms (apply-someValue (second concept) instance r-abox)))
                        (#t (rec-apply-rules terms (apply-concept concept instance r-abox)))))))))
      (rec-apply-rules abox abox)))

--- NEW FILE: AL-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))))))

       (simplify-someValue
        (lambda (role)
          `($someValue ,@role))))
    
    (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))
                ((eq? constr '$someValue) (simplify-someValue 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))))))))
    (cons '($= $BOTTOM ($complement $TOP)) (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
                                                                (apply-rules (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
                                                                 (apply-rules (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))
                                                                     (equal? instance (second x)))) r-abox))
                                 concept r-abox))))

       (apply-someValue
        (lambda (role instance r-abox)
          (let ((roles (filter (lambda (x) (and (equal? role (first x))
                                                (equal? instance (second x)))) r-abox)))
            (if (= (length roles) 0)
                (let ((tmp (gentemp)))
                  (apply-rules `(($TOP ,tmp) (,role ,instance ,tmp) ,@r-abox)))
                r-abox))))
        
        (apply-concept
         (lambda (concept instance r-abox)
           (if (not (eq? concept '$TOP))
               (cons `($TOP ,instance) r-abox)
               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)
                       (if (= (length term) 3)
                           (rec-apply-rules terms r-abox)
                           (rec-apply-rules terms (apply-concept concept instance 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)))
                      ((eq? (car concept) '$someValue)
                       (rec-apply-rules terms (apply-someValue (second concept) instance r-abox)))
                      (#t (rec-apply-rules terms (apply-concept concept instance r-abox)))))))))
    (rec-apply-rules abox abox)))

(define (has-contradiction? abox)
  (letrec
      ((complement
        (lambda (t)
          (let ((concept (first t))
                (instance (second t)))
            (cond ((symbol? concept) `(($complement ,concept) ,instance))
                  (#t `(,(second concept) ,instance))))))
       (base-concept?
        (lambda (c)
          (or (symbol? c)
              (eq? (first c) '$complement)))))

    (if (null? abox)
        #f
        (let ((term (car abox))
              (terms (cdr abox)))
          (if (= (length term) 3)
              (has-contradiction? terms)
              (if (and (base-concept? (first term))
                       (member (complement term) terms))
                  #t
                  (has-contradiction? terms)))))))

(define (consistent? abox)
  (not (has-contradiction? (apply-rules abox))))

(define (expand-wrt-tbox abox tbox)
  (letrec
      ((etbox (expand-tbox tbox))

       (rec-expand-wrt-tbox
        (lambda (abox eabox)
          (if (null? abox)
              eabox
              (let ((term (car abox))
                    (other-terms (cdr abox)))
                (if (= (length term) 2)
                    (rec-expand-wrt-tbox other-terms
                                         (cons `(,(simplify (expand-concept-definition etbox (first term)))
                                                 ,(second term))
                                               eabox))
                    (rec-expand-wrt-tbox other-terms (cons term eabox))))))))

    (rec-expand-wrt-tbox abox ())))

(define (consistent-wrt-tbox? abox tbox)
  (consistent? (expand-wrt-tbox abox tbox)))