;;; File: silk-translator.lisp
;;; Author: Peter Clark
;;; Date: JUNE 19th 2010
;;; Purpose: First pass of the KM to SILK translator
;;; **NOTE** This code still needs to be documented!!

#|
USAGE:
1. Download km-2-5-1-packaged from www.cs.utexas.edu/users/mfkb/km/
   (Grab the packaged version)
2. Compile and load KM
3. Load this file
4. Do (setq *readtable* *km-readtable*)	; So that the dispatch macro #$ is recognized
5. Assert the demo of interest and run (translate-class <class>) 

USER: (load "km-2-5-1-packaged")
USER: (in-package :km)
KM: (setq *readtable* *km-readtable*)	; So that the dispatch macro #$ is recognized
KM: (load "silk-translator")
KM: (assert-demo1)
KM: (translate-all)

or 
KM: (demo-all)
|#

(in-package :km)

(eval-when (:execute :load-toplevel :compile-toplevel)
  (setq *readtable* *km-readtable*))	; So that the dispatch macro #$ is recognized

(defun cload (file) (load (excl:compile-file-if-needed file :print nil)))

(defvar *report-warnings* nil)

(defvar *equalities* nil)
(defvar *done* nil)

(defun translate-all () 
  (mapc #'translate-class 
	(sort (copy-list (get-all-concepts)) #'string< :key #'symbol-name)) ; all classes, in alphabetical order
  t)

;;; e.g., (translate-class '#$Eukaryotic-cell)
(defun translate-class (class)
  (let ((protoroots (get-vals class '#$prototypes)))
    (mapc #'(lambda (protoroot)
	      (translate-protoroot protoroot class))
	  protoroots)
    t))

(defun translate-protoroot (protoroot class)
  (cond
   ((>= (length (get-vals protoroot '#$prototype-participants)) 2) ; otherwise, prototype is vacuuous
    (km-format t "// ======================================================================~%")
    (km-format t "//                SILK REPRESENTATION OF ~a~%" class)
    (km-format t "// ======================================================================~%")
    (translate-to-silk protoroot))))

;;; ------------------------------

;;; [1] otherwise              KM: (translate-class '#$Cell-Cycle)
;;; might produce              _Mitotic-Phase37(?x)#Mitotic_Phase[subevent_of->?x#Cell_Cycle] :- ?x#Cell_Cycle ;  
;;; rather than the preferred  ?x[subevent->_Mitotic-Phase37(?x)#Mitotic_Phase] :- ?x#Cell_Cycle ;  
?x#Cell_Cycle] :- ?x#Cell_Cycle		;  
(defun translate-to-silk (protoroot)
  (let ((*print-right-margin* 9999))			; avoid undesirable <nl> when writing out
  (cond
   ((not (protorootp protoroot))
    (format t "ERROR! (translate-to-silk <x>) must be given a prototype root as an argument (instead was ~a)~%" protoroot))
   (t (setq *equalities* nil)		; crude method of collecting equalities 
      (setq *done* nil)			; crude method of recording what's been done so far
      (let* ((prototype-participants (get-vals protoroot '#$prototype-participants))
	     (ordered-prototype-participants 
	      (cons protoroot (remove protoroot prototype-participants))) ; protoroot first! [1]
	     (silk-expr-fragments-without-skolems (my-mapcan #'(lambda (instance)
							(translate-frame-to-silk instance :protoroot protoroot))
							     ordered-prototype-participants))
	     (silk-expr-fragments (mapcar #'add-skolem-functions silk-expr-fragments-without-skolems))
	     (silk-exprs (mapcar #'concat-list silk-expr-fragments)))
	(terpri)
	(cond (*equalities*
	       (mapc #'(lambda (equality)
			 (format t equality)
			 (terpri))
		     (remove-duplicates *equalities* :test #'string=))
	       (terpri)))
	(mapc #'nice-silk-print silk-exprs)
	t)))))

;;; (nice-silk-print <string>)
;;; Break and indent at "[" characters
;;; e.g., "cat[dog" -> "cat[
;;;                        dog"
(defun nice-silk-print (silk-string &key (tab 0) last-break-char)
  (let* ((n-square-bracket0 (search "[" silk-string))
	 (n-square-bracket (cond ((and n-square-bracket0 (> n-square-bracket0 4)) n-square-bracket0)))
	 (n-comma (search "," silk-string))
	 (break-char (cond ((and n-square-bracket n-comma)			
			    (cond ((< n-square-bracket n-comma) "[")
				  (t ",")))
			   (n-square-bracket "[")
			   (n-comma ","))))
    (cond
     (break-char (multiple-value-bind
		  (left right)
		  (split-at silk-string break-char)
		(format t "~v@t~a~a~%" tab left break-char)
		(nice-silk-print right :tab (cond ((and (string= break-char ",") (equal last-break-char ",")) tab)
						  (t (+ tab 4)))
				 :last-break-char break-char)))
     (t (format t "~v@t~a~%~%" tab silk-string)))))

;;; ======================================================================

; ?x[has-part->{_Engine1(?x)] :- ?x#Car	;
; _Engine1(?x)[has-part->{_Cylinder1(?x)] :- ?x#Car ;

(defun translate-frame-to-silk (instance &key protoroot)
  (let* ((slotsvals (get-slotsvals instance :situation *global-situation*)))
    (remove nil
     (mapcar #'(lambda (slotvals)
		(let ((slot (slot-in slotvals))
		      (vals (vals-in slotvals)))
		  (cond ((member slot (aura-slots-to-translate)) ; worth exploring
			 (let* ((silk-vals 
				 (remove nil
				  (mapcar #'(lambda (val)
					      (cond ((not (kb-objectp val))
						     (km-format t "// DEBUG: Don't know how to translate structure ~a to SILK (ignoring)~%" val))					       
						    ((not (member `(,val ,(invert-slot slot) ,instance) *done*
								  :test #'equal))
						     (push `(,instance ,slot ,val) *done*)
						     `(,val ,@(silk-classlist val)))))
					  vals)))
				(open-curly (cond ((>= (length silk-vals) 2) "{")
						  (t "")))
				(close-curly (cond ((>= (length silk-vals) 2) "}")
						   (t ""))))
			   (cond
			    (silk-vals
;			     (km-format t "silk-vals = ~a~%" silk-vals)
			     `(,instance 
			       ,@(cond ((neq instance protoroot) (silk-classlist instance)))
			       "[" ,(silk-string-for slot) "->" ,open-curly
			       ,@(apply #'append (insert-delimeter silk-vals '(",")))
			       ,close-curly 
			       "] :- ?x" ,@(silk-classlist protoroot) " ;"))))))))
	     slotsvals))))
				
(defun add-skolem-functions (fragments)
  (my-mapcan #'(lambda (fragment)
		 (cond ((stringp fragment) (list fragment))
		       ((kb-objectp fragment) (make-skolem-function fragment))
		       (t (format t "ERROR! Don't know what to do with fragment ~a!~%" fragment))))
	     fragments))

;;; ======================================================================
;;;		MAKING SKOLEM FUNCTIONS
;;; ======================================================================
#|
(make-skolem-function '#$_DNA2)
  _DNA2 -> cloned from _DNA1 -> in prototype _HChromosome1 -> has-clones _HChromosome2
  -> _DNA1(_HChromosome2(?x))
  ?x#Plant-Cell -> _nucleus03(?x)  = _nucleus01(?x).

GIVEN	
1.		   Atom1 -part-> Electron
2.     DNA -part-> Atom2
3.                 Atom3
		      cloned-from: Atom1, Atom2
THEN: Atom3 should have Skolem symbol Atom2		      

Example of looping:
	[[?x:Adenine]] --- Cytosine1(?x)
	Adenine1(?x) ---- [[?x:Cytosine]]
		?x:DNA
	      /      \
     Adenine07(?x)--- Cytosine07(?x)

make-skolem-function(adenine07) 
   -> adenine1(Cytosine07)
   -> adenine1(cytosine1(adenine07))
   -> adenine1(cytosine1(adenine1(cytosine07)))
   -> etc.	

How to handle loops: Add equalities:
  adenine07(x)  =  adenine01(cytosine07(x))
  cytosine07(x) = cytosine01( adenine07(x))
and leave adenine07(x), cytosine07(x) in the representation of DNA.

make-skolem-function adenine07 :done nil		 	  ; fn so far adenine01(...)
 -> make-skolem-function cytosine07 :done (adenine07)	 	  ; fn so far adenine01(cytosine01(...))
  ->  make-skolem-function adenine07 :done (cytosine07 adenine07) ; returns ?x for the filler. NEW returns NIL
      Looping detected!
      Returns 

Similarly below, except instead of Adenine07, Cytosine07 we have _Organic-Molecule3388, _Organic-Molecule3389
 0[4]: (MAKE-SKOLEM-FUNCTION |_Organic-Molecule3389|)
   1[4]: (MAKE-SKOLEM-FUNCTION |_Organic-Molecule3388| :DONE (|_Organic-Molecule3389|))
     2[4]: (MAKE-SKOLEM-FUNCTION |_Organic-Molecule3389| :DONE (|_Organic-Molecule3388| |_Organic-Molecule3389|))
// ERROR! Looping on make-skolem-function! Returning just "?x".
//    Done = (_Organic-Molecule3388 _Organic-Molecule3389)
     2[4]: returned ("?x")
   1[4]: returned ("_Pyrimidine34" "(" "?x" ")")
 0[4]: returned ("_Adenine2945" "(" "_Pyrimidine34" "(" "?x" ")" ")")
|#
;;; [1] adenine01(cytosine01(looping-detected)) -> adenine01(cytosine07(?x))
(defun make-skolem-function (instance)
  (let ((skolem-function (make-skolem-function0 instance)))
    (cond ((member 'looping-detected skolem-function)
	   (let* ((short-skolem-function `(,(symbol-name instance) "(?x)"))
		  (long-skolem-function (sublis `((looping-detected . "?x")) skolem-function))
		  (protoroot (get-unique-val instance '#$prototype-participant-of))	  
		  (classes (concat-list (silk-classlist protoroot))))
	     (push (format nil "~a :=: ~a :- ?x~a ;" 
			   (concat-list short-skolem-function) 
			   (concat-list long-skolem-function)
			   classes) *equalities*)
	     short-skolem-function))
	  (t skolem-function))))
			 
(defun make-skolem-function0 (instance &key done)
  (cond 
   ((not (anonymous-instancep instance)) (list (symbol-name instance)))
   ((protorootp instance) '("?x"))
   ((member instance done)
    (format t "// DEBUG: Looping on make-skolem-function0, with ~a~%" done)
    '(looping-detected))
   (t (let* ((protoroot (get-unique-val instance '#$prototype-participant-of))
	     (source-instances-with-protoroots (node-cloned-from-originally instance))
	     (source-instances (remove-if #'protorootp source-instances-with-protoroots)) ; Can ignore protoroots
	     (source-instance (first source-instances)))

	(cond ((>= (length source-instances) 2)
	       (mapcar #'(lambda (pair)
			   (let ((i1 (first pair))
				 (i2 (second pair))
				 (classes (concat-list (silk-classlist protoroot))))
			     (push (format nil "~a(?x) :=: ~a(?x) :- ?x~a ;" i1 i2 classes) *equalities*))) ; [1]
		       (all-adjacent-pairs source-instances))))		; (a b c d) -> ((a b) (b c) (c d))
	(cond
	 ((null source-instances) `(,(symbol-name instance) "(?x)"))
;	 ((protorootp source-instance) `(,(symbol-name instance) "(?x)"))
	 (t (let* ((source-protoroot (get-unique-val source-instance '#$prototype-participant-of))
		   (cloned-pairs (nodes-cloned-to (list source-protoroot source-instance)))
		   (protoroot-clones0 (remove nil (mapcar #'(lambda (cloned-protoroot+instance)
							     (cond ((eq (second cloned-protoroot+instance) instance)
								    (first cloned-protoroot+instance))))
							 cloned-pairs)))
		   (protoroot-clones (or protoroot-clones0
					 (remove-if-not #'(lambda (participant)		; fallback technique
							    (member source-protoroot (node-cloned-from* participant)))
							(get-vals protoroot '#$prototype-participants))))
		   (protoroot-clone 
		    (cond ((null protoroot-clones) nil)
			  ((singletonp protoroot-clones) (first protoroot-clones))
			  (t (let* ((clone+distances (mapcar #'(lambda (clone)
								 (list clone (shortest-distance-between instance clone)))
							     protoroot-clones))
				    (nearest-clone+distance (first (sort (copy-tree clone+distances) #'< :key #'second))))
			       (cond (*report-warnings*
				      (km-format t "// WARNING: clones+distances were ~a~%" clone+distances)))
			       (first nearest-clone+distance))))))
	      (cond ((and *report-warnings* (>= (length protoroot-clones) 2))
		     (km-format t "//      Instance ~a in ~a was cloned from ~a in ~a,~%"
				instance protoroot source-instance source-protoroot)
		     (km-format t "//      but the protoroot ~a has multiple clones ~a in ~a!~%"
				source-protoroot protoroot-clones protoroot)
		     (km-format t "//      I'll guess that the nearest one, ~a, is the relevant clone.~%"
				protoroot-clone)))
	      (cond ((null protoroot-clones)
		     (cond (*report-warnings*
			    (km-format t "// WARNING! protoinstance ~a was apparently cloned to ~a in ~a,~%"
				       source-instance instance protoroot)
			    (km-format t "//    but that protoinstance's protoroot ~a doesn't appear to~%"
				       source-protoroot)
			    (km-format t "//    have been cloned into ~a anywhere!~%" protoroot)))
		     (list (symbol-name instance)))		
		    (t (let* ((skolem-function (make-skolem-function0 protoroot-clone :done (cons instance done)))
			      (outer-instance (cond ((equal skolem-function '(looping-detected)) instance)
						       (t source-instance))))
			 `(,(symbol-name outer-instance) "(" ,@skolem-function ")")
			 ))))))))))

;;; ======================================================================
;;;			UTILITIES
;;; ======================================================================

(defun shortest-distance-between (i1 i2)
  (let ((key (intern (concat (symbol-name i1) (symbol-name i2)))))
    (or
     (get key 'shortest-distance)
     (let* ((shortest-path (shortest-path-between `((,i1)) i2))
	    (shortest-distance (cond (shortest-path (length shortest-path))
				     (t 999))))
       (setf (get key 'shortest-distance) shortest-distance)))))
	
(defun shortest-path-between (paths i2 &key done)
  (cond 
   ((endp paths) nil)
   ((eq (first (first paths)) i2) (first paths))
   (t (let* ((path (first paths))
	     (i1 (first path))
	     (slotsvals (get-slotsvals i1 :situation *global-situation*))
	     (new-paths (mapcan #'(lambda (slotvals)
				    (cond
				     ((member (slot-in slotvals) (aura-slots-to-translate))
				      (mapcan #'(lambda (val)
						  (cond ((and (anonymous-instancep val)
							      (not (member val done)))
							 `((,val ,@path)))))
					      (vals-in slotvals)))))
				slotsvals)))
;	(km-format t "i1 = ~a, slotsvals = ~a~%" i1 slotsvals)
;	(km-format t "new-paths = ~a~%" new-paths)
	(shortest-path-between (append (rest paths) new-paths) i2 :done (cons i1 done))))))
	  
;;; ----------

;;; _Nucleus1 -> ("#" "Nucleus")
;;; _Pet-Fish1 -> ("#" "(" "Pet" "," "Fish" ")")
(defun silk-classlist (instance)
  (let ((classes (remove-subsumers (get-vals instance '#$instance-of))))
    (cond ((null classes) nil)
	  (t `("#" ,@(insert-delimeter (mapcar #'silk-string-for classes) "#"))))))
;	  ((singletonp classes) `("#" ,(silk-string-for (first classes))))
;	  (t `("#" "(" ,(first classes) 
;		   ,@(mapcan #'(lambda (class) `("," ,(silk-string-for class))) (rest classes))
;		   ")" )))))

(defun silk-string-for (instance) (substitute #\_ #\- (symbol-name instance)))

(defun aura-slots-to-translate () 
  (cond ((fboundp 'aura-slots)
	 (aura-slots))
	(t '#$(has-part is-part-of encloses is-inside donor donor-of complement))))

;;; ======================================================================
;;;		DEMO KBs
;;; ======================================================================

;;; Assert demo example
(defun assert-demo1 ()
 (let ((*trace-prototype-assertions* nil))
  (mapc #'km '#$(
   (reset-kb)
   (has-part has (instance-of (Slot)) (inverse (is-part-of)))
   (encloses has (instance-of (Slot)) (inverse (is-inside)))
   (_Euk-Cell3 has
      (instance-of (Euk-Cell))
      (prototype-of (Euk-Cell))	
      (prototype-scope (Euk-Cell))	      
      (prototype-participants (_Euk-Cell3 _DNA3 _Nucleus3))
      (has-part (_DNA3 _Nucleus3))
      (prototype-participant-of (_Euk-Cell3)))

    (_DNA3 has 
	   (instance-of (DNA))
	   (is-part-of (_Euk-Cell3))
	   (is-inside (_Nucleus3))
	   (prototype-participant-of (_Euk-Cell3)))
    (_Nucleus3 has 
	       (instance-of (Nucleus))
	       (is-part-of (_Euk-Cell3))
	       (encloses (_DNA3))
	       (prototype-participant-of (_Euk-Cell3)))))))

(defun assert-demo2 ()
 (let ((*trace-prototype-assertions* nil))
  (mapc #'km '#$(
   (reset-kb)
   (has-part has (instance-of (Slot)) (inverse (is-part-of)))
   (encloses has (instance-of (Slot)) (inverse (is-inside)))

    ;;; EXAMPLE 2
    (_Cell4 has
      (instance-of (Cell))
      (prototype-of (Cell))	
      (prototype-scope (Cell))	
      (prototype-participants (_Cell4 _DNA4))
      (has-part (_DNA4))
      (has-clones (_Euk-Cell5))
      (has-built-clones (_Euk-Cell5))      
      (prototype-participant-of (_Cell4)))

    (_DNA4 has 
	   (instance-of (DNA))
	   (is-part-of (_Cell4))
	   (has-clones (_DNA5))
	   (prototype-participant-of (_Cell4)))

    (Euk-Cell has (superclasses (Cell)))    
    
    (_Euk-Cell5 has
		(instance-of (Euk-Cell))
		(prototype-of (Euk-Cell))	
      (prototype-scope (Euk-Cell))			
      (prototype-participants (_Euk-Cell5 _DNA5 _Nucleus5))
      (prototype-participant-of (_Euk-Cell5))
      (cloned-from (_Cell4))
      (cloned-built-from (_Cell4))
      (has-part (_DNA5 _Nucleus5)))

    (_DNA5 has 
	   (instance-of (DNA))
	   (is-part-of (_Euk-Cell5))
	   (is-inside (_Nucleus5))
	   (cloned-from (_DNA4))
	   (prototype-participant-of (_Euk-Cell5)))
    (_Nucleus5 has 
	       (instance-of (Nucleus))
	       (is-part-of (_Euk-Cell5))
	       (encloses (_DNA5))
	       (prototype-participant-of (_Euk-Cell5)))))))

(defun assert-demo3 ()
 (let ((*trace-prototype-assertions* nil))
  (mapc #'km '#$(
   (reset-kb)
   (has-part has (instance-of (Slot)) (inverse (is-part-of)))
   (encloses has (instance-of (Slot)) (inverse (is-inside)))
    ;;; EXAMPLE 3    
    (_HChromosome1 has 
	(instance-of (HChromosome))
	(prototype-of (HChromosome))
	(prototype-scope (HChromosome))
	(prototype-participants (_HChromosome1 _DNA1))
	(prototype-participant-of (_HChromosome1))
	(has-part (_DNA1))
	(has-clones (_HChromosome2))
	(has-built-clones (_HChromosome2)))    
    
    (_DNA1 has
	    (instance-of (DNA))
	    (is-part-of (_HChromosome1))
	    (prototype-participant-of (_HChromosome1))
	    (has-clones (_DNA2)))

    (_Crossing-Over1 has 
        (prototype-of (Crossing-Over))		     
        (prototype-scope (Crossing-Over))		     		     
        (instance-of (Crossing-Over))
	(prototype-participants (_Crossing-Over1 _HChromosome2 _DNA2))
	(prototype-participant-of (_Crossing-Over1))
	(donor (_HChromosome2)))

    (_HChromosome2 has
        (instance-of (HChromosome))
	(cloned-from (_HChromosome1))	   
	(cloned-built-from (_HChromosome1))	   
        (has-part (_DNA2))
	(prototype-participant-of (_Crossing-Over1)))

    (_DNA2 has 
        (instance-of (DNA))
	(cloned-from (_DNA1))
	(prototype-participant-of (_Crossing-Over1)))

    ))
  t))

(defun assert-demo4 ()
 (let ((*trace-prototype-assertions* nil))
  (mapc #'km '#$(
   (reset-kb)
   (has-part has (instance-of (Slot)) (inverse (is-part-of)))
   (encloses has (instance-of (Slot)) (inverse (is-inside)))
    ;;; EXAMPLE 3    
    (_HChromosome1 has 
	(instance-of (HChromosome))
	(prototype-of (HChromosome))
	(prototype-scope (HChromosome))
	(prototype-participants (_HChromosome1 _DNA1))
	(prototype-participant-of (_HChromosome1))
	(has-part (_DNA1))
	(has-clones (_HChromosome2))
	(has-built-clones (_HChromosome2)))    
    
    (_DNA1 has
	    (instance-of (DNA))
	    (is-part-of (_HChromosome1))
	    (prototype-participant-of (_HChromosome1))
	    (has-clones (_DNA2)))

    (_Crossing-Over1 has 
     (prototype-of (Crossing-Over))		     
        (prototype-scope (Crossing-Over))		     		     
        (instance-of (Crossing-Over))
	(prototype-participants (_Crossing-Over1 _HChromosome2 _HChromosome3 _DNA2 _DNA3))
	(prototype-participant-of (_Crossing-Over1))
	(donor (_HChromosome2 _HChromosome3)))

    (_HChromosome2 has
        (instance-of (HChromosome))
	(cloned-from (_HChromosome1))	   
	(cloned-built-from (_HChromosome1))	   
        (has-part (_DNA2))
	(prototype-participant-of (_Crossing-Over1)))

    (_DNA2 has 
        (instance-of (DNA))
	(cloned-from (_DNA1))
	(prototype-participant-of (_Crossing-Over1)))

    (_HChromosome3 has
        (instance-of (HChromosome))
	(cloned-from (_HChromosome1))	   
	(cloned-built-from (_HChromosome1))	   
        (has-part (_DNA3))
	(prototype-participant-of (_Crossing-Over1)))

    (_DNA3 has 
        (instance-of (DNA))
	(cloned-from (_DNA1))
	(prototype-participant-of (_Crossing-Over1)))
    ))
  t))

(defun assert-demo5 ()
 (let ((*trace-prototype-assertions* nil))
  (mapc #'km '#$(
   (reset-kb)
   (has-part has (instance-of (Slot)) (inverse (is-part-of)))
   (encloses has (instance-of (Slot)) (inverse (is-inside)))

    ;;; EXAMPLE 2
    (_Prok-Cell4 has
      (instance-of (Prok-Cell))
      (prototype-of (Prok-Cell))	
      (prototype-scope (Prok-Cell))	
      (prototype-participants (_Prok-Cell4 _DNA4))
      (has-part (_DNA4))
      (has-clones (_Spherical-Prok-Cell5))
      (has-built-clones (_Spherical-Prok-Cell5))      
      (prototype-participant-of (_Prok-Cell4)))

    (_DNA4 has 
	   (instance-of (DNA))
	   (is-part-of (_Prok-Cell4))
	   (has-clones (_DNA5))
	   (prototype-participant-of (_Prok-Cell4)))

    (_Spherical-Cell6 has
      (instance-of (Spherical-Cell))
      (prototype-of (Spherical-Cell))	
      (prototype-scope (Spherical-Cell))	
      (prototype-participants (_Spherical-Cell6 _DNA6))
      (has-part (_DNA6))
      (has-clones (_Spherical-Prok-Cell5))
      (has-built-clones (_Spherical-Prok-Cell5))      
      (prototype-participant-of (_Spherical-Cell6)))

    (_DNA6 has 
	   (instance-of (DNA))
	   (is-part-of (_Spherical-Cell6))
	   (has-clones (_DNA5))
	   (prototype-participant-of (_Spherical-Cell6)))

    (Spherical-Prok-Cell has (superclasses (Prok-Cell Spherical-Cell)))
    
    (_Spherical-Prok-Cell5 has
		(instance-of (Spherical-Prok-Cell))
		(prototype-of (Spherical-Prok-Cell))	
      (prototype-scope (Spherical-Prok-Cell))			
      (prototype-participants (_Spherical-Prok-Cell5 _DNA5))
      (prototype-participant-of (_Spherical-Prok-Cell5))
      (cloned-from (_Prok-Cell4 _Spherical-Cell6))
      (cloned-built-from (_Prok-Cell4 _Spherical-Cell6))
      (has-part (_DNA5 _Nucleus5)))

    (_DNA5 has 
	   (instance-of (DNA))
	   (is-part-of (_Spherical-Prok-Cell5))
	   (cloned-from (_DNA4 _DNA6))
	   (prototype-participant-of (_Spherical-Prok-Cell5)))
    )))
 t)

(defun assert-demo6 ()
 (let ((*trace-prototype-assertions* nil))
  (mapc #'km '#$(
   (reset-kb)
   (has-part has (instance-of (Slot)) (inverse (is-part-of)))
   (complement has (instance-of (Slot)) (inverse (complement)))
    ;;; EXAMPLE 3    
   (_Adenine1 has
	   (instance-of (Adenine))
	   (prototype-of (Adenine))
	   (prototype-scope (Adenine))
	   (prototype-participants (_Adenine1 _Cytosine1))
	   (complement (_Cytosine1))
	   (has-clones (_Adenine3))
	   (has-built-clones (_Adenine3))
	   (prototype-participant-of (_Adenine1)))
    (_Cytosine1 has
	   (instance-of (Cytosine))
	   (complement (_Adenine1))
	   (has-clones (_Cytosine3))
	   (prototype-participant-of (_Adenine1)))

   (_Cytosine2 has
	   (instance-of (Cytosine))
	   (prototype-of (Cytosine))
	   (prototype-scope (Cytosine))
	   (prototype-participants (_Cytosine2 _Adenine2))
	   (complement (_Adenine2))
	   (has-clones (_Cytosine3))
	   (has-built-clones (_Cytosine3))
	   (prototype-participant-of (_Cytosine2)))
    (_Adenine2 has
	   (instance-of (Adenine))
	   (complement (_Cytosine2))
	   (has-clones (_Adenine3))
	   (prototype-participant-of (_Cytosine2)))
    
    (_DNA3 has
	   (instance-of (DNA))
	   (prototype-of (DNA))
	   (prototype-scope (DNA))
	   (prototype-participants (_DNA3 _Cytosine3 _Adenine3))
	   (has-part (_Cytosine3 _Adenine3))
	   (prototype-participant-of (_DNA3)))
    
    (_Adenine3 has
	   (instance-of (Adenine))
	   (complement (_Cytosine3))
	   (is-part-of (_DNA3))
	   (cloned-from (_Adenine1 _Adenine2))
	   (clone-built-from (_Adenine1))
	   (prototype-participant-of (_DNA3)))
    
    (_Cytosine3 has
	   (instance-of (Cytosine))
	   (complement (_Adenine3))
	   (is-part-of (_DNA3))
	   (cloned-from (_Cytosine1 _Cytosine2))
	   (clone-built-from (_Cytosine2))
	   (prototype-participant-of (_DNA3)))
    
    
    )))
 t)

(defun demo-all ()
  (format t "~%// DEMO 1~%~%") (assert-demo1) (translate-all)
  (format t "~%// DEMO 2~%~%") (assert-demo2) (translate-all)
  (format t "~%// DEMO 3~%~%") (assert-demo3) (translate-all)
  (format t "~%// DEMO 4~%~%") (assert-demo4) (translate-all)
  (format t "~%// DEMO 5~%~%") (assert-demo5) (translate-all)
  (format t "~%// DEMO 6~%~%") (assert-demo6) (translate-all))