Paste number 25354: Deduction as a CLIPS rule

Index of paste annotations: 2 | 1

Paste number 25354: Deduction as a CLIPS rule
Pasted by: Arnia
When:2 years, 9 months ago
Share:Tweet this! | http://paste.lisp.org/+JKA
Channel:#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 2: Whee deduction
Pasted by: Arnia
When:2 years, 9 months ago
Share:Tweet this! | http://paste.lisp.org/+JKA#2
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)))
)

Annotation number 1: Deduction for NAL in CLIPS
Pasted by: Arnia
When:2 years, 9 months ago
Share:Tweet this! | http://paste.lisp.org/+JKA#1
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))
)

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

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