;;;; example multi-level simulation
;;;;  teachers.lsp
;;;;
;;;; Nigel Gilbert October 22, 1996


;;;; There are 10 schools, each with an average of 20 teachers.
;;;; The teachers leave their jobs through retirement etc. and
;;;; are replaced, by men and women with equal probability.  Men
;;;; stay in their jobs twice as long as women.  New women are
;;;; assigned to a school with probability
;;;;   ny-t * exp(kappa * eta)
;;;; where eta is the percentage of women amont the school's
;;;; teachers.

;;; to run
;;;   (load "teachers")
;;;   (compile-file "teachers" :load t)
;;;   (run-teachers)

(require "mls")  ;load the mls toolkit

(defconstant kappa 1.5)

(defconstant ny-t 0.2)

;; the multi-level hierachy is system-school-teacher

(defobject system)

(defobject school (sex-ratio new-woman-prob))

(defobject teacher (sex age duration status) (status))

(defmeth system :initialise (n-schools mean-teachers-per-school)
"the system consists of schools"
  (create-lowers school n-schools mean-teachers-per-school))

(defmeth school :initialise (mean-teachers-per-school)
"a school consists of teachers, a different number for each school"
  (create-lowers teacher 
        (let ((num-teachers (round (normal mean-teachers-per-school 
                                    (/ mean-teachers-per-school 3)))))
          ; a school must have at least 2 teachers
          (if (< num-teachers 2) 
              2 
              num-teachers)))
  (set-attribute new-woman-prob 0.5)
  ; the school's sex ratio is the number of female teachers divided
  ; by the total number of teachers
  (set-attribute sex-ratio
                 (/ (count 'female (send self :from-lowers 'sex))
                    (send self :num-lowers))))

(defmeth teacher :initialise ()
  (set-attribute sex (randomly-choose 'male 'female))
  (set-attribute age (uniform 20 65))
  ; duration is the time they stay in the job
  (set-attribute duration 
                 (case (attribute sex)
                   (male (normal 30 5))
                   (female (normal 15 5))))
  (set-attribute status 'teaching))

(defmeth school :act ()
  (set-attribute new-woman-prob
                 (* ny-t (exp (* kappa (prev-attribute sex-ratio)))))
  (set-attribute sex-ratio
                 (/ (count 'female (send self :from-lowers 'sex))
                    (send self :num-lowers))))

(defmeth teacher :act ()
  (set-attribute status
                 (cond
                   ((<= (prev-attribute duration) 0) 'left)
                   ((>= (prev-attribute age) 65) 'retired)
                   (t 'teaching)))
  (cond 
    ((eql (attribute status) 'teaching)
     ; if this teacher is still teaching, make him/her a year older
     (set-attribute age (+ (prev-attribute age) 1))
     (set-attribute duration (- (prev-attribute duration) 1)))
    (otherwise
     ; this teacher has left or retired.  Miraculously revive the
     ; teacher as a new recruit, with a new age, sex etc.
     (set-attribute sex (if (prob (prev-upper-attribute new-woman-prob))
                            'female 'male))
     (set-attribute age (uniform 20 65))
     (set-attribute duration 
                 (case (attribute sex)
                   (male (normal 30 5))
                   (female (normal 15 5))))
     (set-attribute status 'teaching))))

(defun run-teachers (&optional (n-schools 10) 
                               (mean-teachers-per-school 20) 
                               (steps 100))
  (let ((system (create system n-schools mean-teachers-per-school))
        plot)
    ; run the simulation
    (dotimes (s steps)
             (send system :step))
    ; set up a blank plot
    (setq plot (plot-lines '(0) '(0) :title "Simulation results"
                          :variable-labels '("Time" "Percentage Women")))
    ; draw a line on the plot for each school, showing the history of 
    ; the school's sex ratio during the simulation
    (dolist (school (send system :lowers))
            (send plot :add-lines (list (iseq steps)
                                       (its-history school 'sex-ratio)))
            (send plot :adjust-to-data))))