code.consxy.com Git - clnl/blob - src/main/clnl/nvm/nvm.lisp

   1 (in-package #:clnl-nvm)
   2
   3 (defun lookup-color (color)
   4  "LOOKUP-COLOR COLOR => COLOR-NUMBER
   5
   6 ARGUMENTS AND VALUES:
   7
   8   COLOR: a symbol representing a color
   9   COLOR-NUMBER: the NetLogo color integer
  10
  11 DESCRIPTION:
  12
  13   Returns the number used to represent colors in NetLogo.
  14
  15   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#Constants"
  16  (case color
  17   (:black 0d0)
  18   (:gray 5d0)
  19   (:white 9.9d0)
  20   (:red 15d0)
  21   (:orange 25d0)
  22   (:brown 35d0)
  23   (:yellow 45d0)
  24   (:green 55d0)
  25   (:lime 65d0)
  26   (:turquoise 75d0)
  27   (:cyan 85d0)
  28   (:sky 95d0)
  29   (:blue 105d0)
  30   (:violet 115d0)
  31   (:magenta 125d0)
  32   (:pink 135d0)))
  33
  34 (defun create-turtle (breed &optional base-turtle)
  35  (let*
  36   ((breed (or breed (and base-turtle (turtle-breed base-turtle)) :turtles))
  37    (new-turtle (make-turtle
  38                 :who (coerce *current-id* 'double-float)
  39                 :color (if base-turtle
  40                         (turtle-color base-turtle)
  41                         (coerce (+ 5 (* 10 (clnl-random:next-int 14))) 'double-float))
  42                 :heading (if base-turtle
  43                           (turtle-heading base-turtle)
  44                           (coerce (clnl-random:next-int 360) 'double-float))
  45                 :label-color (if base-turtle (turtle-label-color base-turtle) 9.9d0)
  46                 :size (if base-turtle (turtle-size base-turtle) 1d0)
  47                 :breed breed
  48                 :shape (breed-default-shape breed)
  49                 :xcor (if base-turtle (turtle-xcor base-turtle) 0d0)
  50                 :ycor (if base-turtle (turtle-ycor base-turtle) 0d0)
  51                 :own-vars (when base-turtle (copy-list (turtle-own-vars base-turtle))))))
  52   (let
  53    ((patch (patch-at (turtle-xcor new-turtle) (turtle-ycor new-turtle))))
  54    (setf (patch-turtles patch) (nconc (patch-turtles patch) (list new-turtle))))
  55   (setf *turtles* (nconc *turtles* (list new-turtle)))
  56   (incf *current-id*)
  57   new-turtle))
  58
  59 (defun shufflerator (agentset-list)
  60  (let
  61   ((copy (copy-list agentset-list))
  62    (i 0)
  63    (agent nil))
  64   (labels
  65    ((fetch ()
  66      (let
  67       ((idx (when (< i (1- (length copy))) (+ i (clnl-random:next-int (- (length copy) i))))))
  68       (when idx (setf agent (nth idx copy)))
  69       (when idx (setf (nth idx copy) (nth i copy)))
  70       (incf i)
  71       (when (and (<= i (length copy)) (turtle-p agent) (= -1 (turtle-who agent))) (fetch)))))
  72    (fetch) ; we pre-fetch because netlogo does, rng sync hype!
  73    (lambda ()
  74     (cond
  75      ((> i (length copy)) nil)
  76      ((= i (length copy)) (incf i) (car (last copy)))
  77      (t (let ((result agent)) (fetch) result)))))))
  78
  79 (defcommand create-world (&key dims globals turtles-own-vars patches-own-vars breeds)
  80  "CREATE-WORLD &key DIMS GLOBALS TURTLES-OWN-VARS PATCHES-OWN-VARS BREEDS => RESULT
  81
  82   DIMS: (:xmin XMIN :xmax XMAX :ymin YMIN :ymax YMAX)
  83   GLOBALS: GLOBAL*
  84   TURTLES-OWN-VARS: TURTLES-OWN-VAR*
  85   PATCHES-OWN-VARS: PATCHES-OWN-VAR*
  86   BREEDS: BREED*
  87   RESULT: :undefined
  88   GLOBAL: (GLOBAL-NAME GLOBAL-ACCESS-FUNC)
  89
  90 ARGUMENTS AND VALUES:
  91
  92   XMIN: An integer representing the minimum patch coord in X
  93   XMAX: An integer representing the maximum patch coord in X
  94   YMIN: An integer representing the minimum patch coord in Y
  95   YMAX: An integer representing the maximum patch coord in Y
  96   TURTLES-OWN-VAR: Symbol for the turtles own variable in the keyword package
  97   PATCHES-OWN-VAR: Symbol for the patches own variable in the keyword package
  98   BREED: A list of symbols representing the possible preeds
  99   GLOBAL-NAME: Symbol for the global in the keyword package
 100   GLOBAL-ACCESS-FUNC: Function to get the value of the global
 101
 102 DESCRIPTION:
 103
 104   Initializes the world in the NVM.
 105
 106   This should be called before using the engine in any real capacity.  If
 107   called when an engine is already running, it may do somethign weird."
 108  (setf *turtles-own-vars* turtles-own-vars)
 109  (setf *patches-own-vars* patches-own-vars)
 110  (setf *dimensions* dims)
 111  (setf *globals* globals)
 112  (setf *breeds*
 113   (append
 114    (list (list :turtles "default"))
 115    (mapcar (lambda (breed) (list breed "default")) breeds)))
 116  (clear-ticks)
 117  (clear-patches)
 118  (clear-turtles))
 119
 120 (defun current-state ()
 121  "CURRENT-STATE => WORLD-STATE
 122
 123 ARGUMENTS AND VALUES:
 124
 125   WORLD-STATE: A list, the current state of the whole world
 126
 127 DESCRIPTION:
 128
 129   Dumps out the state of the world.
 130
 131   This is useful for visualizations and also storing in a common lisp
 132   data structure for easy usage in a common lisp instance.  It's preferable
 133   to use this when working with the nvm than the output done by export-world.
 134
 135   Currently this only dumps out turtle and patch information.
 136
 137   This is called CURRENT-STATE because export-world is an actual primitive
 138   used by NetLogo."
 139  (list
 140   (mapcar
 141    (lambda (turtle)
 142     (list
 143      :color (turtle-color turtle)
 144      :xcor (turtle-xcor turtle)
 145      :ycor (turtle-ycor turtle)
 146      :heading (turtle-heading turtle)
 147      :shape (turtle-shape turtle)
 148      :size (turtle-size turtle)))
 149    *turtles*)
 150   (mapcar
 151    (lambda (patch)
 152     (list
 153      :color (patch-color patch)
 154      :xcor (patch-xcor patch)
 155      :ycor (patch-ycor patch)))
 156    *patches*)
 157   (mapcar
 158    (lambda (global)
 159     (list
 160      :name (car global)
 161      :value (funcall (cadr global))))
 162    *globals*)))
 163
 164 ; These match netlogo's dump
 165 (defgeneric dump-object (o))
 166
 167 (defmethod dump-object ((n double-float))
 168  (multiple-value-bind (int rem) (floor n)
 169   (if (eql 0d0 rem)
 170    (format nil "~A" int)
 171    (let
 172     ((output (format nil "~D" n)))
 173     ; Someday we'll have d<posint>, but this is not that day!
 174     (cl-ppcre:regex-replace "d-" (cl-ppcre:regex-replace "d0" output "") "E-")))))
 175
 176 (defmethod dump-object ((o string)) (format nil "~A" (cl-ppcre:regex-replace-all "\"" (format nil "~S" o) "\"\"")))
 177
 178 (defmethod dump-object ((o (eql t))) "true")
 179 (defmethod dump-object ((o (eql nil))) "false")
 180
 181 (defmethod dump-object ((o list))
 182  (cond
 183   ((agentset-p o) (format nil "(agentset, ~A ~A)" (dump-object (count o)) (string-downcase (agentset-breed o))))
 184   (t (format nil "[~{~A~^ ~}]" (mapcar #'dump-object o)))))
 185
 186 (defmethod dump-object ((o patch))
 187  (format nil "(patch ~A ~A)" (dump-object (patch-xcor o)) (dump-object (patch-ycor o))))
 188
 189 (defmethod dump-object ((o turtle)) (format nil "(turtle ~A)" (dump-object (turtle-who o))))
 190 (defmethod dump-object ((o (eql :nobody))) (format nil "nobody"))
 191 (defmethod dump-object ((o (eql :turtles))) (format nil "{all-turtles}"))
 192 (defmethod dump-object ((o symbol))
 193  (cond
 194   ((find o *breeds* :key #'car) (format nil "{breed ~(~A~)}" o))
 195   (t (error "Keyword unrecognized by dump object: ~A" o))))