Paste number 25354: Deduction as a CLIPS rule

Index of paste annotations: 1 | 2

Paste number 25354: Deduction as a CLIPS rule
Pasted by: Arnia
2 years, 4 months ago
#swhack
Paste contents:
Raw Source | XML | Display As
(defrule nal-1-deduction-jb
         ?judge <- (object (is-a JUDGEMENT)
                           (stm ?s1)
                           (freq ?f1)
                           (conf ?c1)
                           (justs $?jsts1)
                   )
         ?belief <- (object (is-a BELIEF)
                            (stm ?s2)
                            (freq ?f2)
                            (conf ?c2)
                            (justs $?jsts2)
                    )
         (object (is-a STATEMENT) (name =(instance-name ?s1))
                 (copula inherits)
                 (subj ?a) (pred ?b))
         (object (is-a STATEMENT) (name =(instance-name ?s2))
                 (copula inherits)
                 (subj ?b) (pred ?c))
         =>
         (bind ?freq (* ?f1 ?f2))
         (bind ?conf (* ?f1 ?c1 ?f2 ?c2))
         (bind ?stm (make-instance (gensym*) of STATEMENT
                                   (copula inherits)
                                   (subj ?a) (pred ?c)))
         (make-instance (gensym*) of JUDGEMENT
                        (stm ?stm)
                        (freq ?freq) (conf ?conf)
                        (justs ?jsts1 ?jsts2))
)

Annotations for this paste:

Annotation number 1: Deduction for NAL in CLIPS
Pasted by: Arnia
2 years, 4 months ago
Paste contents:
Raw Source | Display As
; A first hash of rules for NAL
; Nb. This will be split into a number of smaller files later

;; ----------------------------------------------
;; Constants
;; ----------------------------------------------

(defglobal ?*delete-time-delta* = 600.0)

;; ----------------------------------------------
;; Functions
;; ----------------------------------------------


;; ----------------------------------------------
;; Class definitions
;; ----------------------------------------------

(defclass STATEMENTSORT (is-a USER)
  (role abstract)
  (slot stm (type INSTANCE-NAME)) ; STATEMENT
)

(defclass BELIEFSORT (is-a USER)
  (role abstract)
  (slot freq (type FLOAT) (range 0.0 1.0) (default 1.0))
  (slot conf (type FLOAT) (range 0.0 1.0) (default 0.9))
  (multislot justs (type SYMBOL) (default (create$ (gensym*))))
)  

(defclass TASK (is-a STATEMENTSORT)
  (role abstract)
  (slot delete-time (type FLOAT) (default (+ ?*delete-time-delta* (time))))
)

(defclass TERM (is-a USER)
  (role abstract)
)

(defclass BELIEF (is-a BELIEFSORT STATEMENTSORT)
  (role concrete)
  (pattern-match reactive)
)

(defclass JUDGEMENT (is-a BELIEFSORT TASK)
  (role concrete)
  (pattern-match reactive)
)

(defclass QUESTION (is-a TASK)
  (role concrete)
  (pattern-match reactive)
  (slot asker (type STRING) (default ""))
  (slot best-e (type FLOAT) (range 0.0 1.0) (default 0.0))
)

(defclass STATEMENT (is-a TERM)
  (role concrete)
  (pattern-match reactive)
  (slot copula (type SYMBOL)
        (allowed-symbols inherits similar implies equiv)
        (default inherits)
  )
  (slot subj (type INSTANCE-NAME)) ; TERM
  (slot pred (type INSTANCE-NAME)) ; TERM
)

(defclass ATOMTERM (is-a TERM)
  (role concrete)
  (pattern-match reactive)
  (slot label (type LEXEME))
)

;; ----------------------------------------------
;; EXAMPLES
;; ----------------------------------------------

(definstances SYLLOGISM
    (dogterm of ATOMTERM (label dog))
    (mammalterm of ATOMTERM (label mammal))
    (animalterm of ATOMTERM (label animal))
    (dogmammalstm of STATEMENT (copula inherits)
                  (subj [dogterm])
                  (pred [mammalterm]))
    (mammalanimalstm of STATEMENT (copula inherits)
                     (subj [mammalterm])
                     (pred [animalterm]))
    (dmjudge of JUDGEMENT
             (stm [dogmammalstm])
             (freq 0.9) (conf 0.9))
    (mabelief of BELIEF
              (stm [mammalanimalstm])
              (freq 0.9) (conf 0.9))
)

