;; This file requires Common Lisp and Babel2.
;; Please visit http://emergent-languages.org for the source code.

(asdf:operate 'asdf:load-op 'language-game-examples)

(in-package :fcg-user)

;; We create an agent who will perform the language tasks.
(defvar *agent* (make-instance 'fcg-agent))
(defvar *initial-structure-production* nil)
(defvar *initial-structure-parsing* nil)

;; Now we will add some rules to the agent.
;; ----------------------------------------

(let ((see-lex
       (make-rule :name 'see-lex
		  :type 'lex-stem
		  :left-pole `((?top-unit
				(meaning
				 (== (see ?ev true)
				     (see-1 ?ev ?obj-1)
				     (see-2 ?ev ?obj-2))))
			       ((J ?new-unit ?top-unit)
				(case-frame
				 (== (agent ?obj-1)
				     (patient ?obj-2)))))
		  :right-pole `((?top-unit
				 (syn-subunits (== ?new-unit)))
				(?new-unit
				 (form (== (stem ?new-unit "see")))
				 (syn-cat v)
				 (agr (== (person ?person) (number ?number)))))))
      (jack-lex 
       (make-rule :name 'jack-lex
		  :type 'lex-stem
		  :left-pole `((?top-unit
				(meaning
				 (== (unique-person jack))))
			       ((J ?new-unit ?top-unit)
				(referent jack)))
		  :right-pole `((?top-unit
				 (syn-subunits (== ?new-unit)))
				(?new-unit
				 (form (== (stem ?new-unit "jack")))
				 (syn-cat n)
				 (person 3)
				 (number sg)))))
      (jill-lex 
       (make-rule :name 'jill-lex
		  :type 'lex-stem
		  :left-pole `((?top-unit
				(meaning
				 (== (unique-person jill))))
			       ((J ?new-unit ?top-unit)
				(referent jill)))
		  :right-pole `((?top-unit
				 (syn-subunits (== ?new-unit)))
				(?new-unit
				 (form (== (stem ?new-unit "jill")))
				 (syn-cat n)
				 (number sg)
				 (person 3)))))
      (construction
       (make-rule :name 'simple-construction
		  :type 'con
		  :left-pole `((?top-unit
				(sem-subunits
				 (== ?subject-unit ?verb-unit ?object-unit)))
			       (?subject-unit
				(referent ?obj-1))
			       (?verb-unit
				(case-frame
				 (== (agent ?obj-1)
				     (patient ?obj-2))))
			       (?object-unit
				(referent ?obj-2)))
		  :right-pole `((?top-unit
				 (syn-subunits
				  (== ?subject-unit ?verb-unit ?object-unit))
				 (form
				  (== (precedes ?subject-unit ?verb-unit)
				      (precedes ?verb-unit ?object-unit))))
				(?subject-unit
				 (syn-cat n)
				 (person ?person)
				 (number ?number))
				(?verb-unit
				 (syn-cat v)
				 (agr (== (person ?person) (number ?number))))
				(?object-unit
				 (syn-cat n)))))
      (sees-morph
       (make-rule :name 'sees-morph
		  :type 'morph
		  :left-pole `((?top-unit
				(syn-subunits (== ?new-unit)))
			       (?new-unit
				(syn-cat v)
				(agr (== (number sg) (person 3)))
				(form (== (stem ?new-unit "see")))))
		  :right-pole `((?top-unit
				 (form (== (string ?new-unit "sees"))))
				((J ?new-unit ?top-unit)))))
      (jack-morph 
       (make-rule :name 'jack-morph
		  :type 'morph
		  :left-pole `((?top-unit
				(syn-subunits (== ?new-unit)))
			       (?new-unit
				(syn-cat n)
				(form (== (stem ?new-unit "jack")))
				(number sg)
				(person 3)))
		  :right-pole `((?top-unit
				 (form (== (string ?new-unit "Jack"))))
				((J ?new-unit ?top-unit)))))
      (jill-morph 
       (make-rule :name 'jill-morph
		  :type 'morph
		  :left-pole `((?top-unit
				(syn-subunits (== ?new-unit)))
			       (?new-unit
				(syn-cat n)
				(form (== (stem ?new-unit "jill")))
				(number sg)
				(person 3)))
		  :right-pole `((?top-unit
				 (form (== (string ?new-unit "Jill"))))
				((J ?new-unit ?top-unit))))))
  (add-rule *agent* jill-morph)
  (add-rule *agent* jack-morph)
  (add-rule *agent* sees-morph)
  (add-rule *agent* construction)
  (add-rule *agent* see-lex)
  (add-rule *agent* jack-lex)
  (add-rule *agent* jill-lex)
  (setf *initial-structure-production*
	(make-coupled-feature-structure
	 :left-pole `((top-unit
		       (meaning
			((see ev-1 true)
			 (see-1 ev-1 jack)
			 (see-2 ev-1 jill)
			 (unique-person jack)
			 (unique-person jill)))))
	 :right-pole `((top-unit))))
  (setf *initial-structure-parsing*
	(make-coupled-feature-structure
	 :left-pole `((top-unit))
	 :right-pole `((top-unit
			(form ((string see-unit "sees")
			       (string jack-unit "Jack")
			       (string jill-unit "Jill")
			       (precedes jack-unit see-unit)
			       (precedes see-unit jill-unit))))))))


(defun production-example ()
  (deactivate-all-monitors)
  (activate-monitor trace-process-execution)
  (clean-agent *agent*)
  (format t "~%Initial structure: ~% ~a~%~%" *initial-structure-production*)
  (let ((structure nil))
    (setf structure (apply-rule-set-once (get-rule-set *agent* 'lex-stem) 
					 *initial-structure-production* '->)) 
    (format t "~%~%~a~%~%" structure)
    (setf structure 
	  (apply-rule-set-once (get-rule-set *agent* 'con) 
			       (spec-current-structure (first structure)) '->))
    (format t "~%~%~a~%~%" structure)
    (setf structure 
	  (apply-rule-set-once (get-rule-set *agent* 'morph) 
			       (spec-current-structure (first structure)) '->))
    (format t "~%~%~a~%~%" structure)
    (render (right-pole (spec-current-structure (first structure))))))

(defun parsing-example ()
  (deactivate-all-monitors)
  (activate-monitor trace-process-execution)
  (clean-agent *agent*)
  (format t "~%Initial structure: ~% ~a~%~%" *initial-structure-parsing*)
  (let ((structure nil))
    (setf structure (apply-rule-set-once (get-rule-set *agent* 'morph) 
					 *initial-structure-parsing*
					 '<-))
    (format t "~%~%~a~%~%" structure)
    (setf structure 
	  (apply-rule-set-once (get-rule-set *agent* 'lex-stem) 
			       (spec-current-structure (first structure)) '<-))
    (format t "~%~%~a~%~%" structure)
    (setf structure 
	  (apply-rule-set-once (get-rule-set *agent* 'con) 
			       (spec-current-structure (first structure)) '<-))
    (format t "~%~%~a~%~%" structure)
    (extract-meanings (left-pole (spec-current-structure (first structure))))))
  
  
(setf *initial-structure-parsing*
      (make-coupled-feature-structure
       :left-pole `((top-unit))
       :right-pole `((top-unit
		      (form ((string see-unit "sees")
			     (string jack-unit "Jack")
			     (string jill-unit "Jill")
			     (precedes jill-unit see-unit)
			     (precedes see-unit jack-unit)))))))
(setf *initial-structure-production*
      (make-coupled-feature-structure
       :left-pole `((top-unit
		     (meaning
		      ((see ev-1 true)
		       (see-1 ev-1 jill)
		       (see-2 ev-1 jack)
		       (unique-person jack)
		       (unique-person jill)))))
       :right-pole `((top-unit))))