examples/tutorial/tutorial-3-evolving-models.lisp

(require :asdf)
(require :alexandria)
(require :gems)

;; --------------------------------------------------------------------------
;; Global parameters / utilities

;; -- these parameters control the experimental settings

(defvar *good-model-threshold* 0.1) ; based on overall fitness

;; for GP system
(defvar *population-size* 500) ; size of population 
(defvar *total-generations* 500) ; fixed number of iterations 

;; The following parameters are used within the definition of the fitness 
;; function to fine-tune the individual objective functions.
(defvar *propn-fitness-accuracy* 0.7) ; proportion of f_a
(defvar *propn-fitness-time* 0.2)     ; proportion of f_t
(defvar *propn-fitness-size* 0.1)     ; proportion of f_s
(defvar *size-ps* 100)          ; program size scaling parameter
(defvar *time-rt* 767)          ; response time scaling parameter

;; Return new list of individuals, with duplicates and time-only-code removed.
;; Note - as dotted list required, we cannot include this in gems:clean-individuals
(defun clean-individuals-time (individuals run-experiment)
  (remove-duplicates
    (mapcar #'(lambda (individual) 
                (gems:make-individual 
                  :fitness (gems:individual-fitness individual)
                  :extras (gems:individual-extras individual)
                  :tree (gems:replace-timeonly-code 
                          (gems:individual-tree individual) 
                          run-experiment
                          '((input-target . wait-input)
                            (input-left . wait-input)
                            (input-right . wait-input)
                            (respond-left . wait-output)
                            (respond-right . wait-output)
                            (compare-1-2 . wait-cognitive)
                            (compare-1-3 . wait-cognitive)
                            (compare-2-3 . wait-cognitive)
                            (put-stm . wait-cognitive)
                            (access-stm-1 . wait-stm)
                            (access-stm-2 . wait-stm)
                            (access-stm-3 . wait-stm)))))
            individuals)
    :key #'gems:individual-tree
    :test #'equalp))

;; --------------------------------------------------------------------------
;; Task Definition: DMTS

;; Experiment times for 
;; -- when to end presenting the target
(defconstant end-target 1000)
;; -- when to start showing the two inputs
(defconstant start-input (+ end-target 500))

;; Data for experiment - in form (target left right)
(defvar *data* '((1 2 1) (1 1 2) (1 3 1) (1 1 3) (1 4 1) (1 1 4) (1 5 1) (1 1 5) (1 6 1) (1 1 6)
                         (2 1 2) (2 2 1) (2 3 2) (2 2 3) (2 4 2) (2 2 4) (2 5 2) (2 2 5) (2 6 2) (2 2 6)
                         (3 1 3) (3 3 1) (3 2 3) (3 3 2) (3 4 3) (3 3 4) (3 5 3) (3 3 5) (3 6 3) (3 3 6)
                         (4 1 4) (4 4 1) (4 2 4) (4 4 2) (4 3 4) (4 4 2) (4 5 4) (4 4 5) (4 6 4) (4 4 6)
                         (5 1 5) (5 5 1) (5 2 5) (5 5 2) (5 3 5) (5 5 3) (5 4 5) (5 5 4) (5 6 5) (5 5 6)
                         (6 1 6) (6 6 1) (6 2 6) (6 6 2) (6 3 6) (6 6 3) (6 4 6) (6 6 4) (6 5 6) (6 6 5)))

;; Holds information about results of experiment
(defstruct result 
  inputs response accuracy timing)

;; Given the three inputs, compute the target response
(defun target-response (inputs)
  (if (= (first inputs) (second inputs))
    "L"
    "R"))