;; ----------------------------------------------
;; Maintainance rules
;; ----------------------------------------------

(defrule maint-delete-old-judgement
         ?task <- (object (is-a JUDGEMENT)
                          (delete-time ?t)
                          (stm ?s)
                          (freq ?f)
                          (conf ?c)
                          (justs $?jsts))
         (test (< ?t (time)))
         =>
         (make-instance (gensym*) of BELIEF
                        (stm ?s)
                        (freq ?f)
                        (conf ?c)
                        (justs ?jsts))
         (unmake-instance ?task))

(defrule maint-delete-old-task
         ?task <- (object (is-a QUESTION)
                          (delete-time ?t)
                          (stm ?s)
         (test (< ?t (time)))
         =>
         (unmake-instance ?task))


;; ----------------------------------------------
;; NAL-1 inference rules
;; ----------------------------------------------


;; Deduction

(defrule nal-1-deduction-jb1
         ?judge <- (object (is-a JUDGEMENT)
                           (stm ?s1)
                           (freq ?f1)
                           (conf ?c1)
                           (justs $?jsts1)
                   )
         ?belief <- (object (is-a BELIEF)
                            (stm ?s2)
                            (freq ?f2)
                            (conf ?c2)
                            (justs $?jsts2)
                    )
         (object (is-a STATEMENT) (name ?s1)
                 (copula inherits)
                 (subj ?a) (pred ?b))
         (object (is-a STATEMENT) (name ?s2)
                 (copula inherits)
                 (subj ?b) (pred ?c))
         =>
         (bind ?freq (* ?f1 ?f2))
         (bind ?conf (* ?f1 ?c1 ?f2 ?c2))
         (bind ?stm (make-instance (gensym*) of STATEMENT
                                   (copula inherits)
                                   (subj ?a) (pred ?c)))
         (modify-instance ?judge
                          (delete-time (+ ?*delete-time-delta* (time))))
         (make-instance (gensym*) of JUDGEMENT
                        (stm (instance-name ?stm))
                        (freq ?freq) (conf ?conf)
                        (justs ?jsts1 ?jsts2))
)

(defrule nal-1-deduction-jb2
         ?judge <- (object (is-a JUDGEMENT)
                           (stm ?s1)
                           (freq ?f1)
                           (conf ?c1)
                           (justs $?jsts1)
                   )
         ?belief <- (object (is-a BELIEF)
                            (stm ?s2)
                            (freq ?f2)
                            (conf ?c2)
                            (justs $?jsts2)
                    )
         (object (is-a STATEMENT) (name ?s1)
                 (copula inherits)
                 (subj ?b) (pred ?c))
         (object (is-a STATEMENT) (name ?s2)
                 (copula inherits)
                 (subj ?a) (pred ?b))
         =>
         (bind ?freq (* ?f1 ?f2))
         (bind ?conf (* ?f1 ?c1 ?f2 ?c2))
         (bind ?stm (make-instance (gensym*) of STATEMENT
                                   (copula inherits)
                                   (subj ?a) (pred ?c)))
         (modify-instance ?judge
                          (delete-time (+ ?*delete-time-delta* (time))))
         (make-instance (gensym*) of JUDGEMENT
                        (stm (instance-name ?stm))
                        (freq ?freq) (conf ?conf)
                        (justs ?jsts1 ?jsts2))
)

Annotation number 2: Whee deduction
Pasted by: Arnia
2 years, 4 months ago
Paste contents:
Raw Source | Display As
; A first hash of rules for NAL
; Nb. This will be split into a number of smaller files later

;; ----------------------------------------------
;; Constants
;; ----------------------------------------------

(defglobal ?*delete-time-delta* = 600.0)

(assert (tick)) ; Tick-tock, keep watching for out-of-date tasks

;; ----------------------------------------------
;; Functions
;; ----------------------------------------------

(deffun non-overlapping (?$x ?$y)


;; ----------------------------------------------
;; Class definitions
;; ----------------------------------------------

(defclass STATEMENTSORT (is-a USER)
  (role abstract)
  (slot stm (type INSTANCE-NAME)) ; STATEMENT
)

(defclass BELIEFSORT (is-a USER)
  (role abstract)
  (slot freq (type FLOAT) (range 0.0 1.0) (default 1.0))
  (slot conf (type FLOAT) (range 0.0 1.0) (default 0.9))
  (multislot justs (type SYMBOL) (default-dynamic (gensym*)))
)  

(defclass TASK (is-a STATEMENTSORT)
  (role abstract)
  (slot delete-time (type FLOAT) (default-dynamic (+ ?*delete-time-delta* (time))))
)

(defclass TERM (is-a USER)
  (role abstract)
)

(defclass BELIEF (is-a BELIEFSORT STATEMENTSORT)
  (role concrete)
  (pattern-match reactive)
)

(defclass JUDGEMENT (is-a BELIEFSORT TASK)
  (role concrete)
  (pattern-match reactive)
)

(defclass QUESTION (is-a TASK)
  (role concrete)
  (pattern-match reactive)
  (slot asker (type STRING) (default ""))
  (slot best-e (type FLOAT) (range 0.0 1.0) (default 0.0))
)

(defclass STATEMENT (is-a TERM)
  (role concrete)
  (pattern-match reactive)
  (slot copula (type SYMBOL)
        (allowed-symbols inherits similar implies equiv)
        (default inherits)
  )
  (slot subj (type INSTANCE-NAME)) ; TERM
  (slot pred (type INSTANCE-NAME)) ; TERM
)

(defclass ATOMTERM (is-a TERM)
  (role concrete)
  (pattern-match reactive)
  (slot label (type LEXEME))
)

;; ----------------------------------------------
;; EXAMPLES
;; ----------------------------------------------

(definstances SYLLOGISM
    (dogterm of ATOMTERM (label dog))
    (mammalterm of ATOMTERM (label mammal))
    (animalterm of ATOMTERM (label animal))
    (dogmammalstm of STATEMENT (copula inherits)
                  (subj [dogterm])
                  (pred [mammalterm]))
    (mammalanimalstm of STATEMENT (copula inherits)
                     (subj [mammalterm])
                     (pred [animalterm]))
    (dmjudge of JUDGEMENT
             (stm [dogmammalstm])
             (freq 0.9) (conf 0.9))
    (mabelief of BELIEF
              (stm [mammalanimalstm])
              (freq 0.9) (conf 0.9))
)

;; ----------------------------------------------
;; Maintainance rules
;; ----------------------------------------------

(defrule maint-delete-old-judgement
         ?tk <- (tick)
         ?task <- (object (is-a JUDGEMENT)
                          (delete-time ?t)
                          (stm ?s)
                          (freq ?f)
                          (conf ?c)
                          (justs $?jsts))
         (test (< ?t (time)))
         =>
         (retract ?tk)
         (assert (tick))
         (make-instance (gensym*) of BELIEF
                        (stm ?s)
                        (freq ?f)
                        (conf ?c)
                        (justs ?jsts))
         (unmake-instance ?task))

(defrule maint-delete-old-question
         ?tk <- (tick)
         ?task <- (object (is-a QUESTION)
                          (delete-time ?t)
                          (stm ?s))
         (test (< ?t (time)))
         =>
         (retract ?tk)
         (assert (tick))
         (unmake-instance ?task))

;; ----------------------------------------------
;; Revision and Choice
;; ----------------------------------------------

(defrule revision-jb
         ?judge <- (object (is-a JUDGEMENT)
                           (stm ?s1)
                           (freq ?f1)
                           (conf ?c1)
                           (justs $?justs1))
         ?belief <- (object (is-a BELIEF)
                            (stm ?s2)
                            (freq ?f2)
                            (conf ?c2)
                            (justs $?justs2))
         (test (non-overlap ?justs1 ?justs2))
         (object (is-a STATEMENT) (name ?s1)
                 (subj ?a) (pred ?b) (copula ?cop))
         (object (is-a STATEMENT) (name ?s2)
                 (subj ?a) (pred ?b) (copula ?cop))
         =>
         (bind ?freq (/ (+ (* ?f1 ?c1 (- 1 ?c2))
                           (* ?f2 ?c2 (- 1 ?c1)))
                        (+ (* ?c1 (- 1 ?c2))
                           (* ?c2 (- 1 ?c1)))))
         (bind ?conf (/ (+ (* ?c1 (- 1 ?c2))
                           (* ?c2 (- 1 ?c1)))
                        (+ (* ?c1 (- 1 ?c2))
                           (* ?c2 (- 1 ?c1))
                           (* (-1 ?c1) (-1 ?c2)))))
         (make-instance (gensym*) of JUDGEMENT
                        (stm ?s1)
                        (freq ?freq) (conf ?conf)
                        (justs ?justs1 ?justs2)))


;; ----------------------------------------------
;; NAL-1 inference rules
;; ----------------------------------------------

; General scheme is that each inference rule requires 2T CLIPS rules
; to encode it (2 antecedent permutations for T task types).

;; Deduction

(defrule nal-1-deduction-jb1
         ?judge <- (object (is-a JUDGEMENT)
                           (stm ?s1)
                           (freq ?f1)
                           (conf ?c1)
                           (justs $?jsts1)
                   )
         ?belief <- (object (is-a BELIEF)
                            (stm ?s2)
                            (freq ?f2)
                            (conf ?c2)
                            (justs $?jsts2)
                    )
         (object (is-a STATEMENT) (name ?s1)
                 (copula inherits)
                 (subj ?a) (pred ?b))
         (object (is-a STATEMENT) (name ?s2)
                 (copula inherits)
                 (subj ?b) (pred ?c))
         =>
         (bind ?freq (* ?f1 ?f2))
         (bind ?conf (* ?f1 ?c1 ?f2 ?c2))
         (bind ?stm (make-instance (gensym*) of STATEMENT
                                   (copula inherits)
                                   (subj ?a) (pred ?c)))
         (modify-instance ?judge
                          (delete-time (+ ?*delete-time-delta* (time))))
         (make-instance (gensym*) of JUDGEMENT
                        (stm (instance-name ?stm))
                        (freq ?freq) (conf ?conf)
                        (justs ?jsts1 ?jsts2))
)

(defrule nal-1-deduction-jb2
         ?judge <- (object (is-a JUDGEMENT)
                           (stm ?s1)
                           (freq ?f1)
                           (conf ?c1)
                           (justs $?jsts1)
                   )
         ?belief <- (object (is-a BELIEF)
                            (stm ?s2)
                            (freq ?f2)
                            (conf ?c2)
                            (justs $?jsts2)
                    )
         (object (is-a STATEMENT) (name ?s1)
                 (copula inherits)
                 (subj ?b) (pred ?c))
         (object (is-a STATEMENT) (name ?s2)
                 (copula inherits)
                 (subj ?a) (pred ?b))
         =>
         (bind ?freq (* ?f1 ?f2))
         (bind ?conf (* ?f1 ?c1 ?f2 ?c2))
         (bind ?stm (make-instance (gensym*) of STATEMENT
                                   (copula inherits)
                                   (subj ?a) (pred ?c)))
         (modify-instance ?judge
                          (delete-time (+ ?*delete-time-delta* (time))))
         (make-instance (gensym*) of JUDGEMENT
                        (stm (instance-name ?stm))
                        (freq ?freq) (conf ?conf)
                        (justs ?jsts1 ?jsts2))
)

(defrule nal-1-deduction-qb1
         ?quest <- (object (is-a QUESTION)
                           (stm ?s1)
                   )
         ?belief <- (object (is-a BELIEF)
                            (stm ?s2)
                    )
         (object (is-a STATEMENT) (name ?s1)
                 (copula inherits)
                 (subj ?a) (pred ?b))
         (object (is-a STATEMENT) (name ?s2)
                 (copula inherits)
                 (subj ?b) (pred ?c))
         =>
         (bind ?stm (make-instance (gensym*) of STATEMENT
                                   (copula inherits)
                                   (subj ?a) (pred ?c)))
         (modify-instance ?quest
                          (delete-time (+ ?*delete-time-delta* (time))))
         (make-instance (gensym*) of QUESTION
                        (stm (instance-name ?stm)))
)

(defrule nal-1-deduction-qb2
         ?quest <- (object (is-a QUESTION)
                           (stm ?s1)
                   )
         ?belief <- (object (is-a BELIEF)
                            (stm ?s2)
                    )
         (object (is-a STATEMENT) (name ?s1)
                 (copula inherits)
                 (subj ?b) (pred ?c))
         (object (is-a STATEMENT) (name ?s2)
                 (copula inherits)
                 (subj ?a) (pred ?b))
         =>
         (bind ?stm (make-instance (gensym*) of STATEMENT
                                   (copula inherits)
                                   (subj ?a) (pred ?c)))
         (modify-instance ?quest
                          (delete-time (+ ?*delete-time-delta* (time))))
         (make-instance (gensym*) of QUESTION
                        (stm (instance-name ?stm)))
)

Colorize as:
Show Line Numbers
Index of paste annotations: 1 | 2

Lisppaste pastes can be made by anyone at any time. Imagine a fearsomely comprehensive disclaimer of liability. Now fear, comprehensively.