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

   1 (in-package #:clnl-nvm)
   2
   3 ; Implementations of all the things the nvm can do.
   4
   5 (defun show (value)
   6  "SHOW VALUE => RESULT
   7
   8 ARGUMENTS AND VALUES:
   9
  10   VALUE: a NetLogo value
  11   RESULT: undefined
  12
  13 DESCRIPTION:
  14
  15   A command that prints the given NetLogo value to the command center.
  16
  17   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#show"
  18  (format t "Showing: ~A~%" (dump-object value)))
  19
  20 (defun create-turtle ()
  21  (setf
  22   *turtles*
  23   (nconc
  24    *turtles*
  25    (list
  26     (make-turtle
  27      :who *current-id*
  28      :color (coerce (+ 5 (* 10 (clnl-random:next-int 14))) 'double-float)
  29      :heading (coerce (clnl-random:next-int 360) 'double-float)
  30      :xcor 0d0
  31      :ycor 0d0))))
  32  (incf *current-id*))
  33
  34 (defun die ()
  35  "DIE => RESULT
  36
  37 ARGUMENTS AND VALUES:
  38
  39   RESULT: undefined, commands don't return
  40
  41 DESCRIPTION:
  42
  43   The turtle or link dies
  44
  45   A dead agent ceases to exist. The effects of this include:
  46   - The agent will not execute any further code.
  47   - The agent will disappear from any agentsets it was in, reducing the size of those agentsets by one.
  48   - Any variable that was storing the agent will now instead have nobody in it.
  49   - If the dead agent was a turtle, every link connected to it also dies.
  50   - If the observer was watching or following the agent, the observer's perspective resets.
  51
  52   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#die"
  53  (when (not (turtle-p *self*)) (error "Gotta call die in turtle scope, dude (~A)" *self*))
  54  (setf (turtle-who *self*) -1)
  55  (setf *turtles* (remove *self* *turtles*)))
  56
  57 (defun turtles ()
  58  "TURTLES => ALL-TURTLES
  59
  60 ARGUMENTS AND VALUES:
  61
  62   ALL-TURTLES: a NetLogo agentset, all turtles
  63
  64 DESCRIPTION:
  65
  66   Reports the agentset consisting of all the turtles.
  67
  68   This agentset is special in that it represents the living turtles
  69   each time it's used, so changes depending on the state of the engine.
  70
  71   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#turtles"
  72  *turtles*)
  73
  74 (defun ask (agent-set fn)
  75  "ASK AGENT-SET FN => RESULT
  76
  77 ARGUMENTS AND VALUES:
  78
  79   AGENT-SET: a NetLogo agentset
  80   FN: a function, run on each agent
  81   RESULT: undefined, commands don't return
  82
  83 DESCRIPTION:
  84
  85   ASK is equivalent to ask in NetLogo.
  86
  87   The specified AGENT-SET runs the given FN.  The order in which the agents
  88   are run is random each time, and only agents that are in the set at the
  89   beginning of the call.
  90
  91   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#ask"
  92  (let
  93   ((iter (shufflerator agent-set)))
  94   (loop
  95    :for agent := (funcall iter)
  96    :while agent
  97    :do (let ((*myself* *self*) (*self* agent)) (funcall fn)))))
  98
  99 (defun shufflerator (agent-set)
 100  (let
 101   ((copy (copy-list agent-set))
 102    (i 0)
 103    (agent nil))
 104   (flet
 105    ((fetch ()
 106      (let
 107       ((idx (when (< i (1- (length copy))) (+ i (clnl-random:next-int (- (length copy) i))))))
 108       (when idx (setf agent (nth idx copy)))
 109       (when idx (setf (nth idx copy) (nth i copy)))
 110       (incf i))))
 111    (fetch) ; we pre-fetch because netlogo does, rng sync hype!
 112    (lambda ()
 113     (cond
 114      ((> i (length copy)) nil)
 115      ((= i (length copy)) (incf i) (car (last copy)))
 116      (t (let ((result agent)) (fetch) result)))))))
 117
 118 (defun random-float (n)
 119  "RANDOM-FLOAT N => RANDOM-NUMBER
 120
 121 ARGUMENTS AND VALUES:
 122
 123   N: a double, the upper bound of the random float
 124   RANDOM-NUMBER: a double, the random result
 125
 126 DESCRIPTION:
 127
 128   Returns a random number strictly closer to zero than N.
 129
 130   If number is positive, returns a random floating point number greater than
 131   or equal to 0 but strictly less than number.
 132
 133   If number is negative, returns a random floating point number less than or equal
 134   to 0, but strictly greater than number.
 135
 136   If number is zero, the result is always 0.
 137
 138   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#random-float"
 139  (clnl-random:next-double n))
 140
 141 (defun jump (n)
 142  (when (not (turtle-p *self*)) (error "Gotta call fd in turtle scope, dude (~A)" *self*))
 143  (setf
 144   (turtle-xcor *self*)
 145   (wrap-x *topology*
 146    (+ (turtle-xcor *self*) (* n (using-cached-sin (turtle-heading *self*))))))
 147  (setf
 148   (turtle-ycor *self*)
 149   (wrap-y *topology*
 150    (+ (turtle-ycor *self*) (* n (using-cached-cos (turtle-heading *self*)))))))
 151
 152 (defun forward (n)
 153  "FORWARD N => RESULT
 154
 155 ARGUMENTS AND VALUES:
 156
 157   N: a double, the amount the turtle moves forward
 158   RESULT: undefined
 159
 160 DESCRIPTION:
 161
 162   Moves the current turtle forward N steps, one step at a time.
 163
 164   This moves forward one at a time in order to make the view updates look
 165   good in the case of a purposefully slow running instance.  If the number
 166   is negative, the turtle moves backward.
 167
 168   If the current agent is not a turtle, it raises an error.
 169
 170   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#forward"
 171  (when (not (turtle-p *self*)) (error "Gotta call fd in turtle scope, dude (~A)" *self*))
 172  (labels
 173   ((internal (i)
 174     (cond
 175      ((< (abs i) 3.2e-15) nil)
 176      ((< (abs i) 1d0) (jump i))
 177      (t (jump (if (> i 0d0) 1d0 -1d0)) (internal (- i (if (> i 0d0) 1d0 -1d0)))))))
 178   (internal n)))
 179
 180 (defun turn-right (n)
 181  "TURN-RIGHT N => RESULT
 182
 183 ARGUMENTS AND VALUES:
 184
 185   N: a double, the amount the turtle turns
 186   RESULT: undefined
 187
 188 DESCRIPTION:
 189
 190   The turtle turns right by number degrees. (If number is negative, it turns left.)
 191
 192   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#right"
 193  (when (not (turtle-p *self*)) (error "Gotta call fd in turtle scope, dude (~A)" *self*))
 194  (let
 195   ((new-heading (+ (turtle-heading *self*) n)))
 196   (setf (turtle-heading *self*)
 197    (cond
 198     ((< new-heading 0) (+ (mod new-heading -360) 360))
 199     ((>= new-heading 360) (mod new-heading 360))
 200     (t new-heading)))))
 201
 202 (defun turn-left (n)
 203  "TURN-LEFT N => RESULT
 204
 205 ARGUMENTS AND VALUES:
 206
 207   N: a double, the amount the turtle turns
 208   RESULT: undefined
 209
 210 DESCRIPTION:
 211
 212   The turtle turns left by number degrees. (If number is negative, it turns right.)
 213
 214   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#right"
 215  (turn-right (- n)))
 216
 217 (defun create-turtles (n)
 218  "CREATE-TURTLES N => RESULT
 219
 220 ARGUMENTS AND VALUES:
 221
 222   N: an integer, the numbers of turtles to create
 223   RESULT: undefined
 224
 225 DESCRIPTION:
 226
 227   Creates number new turtles at the origin.
 228
 229   New turtles have random integer headings and the color is randomly selected
 230   from the 14 primary colors.  If commands are supplied, the new turtles
 231   immediately run them (unimplemented).
 232
 233   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#create-turtles"
 234  (loop :for i :from 1 :to n :do (create-turtle)))
 235
 236 (defun create-world (&key dims)
 237  "CREATE-WORLD &key DIMS => RESULT
 238
 239   DIMS: (:xmin XMIN :xmax XMAX :ymin YMIN :ymax YMAX)
 240
 241 ARGUMENTS AND VALUES:
 242
 243   RESULT: undefined
 244   XMIN: An integer representing the minimum patch coord in X
 245   XMAX: An integer representing the maximum patch coord in X
 246   YMIN: An integer representing the minimum patch coord in Y
 247   YMAX: An integer representing the maximum patch coord in Y
 248
 249 DESCRIPTION:
 250
 251   Initializes the world in the NVM.
 252
 253   This should be called before using the engine in any real capacity.  If
 254   called when an engine is already running, it may do somethign weird."
 255  (setf *dimensions* dims)
 256  (setf *turtles* nil)
 257  (setf *current-id* 0))
 258
 259 ; These match netlogo's dump
 260 (defgeneric dump-object (o))
 261
 262 (defmethod dump-object ((n double-float))
 263  (multiple-value-bind (int rem) (floor n)
 264   (if (eql 0d0 rem)
 265    (format nil "~A" int)
 266    (let
 267     ((output (format nil "~D" n)))
 268     ; Someday we'll have d<posint>, but this is not that day!
 269     (cl-ppcre:regex-replace "d-" (cl-ppcre:regex-replace "d0" output "") "E-")))))
 270
 271 (defmethod dump-object ((o string)) o)
 272
 273 (defmethod dump-object ((o (eql t))) "true")
 274 (defmethod dump-object ((o (eql nil))) "false")
 275
 276 (defun current-state ()
 277  "CURRENT-STATE => WORLD-STATE
 278
 279 ARGUMENTS AND VALUES:
 280
 281   WORLD-STATE: A list, the current state of the whole world
 282
 283 DESCRIPTION:
 284
 285   Dumps out the state of the world.
 286
 287   This is useful for visualizations and also storing in a common lisp
 288   data structure for easy usage in a common lisp instance.  It's preferable
 289   to use this when working with the nvm than the output done by export-world.
 290
 291   Currently this only dumps out turtle information.
 292
 293   This is called CURRENT-STATE because export-world is an actual primitive
 294   used by NetLogo."
 295  (mapcar
 296   (lambda (turtle)
 297    (list
 298     :color (turtle-color turtle)
 299     :xcor (turtle-xcor turtle)
 300     :ycor (turtle-ycor turtle)
 301     :heading (turtle-heading turtle)))
 302   *turtles*))
 303
 304 (defun export-patches ()
 305  (list
 306   "\"pxcor\",\"pycor\",\"pcolor\",\"plabel\",\"plabel-color\""
 307   "\"-1\",\"1\",\"0\",\"\"\"\"\"\",\"9.9\""
 308   "\"0\",\"1\",\"0\",\"\"\"\"\"\",\"9.9\""
 309   "\"1\",\"1\",\"0\",\"\"\"\"\"\",\"9.9\""
 310   "\"-1\",\"0\",\"0\",\"\"\"\"\"\",\"9.9\""
 311   "\"0\",\"0\",\"0\",\"\"\"\"\"\",\"9.9\""
 312   "\"1\",\"0\",\"0\",\"\"\"\"\"\",\"9.9\""
 313   "\"-1\",\"-1\",\"0\",\"\"\"\"\"\",\"9.9\""
 314   "\"0\",\"-1\",\"0\",\"\"\"\"\"\",\"9.9\""
 315   "\"1\",\"-1\",\"0\",\"\"\"\"\"\",\"9.9\""))
 316
 317 (defun export-world ()
 318  "EXPORT-WORLD => WORLD-CSV
 319
 320 ARGUMENTS AND VALUES:
 321
 322   WORLD-CSV: A string, the csv of the world
 323
 324 DESCRIPTION:
 325
 326   Dumps out a csv matching NetLogo's export world.
 327
 328   This is useful for serializing the current state of the engine in order
 329   to compare against NetLogo or to reimport later.  Contains everything needed
 330   to boot up a NetLogo instance in the exact same state."
 331  (format nil "~{~A~%~}"
 332   (list
 333    (format nil "~S" "RANDOM STATE")
 334    (format nil "~S" (clnl-random:export))
 335    ""
 336    (format nil "~S" "GLOBALS")
 337    (format nil "~A~A"
 338     "\"min-pxcor\",\"max-pxcor\",\"min-pycor\",\"max-pycor\",\"perspective\",\"subject\","
 339     "\"nextIndex\",\"directed-links\",\"ticks\",")
 340    (format nil "\"~A\",\"~A\",\"~A\",\"~A\",\"0\",\"nobody\",\"~A\",\"\"\"NEITHER\"\"\",\"-1\""
 341     (min-pxcor) (max-pxcor) (min-pycor) (max-pycor) *current-id*)
 342    ""
 343    (format nil "~S" "TURTLES")
 344    (format nil "~A~A"
 345     "\"who\",\"color\",\"heading\",\"xcor\",\"ycor\",\"shape\",\"label\",\"label-color\","
 346     "\"breed\",\"hidden?\",\"size\",\"pen-size\",\"pen-mode\"")
 347    (format nil "~{~A~%~}"
 348     (mapcar
 349      (lambda (turtle)
 350       (format nil
 351        "\"~A\",\"~A\",\"~A\",\"~A\",\"~A\",~A"
 352        (turtle-who turtle)
 353        (dump-object (turtle-color turtle))
 354        (dump-object (turtle-heading turtle))
 355        (dump-object (turtle-xcor turtle))
 356        (dump-object (turtle-ycor turtle))
 357        "\"\"\"default\"\"\",\"\"\"\"\"\",\"9.9\",\"{all-turtles}\",\"false\",\"1\",\"1\",\"\"\"up\"\"\""))
 358      *turtles*))
 359    (format nil "~S" "PATCHES")
 360    (format nil "~{~A~^~%~}" (export-patches))
 361    ""
 362    (format nil "~S" "LINKS")
 363    "\"end1\",\"end2\",\"color\",\"label\",\"label-color\",\"hidden?\",\"breed\",\"thickness\",\"shape\",\"tie-mode\""
 364    "")))