;; Run a single experiment against the given program, returning information on performance.
(defun run-experiment (program)
  (let ((results '())
        (expt-data (alexandria:shuffle *data*)))
    (dolist (input expt-data)
      (let ((md (make-model :clock 0 :current 0 :stm '(0 0 0) 
                            :timings (make-timings)
                            :inputs input :response "-")))
        (interpret program md)
        (let ((result (make-result :inputs input :response "-" :accuracy 0 :timing 0)))
          (when (> (model-clock md) start-input) ; when clock is after allowed time for response
            (setf (result-response result) (model-response md)) ; record model's response
            (setf (result-accuracy result) ; record whether it is correct or not
                  (if (string= (result-response result) (target-response input))
                    1
                    0))
            (setf (result-timing result) (- (model-clock md) start-input)) ; record the response time
            )
          (push result results))))
    results))

;; --------------------------------------------------------------------------
;; Search Space: Cognitive Model definition

;; Defines the timings of different operator groups
(defstruct timings
  (input 100) ;; perception + attend
  (output 140) ;; intend + movement
  (cognitive 70) ;; basic cognitive process
  (stm 50) ;; basic STM process
  (syntax 0) ;; prog2, if etc - different from cognitive operators
  )

;; Defines the state of the model
(defstruct model
  clock current stm timings ; base model
  inputs response ; I/O requirements for DMTS task
  )

;; These convenience functions allow interpret/display-pseudocode to 
;; work with both s-expressions and syntax-tree:node structures.

;; Returns label of given operator
(defun operator-label (operator)
  (typecase operator
    (list 
      (intern (symbol-name (first operator)) "KEYWORD"))
    (syntax-tree:node
      (intern (symbol-name (syntax-tree:node-label operator)) "KEYWORD"))
    (otherwise
      (error "Invalid operator type: ~a~&" operator))))

;; Returns children of given operator
(defun operator-children (operator)
  (typecase operator
    (list 
      (rest operator))
    (syntax-tree:node
      (syntax-tree:node-children operator))
    (otherwise
      (error "Invalid operator type"))))

;; Collect results from running model (defined by operator (program) + md).
(defun interpret (operator md)                                                
  (when (syntax-tree:node-p operator)
    (incf (syntax-tree:node-entries operator))) 
  (unless (> (model-clock md) 10000) ; time-out - adjust this if required
    (case (operator-label operator)

      (:input-left
        (incf (model-clock md) (timings-input (model-timings md)))
        (when (> (model-clock md) start-input)
          (setf (model-current md) (second (model-inputs md)))))

      (:input-right 
        (incf (model-clock md) (timings-input (model-timings md)))
        (when (> (model-clock md) start-input)
          (setf (model-current md) (third (model-inputs md)))))

      (:input-target
        (incf (model-clock md) (timings-input (model-timings md)))
        (when (<= (model-clock md) end-target)
          (setf (model-current md) (first (model-inputs md)))))

      (:respond-left
        (incf (model-clock md) (timings-output (model-timings md)))
        (when (> (model-clock md) start-input)
          (setf (model-response md) "L")))

      (:respond-right 
        (incf (model-clock md) (timings-output (model-timings md)))
        (when (> (model-clock md) start-input)
          (setf (model-response md) "R")))

      (:access-stm-1 
        (incf (model-clock md) (timings-stm (model-timings md)))
        (setf (model-current md) (first (model-stm md))))

      (:access-stm-2
        (incf (model-clock md) (timings-stm (model-timings md)))
        (setf (model-current md) (second (model-stm md))))

      (:access-stm-3
        (incf (model-clock md) (timings-stm (model-timings md)))
        (setf (model-current md) (third (model-stm md))))

      (:compare-1-2 
        (incf (model-clock md) (timings-cognitive (model-timings md)))
        (setf (model-current md) 
              (if (= (first (model-stm md)) (second (model-stm md))) 1 0)))

      (:compare-2-3 
        (incf (model-clock md) (timings-cognitive (model-timings md)))
        (setf (model-current md) 
              (if (= (second (model-stm md)) (third (model-stm md))) 1 0)))

      (:compare-1-3 
        (incf (model-clock md) (timings-cognitive (model-timings md)))
        (setf (model-current md) 
              (if (= (first (model-stm md)) (third (model-stm md))) 1 0)))

      (:nil
        (incf (model-clock md) (timings-cognitive (model-timings md)))
        (setf (model-current md) 0))

      (:put-stm 
        (incf (model-clock md) (timings-stm (model-timings md)))
        (setf (model-stm md) 
              (if (= 3 (length (model-stm md)))
                (list (model-current md)
                      (first (model-stm md))
                      (second (model-stm md)))
                (cons (model-current md)
                      (model-stm md)))))

      (:dotimes-2 
        (incf (model-clock md) (timings-syntax (model-timings md)))
        (dotimes (i 2)
          (interpret (first (operator-children operator)) md)))

      (:dotimes-3 
        (incf (model-clock md) (timings-syntax (model-timings md)))
        (dotimes (i 3)
          (interpret (first (operator-children operator)) md)))

      (:dotimes-5 
        (incf (model-clock md) (timings-syntax (model-timings md)))
        (dotimes (i 5)
          (interpret (first (operator-children operator)) md)))

      (:if 
        (incf (model-clock md) (timings-syntax (model-timings md)))
        (interpret (first (operator-children operator)) md)
        (if (not (zerop (model-current md))) ; 0 is false, other numbers true
          (interpret (second (operator-children operator)) md)
          (interpret (third (operator-children operator)) md)))

      (:prog2
        (incf (model-clock md) (timings-syntax (model-timings md)))
        (interpret (first (operator-children operator)) md)
        (interpret (second (operator-children operator)) md))

      (:prog3
        (incf (model-clock md) (timings-syntax (model-timings md)))
        (interpret (first (operator-children operator)) md)
        (interpret (second (operator-children operator)) md)
        (interpret (third (operator-children operator)) md))

      (:prog4
        (incf (model-clock md) (timings-syntax (model-timings md)))
        (interpret (first (operator-children operator)) md)
        (interpret (second (operator-children operator)) md)
        (interpret (third (operator-children operator)) md)
        (interpret (fourth (operator-children operator)) md))

      (:wait-25
        (incf (model-clock md) 25))

      (:wait-50
        (incf (model-clock md) 50))

      (:wait-100
        (incf (model-clock md) 100))

      (:wait-200
        (incf (model-clock md) 200))

      (:wait-1000
        (incf (model-clock md) 1000))

      (:wait-1500
        (incf (model-clock md) 1500))

      ;; wait operators, used for simplifying code
      (:wait-input 
        (incf (model-clock md) (timings-input (model-timings md))))
      (:wait-output 
        (incf (model-clock md) (timings-output (model-timings md))))
      (:wait-cognitive 
        (incf (model-clock md) (timings-cognitive (model-timings md))))
      (:wait-stm 
        (incf (model-clock md) (timings-stm (model-timings md)))) 

      (otherwise ; error if comes across an unknown operator
        (error "interpret: unknown operator ~a" (operator-label operator))))))

;; -- accuracy calculations for each fitness component

(defvar *phase* 1) ; number of current phase

;; Computes the f_a objective function: 95.7% is target mean accuracy in Chao et al.
(defun fitness-accuracy (performance)
  (/ (abs (- 0.957 performance))
     0.957))

;; Computes the f_t objective function: 767ms is target mean response time in Chao et al.
(defun fitness-time (response-time)
  (gems:half-sigmoid (/ (abs (- response-time 767))
                        *time-rt*)))

;; Computes the f_s objective function.
(defun fitness-size (program-size)
  (gems:half-sigmoid (/ program-size *size-ps*)))

;; Computes the fitness for current phase
(defun fitness-for-phase (f-a f-t f-s)
  (case *phase*
    (1 ; single objective
     f-a)
    (2 ; two objectives
     (/ (+ (* *propn-fitness-accuracy* f-a)
           (* *propn-fitness-time* f-t))
        (+ *propn-fitness-accuracy* *propn-fitness-time*)))
    (otherwise ; all three objectives
      (+ (* *propn-fitness-accuracy* f-a)
         (* *propn-fitness-time* f-t)
         (* *propn-fitness-size* f-s)))))

;; Computes fitness, using the phases
(defun overall-phased-fitness (f-a f-t f-s)
  (when (and (< *phase* 3)
             (< (fitness-for-phase f-a f-t f-s) *good-model-threshold*))
    (incf *phase*))
  (fitness-for-phase f-a f-t f-s))

;; runs experiment on a single program
(defun evaluate-program (individual)
  (let* ((program (gems:individual-tree individual))
         (results (run-experiment program))
         (accuracy (alexandria:mean (mapcar #'result-accuracy results)))
         (f-a (fitness-accuracy accuracy))
         (response-time (alexandria:mean (mapcar #'result-timing results)))
         (f-t (fitness-time response-time))
         (program-size (gems:program-size program))
         (f-s (fitness-size program-size)))
    (values  ; overall-fitness, optional extra information
      (overall-phased-fitness f-a f-t f-s)
      (list accuracy f-a response-time f-t program-size f-s *phase*) ; extra information
      )))

;; Returns a dotted list holding the available operators and number of children.
(defun operator-set () 
  '((INPUT-LEFT . 0)
    (INPUT-RIGHT . 0)
    (INPUT-TARGET . 0)
    (RESPOND-LEFT . 0)
    (RESPOND-RIGHT . 0)
    (ACCESS-STM-1 . 0)
    (ACCESS-STM-2 . 0)
    (ACCESS-STM-3 . 0)
    (COMPARE-1-2 . 0)
    (COMPARE-2-3 . 0)
    (COMPARE-1-3 . 0)
    (NIL . 0)
    (PUT-STM . 0)
    (DOTIMES-2 . 1)
    (DOTIMES-3 . 1)
    (DOTIMES-5 . 1)
    (IF . 3)
    (PROG2 . 2)
    (PROG3 . 3)
    (PROG4 . 4)
    (WAIT-25 . 0)
    (WAIT-50 . 0)
    (WAIT-100 . 0)
    (WAIT-200 . 0)
    (WAIT-1000 . 0)
    (WAIT-1500 . 0)))

;; Runs the GP system with given parameters, results logged to files.
(defun run-gp (&key (logger nil)) ; logger function
  (setf *phase* 1) ; initial phase for phased-evolution
  (gems:launch (operator-set) #'evaluate-program
               :total-generations *total-generations*
               :population-size *population-size*
               :initial-depth 1
               :maximum-depth 10
               :elitism t
               :type :steady-state
               :logger logger))

;; --------------------------------------------------------------------------
;; Simulation experiments

(defun run-expt (name)
  (run-gp :logger (gems:combine-loggers 
                    (gems:make-logger (format nil "log-~a.csv" name)
                                      :if-exists :supersede)
                    (gems:make-logger (format nil "population-~a.yml" name) 
                                      :name name
                                      :kind :trace 
                                      :filter #'(lambda (gen) (= gen *total-generations*))
                                      :if-exists :supersede
                                      ))))

;; -- perform analysis

;; given a file containing a population of models 
;; - perform post-processing
;; - return a list of models, in the form of gems:individual structures, so preserving fitness etc
(defun good-models (filename &optional (display nil))
  (let* ((models ; get models from final population
           (rest (first (last (gems:read-trace filename)))))
         (good-models ; extract those models within good-model threshold
           (remove-if #'(lambda (model) (> (gems:individual-fitness model) *good-model-threshold*))
                                 models))
         (ndc-models ; remove dead-code from the model programs
           (gems:clean-individuals good-models #'run-experiment))
         (nto-models ; remove time-only code from the model programs
           (clean-individuals-time ndc-models #'run-experiment)))
   (when display
     (format t "Found ~a good models out of ~a~&" (length good-models) (length models))
     (format t "After removing dead code: ~a models~&" (length ndc-models))
     (format t "After removing time-only code: ~a models~&" (length nto-models)))
    nto-models))

;; run the experiment
;; this outputs two trace files: log-dmts.cvs and population-dmts.yml
;; the latter contains the models, so load it back in and output the similarity across models
(run-expt "dmts")
(gems:write-similarity-individuals (good-models "population-dmts.yml" t) "dmts-models.dat")