;; First we define some helper functions that are not immediately
;; related but will proof useful later on. I only include it to be
;; able to run the language game code below (since it will use this
;; functionality). My advise is to skip to Question 1.

(defun shuffle (l)
  (declare (list l))
  (dotimes (i (length l) l)
    (rotatef (elt l (random (length l)))
	     (elt l (random (length l))))))

(defun random-elt (l)
  (declare (list l))
  (unless (null l)
    (elt l (random (length l)))))

(defun random-elts (seq n)
  (declare (list seq) (fixnum n))
  (subseq (shuffle seq) 0 n))

(defun random-elt-if (predicate list)
  "Returns a random element that satisfies the predicate"
  (random-elt (remove-if-not predicate list)))

(defvar *vowels* '("a" "e" "i" "o" "u"))
(defvar *consonants* '("b" "d" "f" "g" "k" "l" "m" "n" "p" "r" "s" "t" "v" "w" "x" "z"))
(defvar *words-so-far* nil)

(defun random-syllable ()
  (format nil "~a~a"
          (random-elt *consonants*)
          (random-elt *vowels*)))

(defun random-word (&optional (nof-syllables 3))
  (format nil "~{~a~}"
          (loop for i from 1 to nof-syllables
	     collect (random-elt *consonants*)
	     collect (random-elt *vowels*))))

(defun make-new-word ()
  (loop for word = (random-word)
     unless (member word *words-so-far*)
     do (setf *words-so-far* (push word *words-so-far*))
       (return word)))


;; Question 1. Without thinking of implementations, what abstractions
;; (data structures) and functionality (functions) do we need? Put
;; picture next to it.

;; - agent
;; - lex
;; - world
;; - objects

;; - run-experiment
;; - play-game
;; - pick-topic (done by speaker)
;; - produce-utterance (dony by speaker)
;; - interpret-utterance (done by hearer)
;; - point (hearer)
;; - compare-pointing (speaker)
;; - point (speaker)
;; - interpet-pointing (hearer)

(defun run-experiment (nr-of-games)
  "Allows one to play a series of language games."
  
  )

(defun play-game (speaker hearer)
  "A game consists of a particular interaction pattern."
  
  )

;; implement agent, lex, add-lex

(defstruct agent
  "An agent has an ID and a long-term associative memory called its
lexicon."
  (id (make-id "AGENT") 
      :type (or symbol fixnum))
  (lexicon nil
	   :type list))

(defstruct lex
  "A lex is an association of a form with a meaning. It also has a
score reflecting the success of the lex."
  (form "" :type string)
  (meaning nil :type symbol)
  (score 0.0 :type number))

(defun add-lex (agent form meaning)
  "Creates a lex from the given form and meaning and adds it to the
lexicon of the agent."
  (format t "~%~a adds association of form ~a with meaning ~a to its lexicon."
	  (agent-id agent) form meaning)
  (let ((lex (make-lex :form form
		       :meaning meaning
		       :score 0.5)))
    (push lex (agent-lexicon agent))))

(defun create-population (nr-of-agents)
  "A population is simply a list of agents. The size of the population
will be equal to the parameter nr-of-agents."
  (loop for i from 1 to nr-of-agents
     collect (make-agent)))

(defparameter *population* (create-population 2))

(defun create-unique-object ()
  "We model a unique object as simple as possible. It is just a
symbol."
  (make-id "u-object"))

(defun create-world (nr-of-objects)
  "A world is simply a list of unique objects. The size of the world
is nr-of-objects."
  (loop for i from 1 to nr-of-objects
     collect (create-unique-object)))

(defparameter *world* (create-world 10))

;; There are some other things we cannot model as local to the agents,
;; this is the utterance, the context and the pointed-object. In
;; contrast with the population and the world these will change every
;; game.

(defparameter *context* nil)
(defparameter *utterance* "")
(defparameter *pointed-object* nil)

(defun generate-context (context-size)
  "A context is a random subset of the individuals of the world. 
It is first asserted that the requested context-size is not 
larger than the world."
  (assert (<= context-size (length *world*))) 
  (setf *context* (random-elts *world* context-size))
  (format t "~%context: ~a" *context*))

;; The lexicon of the agent is then a list of lex's.  For now we are
;; set, and start implementing first functionality.

;; Now fill in run-experiment

(defun run-experiment (nr-of-games)
  (loop for i from 1 to nr-of-games
     for speaker = (random-elt *population*)
     for hearer = (random-elt-if #'(lambda (agent)
				     (not (equal agent speaker))) *population*)
     do (generate-context (incf (random 4))) ;; we do incf because we don't want 0
       (play-game speaker hearer)))

;; Then implement play-game

(defun play-game (speaker hearer)
  (format t "~%-----~%Starting new game:~% -speaker: ~a~% -hearer: ~a" 
	  (agent-id speaker) (agent-id hearer))
  (pick-topic speaker)
  (produce speaker)
  (interpret hearer)
  (point hearer)
  (pointing-correct? speaker)
  (point speaker))

;; Implement pick-topic, (simple) produce, interpet, point, pointing-correct?

(defun pick-topic (agent)
  "Picking a topic from the context is just taking a random element
from the context."
  (let ((topic (random-elt *context*)))
    (format t "~%~a has chosen topic: ~a" (agent-id agent) topic)
    ;; problem: where are we going to remember the chosen topic?
    ;; answer: create a slot for it in agent
    (setf (agent-topic agent) topic)))

(defstruct agent
  "An agent has an ID and a long-term associative memory called its
lexicon. It also has a short-term memory for remembering the chosen
topic."
  (id (make-id "AGENT") 
      :type (or symbol fixnum))
  (lexicon nil
	   :type list)
  (topic nil
	 :type symbol))

;; We have to make sure that the memory of the topic is reset at the
;; beginning of every game.

(defun clear-short-term-memory (agent)
  (setf (agent-topic agent) nil)
  (setf *utterance* "")
  (setf *pointed-object* nil))

(defun run-experiment (nr-of-games)
  (loop for i from 1 to nr-of-games
     for speaker = (random-elt *population*)
     for hearer = (random-elt-if #'(lambda (agent)
				     (not (equal agent speaker))) *population*)
     do (generate-context (random 5))       
       (clear-short-term-memory speaker)
       (clear-short-term-memory hearer)
       (play-game speaker hearer)))


(defun produce (agent)
  "Producing in this case simply consists of looking up the form for
the chosen topic. This function has no way to deal with the situation
in which the agent does not yet have a form."
  (let ((lex (find (agent-topic agent) (agent-lexicon agent)
		   :key #'lex-meaning)))
    (when lex
      (setf *utterance* (lex-form lex))
      (format t "~%~a produces utterance: ~a" 
	      (agent-id agent) *utterance*))))

(defun interpret (agent)
  "The hearer tries to interpret the utterance (name) of the speaker
and tries to point to the object its interpretation lead him to."
  (let ((lex (find *utterance* (agent-lexicon agent) 
		   :key #'lex-form :test #'string-equal)))
    (if lex
	(progn 
	  (format t "~%~a found interpretation ~a for ~a." 
		  (agent-id agent) (agent-topic agent) *utterance*)
	  (setf (agent-topic agent) (lex-meaning lex)))
	(progn 
	  (format t "~%~a failed to find any association for ~a" 
		  (agent-id agent) *utterance*)))))

(defun point (agent)
  "Pointing is simply setting *pointed-object*."
  (format t "~%~a points to ~a" (agent-id agent) (agent-topic agent))
  (setf *pointed-object* (agent-topic agent)))

(defun pointing-correct? (agent)
  "This function compares two objects. The comparison is between the
topic the speaker chose and the object the hearer pointed at."
  (format t "~%~a compares his own topic ~a with pointed-object ~a"
	  (agent-id agent) (agent-topic agent) *pointed-object*)
  (eq *pointed-object* (agent-topic agent)))

;; let's now try this

(setf *population* (create-population 2))

(setf *world* (create-world 10))

(run-experiment 1)

;; There is no learning! We need to add that!

(defun play-game (speaker hearer)
  (format t "~%-----~%Starting new game:~% -speaker: ~a~% -hearer: ~a" 
	  (agent-id speaker) (agent-id hearer))
  (pick-topic speaker)
  (produce speaker)
  (diagnose-and-repair-problem-speaker speaker)
  (interpret hearer)
  (point hearer)
  (pointing-correct? speaker)
  (point speaker)
  (diagnose-and-repair-problem-hearer hearer))

(defun diagnose-and-repair-problem-speaker (speaker)
  "If the speaker is not capable of uttering a name there is a
problem. This problem is handled by inventing a new name."
  (when (string-equal *utterance* "")
    (format t "~%~a diagnoses that he has no association for meaning ~a"
	    (agent-id speaker) (agent-topic speaker))
    (let ((new-word (make-new-word)))
      (add-lex speaker new-word (agent-topic speaker)))
    (produce speaker)))

(defun diagnose-and-repair-problem-hearer (hearer)
  "If the hearer fails to point at the correct object he uses the
pointing information from the speaker to adopt a new form-meaning
association."
  (when (not (pointing-correct? hearer))
    (format t "~%~a diagnoses that he pointed to the incorrect
    object."
	    (agent-id hearer))
    (add-lex hearer *utterance* *pointed-object*)))

(setf *population* (create-population 2))

(setf *world* (create-world 10))

(run-experiment 1)

;; We still don't have any alignment!  We extend the agents so they
;; can set whether they have communicated successfully
    
(defstruct agent
  "An agent has an ID and a long-term associative memory called its
lexicon."
  (id (make-id "AGENT") 
      :type (or symbol fixnum))
  (lexicon nil
	   :type list)
  (topic nil
	 :type symbol)
  (communicated-successfully? nil
			      :type boolean))

(defun pointing-correct? (agent)
  "This function compares two objects. The comparison is between the
topic the speaker chose and the object the hearer pointed at."
  (format t "~%~a compares his own topic ~a with pointed-object ~a"
	  (agent-id agent) (agent-topic agent) *pointed-object*)
  (setf (agent-communicated-successfully? agent) (eq *pointed-object* (agent-topic agent)))
  (eq *pointed-object* (agent-topic agent)))

(defun play-game (speaker hearer)
  (format t "~%-----~%Starting new game:~% -speaker: ~a~% -hearer: ~a" 
	  (agent-id speaker) (agent-id hearer))
  (pick-topic speaker)
  (produce speaker)
  (diagnose-and-repair-problem-speaker speaker)
  (interpret hearer)
  (point hearer)
  (pointing-correct? speaker)
  (point speaker)
  (diagnose-and-repair-problem-hearer hearer))
  (update-agent speaker)
  (update-agent hearer))

(defun update-agent (agent)
  (if (agent-communicated-successfully? agent)
      (progn
	(format t "~%Updating ~a with success!!!" (agent-id agent)))
      (progn
	(format t "~%Updating ~a with failure!!!" (agent-id agent)))))

(defun clear-short-term-memory (agent)
  (setf (agent-topic agent) nil)
  (setf (agent-communicated-successfully? agent) t)
  (setf *utterance* "")
  (setf *pointed-object* nil))

(setf *population* (loop for i from 1 to 2
		      collect (make-agent)))

(run-experiment 1)

(run-experiment 20)

;; This will not work for more than 2 agents because no
;; alignment (the update-agent function) is not really
;; implemented. What we need is rewards and punishment in case of
;; successful or unsuccessful communication and lateral inhibition
;; dynamics to inhibit "synonyms".

;; If you would like more information about setting up Lisp on your
;; machine, understanding this file, getting this file to run, getting
;; the Babel2 framework, getting that to run, acquire and running
;; experiments we talk about in our papers or anything else related,
;; please do contact us, we would be pleased to assist you with any of
;; these.

;; e-mails: pieter@arti.vub.ac.be or/and martin.loetzsch@csl.sony.fr.

;; also visit: http://www.emergent-languages.org