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 lookup-color (color)
  21  "LOOKUP-COLOR COLOR => COLOR-NUMBER
  22
  23 ARGUMENTS AND VALUES:
  24
  25   COLOR: a symbol representing a color
  26   COLOR-NUMBER: the NetLogo color integer
  27
  28 DESCRIPTION:
  29
  30   Returns the number used to represent colors in NetLogo.
  31
  32   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#Constants"
  33  (case color
  34   (:black 0d0)
  35   (:gray 5d0)
  36   (:white 9.9d0)
  37   (:red 15d0)
  38   (:orange 25d0)
  39   (:brown 35d0)
  40   (:yellow 45d0)
  41   (:green 55d0)
  42   (:lime 65d0)
  43   (:turquoise 75d0)
  44   (:cyan 85d0)
  45   (:sky 95d0)
  46   (:blue 105d0)
  47   (:violet 115d0)
  48   (:magenta 125d0)
  49   (:pink 135d0)))
  50
  51 (defun create-turtle ()
  52  (setf
  53   *turtles*
  54   (nconc
  55    *turtles*
  56    (list
  57     (make-turtle
  58      :who (coerce *current-id* 'double-float)
  59      :color (coerce (+ 5 (* 10 (clnl-random:next-int 14))) 'double-float)
  60      :heading (coerce (clnl-random:next-int 360) 'double-float)
  61      :xcor 0d0
  62      :ycor 0d0))))
  63  (incf *current-id*))
  64
  65 (defun die ()
  66  "DIE => RESULT
  67
  68 ARGUMENTS AND VALUES:
  69
  70   RESULT: undefined, commands don't return
  71
  72 DESCRIPTION:
  73
  74   The turtle or link dies
  75
  76   A dead agent ceases to exist. The effects of this include:
  77   - The agent will not execute any further code.
  78   - The agent will disappear from any agentsets it was in, reducing the size of those agentsets by one.
  79   - Any variable that was storing the agent will now instead have nobody in it.
  80   - If the dead agent was a turtle, every link connected to it also dies.
  81   - If the observer was watching or following the agent, the observer's perspective resets.
  82
  83   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#die"
  84  (when (not (turtle-p *self*)) (error "Gotta call die in turtle scope, dude (~A)" *self*))
  85  (setf (turtle-who *self*) -1)
  86  (setf *turtles* (remove *self* *turtles*)))
  87
  88 (defun turtles ()
  89  "TURTLES => ALL-TURTLES
  90
  91 ARGUMENTS AND VALUES:
  92
  93   ALL-TURTLES: a NetLogo agentset, all turtles
  94
  95 DESCRIPTION:
  96
  97   Reports the agentset consisting of all the turtles.
  98
  99   This agentset is special in that it represents the living turtles
 100   each time it's used, so changes depending on the state of the engine.
 101
 102   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#turtles"
 103  *turtles*)
 104
 105 (defun ask (agent-set fn)
 106  "ASK AGENT-SET FN => RESULT
 107
 108 ARGUMENTS AND VALUES:
 109
 110   AGENT-SET: a NetLogo agentset
 111   FN: a function, run on each agent
 112   RESULT: undefined, commands don't return
 113
 114 DESCRIPTION:
 115
 116   ASK is equivalent to ask in NetLogo.
 117
 118   The specified AGENT-SET runs the given FN.  The order in which the agents
 119   are run is random each time, and only agents that are in the set at the
 120   beginning of the call.
 121
 122   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#ask"
 123  (let
 124   ((iter (shufflerator agent-set)))
 125   (loop
 126    :for agent := (funcall iter)
 127    :while agent
 128    :do (let ((*myself* *self*) (*self* agent)) (funcall fn)))))
 129
 130 (defun of (fn agent-set)
 131  "OF FN AGENT-SET => RESULT
 132
 133 ARGUMENTS AND VALUES:
 134
 135   FN: a function, run on each agent
 136   AGENT-SET: a NetLogo agentset
 137   RESULT: a list
 138
 139 DESCRIPTION:
 140
 141   OF is equivalent to of in NetLogo.
 142
 143   The specified AGENT-SET runs the given FN.  The order in which the agents
 144   are run is random each time, and only agents that are in the set at the
 145   beginning of the call.  A list is returned of the returned valuse of
 146   FN.
 147
 148   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#of"
 149  (let
 150   ((iter (shufflerator agent-set)))
 151   (loop
 152    :for agent := (funcall iter)
 153    :while agent
 154    :collect (let ((*myself* *self*) (*self* agent)) (funcall fn)))))
 155
 156 (defun shufflerator (agent-set)
 157  (let
 158   ((copy (copy-list agent-set))
 159    (i 0)
 160    (agent nil))
 161   (flet
 162    ((fetch ()
 163      (let
 164       ((idx (when (< i (1- (length copy))) (+ i (clnl-random:next-int (- (length copy) i))))))
 165       (when idx (setf agent (nth idx copy)))
 166       (when idx (setf (nth idx copy) (nth i copy)))
 167       (incf i))))
 168    (fetch) ; we pre-fetch because netlogo does, rng sync hype!
 169    (lambda ()
 170     (cond
 171      ((> i (length copy)) nil)
 172      ((= i (length copy)) (incf i) (car (last copy)))
 173      (t (let ((result agent)) (fetch) result)))))))
 174
 175 (defun random-float (n)
 176  "RANDOM-FLOAT N => RANDOM-NUMBER
 177
 178 ARGUMENTS AND VALUES:
 179
 180   N: a double, the upper bound of the random float
 181   RANDOM-NUMBER: a double, the random result
 182
 183 DESCRIPTION:
 184
 185   Returns a random number strictly closer to zero than N.
 186
 187   If number is positive, returns a random floating point number greater than
 188   or equal to 0 but strictly less than number.
 189
 190   If number is negative, returns a random floating point number less than or equal
 191   to 0, but strictly greater than number.
 192
 193   If number is zero, the result is always 0.
 194
 195   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#random-float"
 196  (clnl-random:next-double n))
 197
 198 (defun jump (n)
 199  (when (not (turtle-p *self*)) (error "Gotta call fd in turtle scope, dude (~A)" *self*))
 200  (setf
 201   (turtle-xcor *self*)
 202   (wrap-x *topology*
 203    (+ (turtle-xcor *self*) (* n (using-cached-sin (turtle-heading *self*))))))
 204  (setf
 205   (turtle-ycor *self*)
 206   (wrap-y *topology*
 207    (+ (turtle-ycor *self*) (* n (using-cached-cos (turtle-heading *self*)))))))
 208
 209 (defun forward (n)
 210  "FORWARD N => RESULT
 211
 212 ARGUMENTS AND VALUES:
 213
 214   N: a double, the amount the turtle moves forward
 215   RESULT: undefined
 216
 217 DESCRIPTION:
 218
 219   Moves the current turtle forward N steps, one step at a time.
 220
 221   This moves forward one at a time in order to make the view updates look
 222   good in the case of a purposefully slow running instance.  If the number
 223   is negative, the turtle moves backward.
 224
 225   If the current agent is not a turtle, it raises an error.
 226
 227   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#forward"
 228  (when (not (turtle-p *self*)) (error "Gotta call fd in turtle scope, dude (~A)" *self*))
 229  (labels
 230   ((internal (i)
 231     (cond
 232      ((< (abs i) 3.2e-15) nil)
 233      ((< (abs i) 1d0) (jump i))
 234      (t (jump (if (> i 0d0) 1d0 -1d0)) (internal (- i (if (> i 0d0) 1d0 -1d0)))))))
 235   (internal n)))
 236
 237 (defun turn-right (n)
 238  "TURN-RIGHT N => RESULT
 239
 240 ARGUMENTS AND VALUES:
 241
 242   N: a double, the amount the turtle turns
 243   RESULT: undefined
 244
 245 DESCRIPTION:
 246
 247   The turtle turns right by number degrees. (If number is negative, it turns left.)
 248
 249   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#right"
 250  (when (not (turtle-p *self*)) (error "Gotta call fd in turtle scope, dude (~A)" *self*))
 251  (let
 252   ((new-heading (+ (turtle-heading *self*) n)))
 253   (setf (turtle-heading *self*)
 254    (cond
 255     ((< new-heading 0) (+ (mod new-heading -360) 360))
 256     ((>= new-heading 360) (mod new-heading 360))
 257     (t new-heading)))))
 258
 259 (defun turn-left (n)
 260  "TURN-LEFT N => RESULT
 261
 262 ARGUMENTS AND VALUES:
 263
 264   N: a double, the amount the turtle turns
 265   RESULT: undefined
 266
 267 DESCRIPTION:
 268
 269   The turtle turns left by number degrees. (If number is negative, it turns right.)
 270
 271   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#right"
 272  (turn-right (- n)))
 273
 274 (defun create-turtles (n)
 275  "CREATE-TURTLES N => RESULT
 276
 277 ARGUMENTS AND VALUES:
 278
 279   N: an integer, the numbers of turtles to create
 280   RESULT: undefined
 281
 282 DESCRIPTION:
 283
 284   Creates number new turtles at the origin.
 285
 286   New turtles have random integer headings and the color is randomly selected
 287   from the 14 primary colors.  If commands are supplied, the new turtles
 288   immediately run them (unimplemented).
 289
 290   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#create-turtles"
 291  (loop :for i :from 1 :to n :do (create-turtle)))
 292
 293 (defun reset-ticks ()
 294  "RESET-TICKS => RESULT
 295
 296 ARGUMENTS AND VALUES:
 297
 298   RESULT: undefined
 299
 300 DESCRIPTION:
 301
 302   Resets the tick counter to zero, sets up all plots, then updates all plots.
 303
 304   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#reset-ticks"
 305  (setf *ticks* 0d0))
 306
 307 (defun tick ()
 308  "RESET-TICKS => RESULT
 309
 310 ARGUMENTS AND VALUES:
 311
 312   RESULT: undefined
 313
 314 DESCRIPTION:
 315
 316   Advances the tick counter by one and updates all plots.
 317
 318   If the tick counter has not been started yet with reset-ticks, an error results.
 319
 320   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#tick"
 321
 322  (when (not *ticks*) (error "reset-ticks must be called"))
 323  (incf *ticks*))
 324
 325 (defun ticks ()
 326  "TICKS => CURRENT-TICKS
 327
 328 ARGUMENTS AND VALUES:
 329
 330   CURRENT-TICKS: A positiv double, representing the current number of ticks
 331
 332 DESCRIPTION:
 333
 334   Reports the current value of the tick counter. The result is always a number and never negative.
 335
 336   If the tick counter has not been started yet with reset-ticks, an error results.
 337
 338   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#ticks"
 339  (when (not *ticks*) (error "reset-ticks must be called"))
 340  *ticks*)
 341
 342 (defun create-world (&key dims)
 343  "CREATE-WORLD &key DIMS => RESULT
 344
 345   DIMS: (:xmin XMIN :xmax XMAX :ymin YMIN :ymax YMAX)
 346
 347 ARGUMENTS AND VALUES:
 348
 349   RESULT: undefined
 350   XMIN: An integer representing the minimum patch coord in X
 351   XMAX: An integer representing the maximum patch coord in X
 352   YMIN: An integer representing the minimum patch coord in Y
 353   YMAX: An integer representing the maximum patch coord in Y
 354
 355 DESCRIPTION:
 356
 357   Initializes the world in the NVM.
 358
 359   This should be called before using the engine in any real capacity.  If
 360   called when an engine is already running, it may do somethign weird."
 361  (setf *dimensions* dims)
 362  (setf
 363   *patches*
 364   (loop
 365    :for y :from (max-pycor) :downto (min-pycor)
 366    :append (loop
 367             :for x :from (min-pxcor) :to (max-pxcor)
 368             :collect (make-patch
 369                       :xcor (coerce x 'double-float)
 370                       :ycor (coerce y 'double-float)
 371                       :color 0d0))))
 372  (setf *turtles* nil)
 373  (setf *current-id* 0))
 374
 375 ; These match netlogo's dump
 376 (defgeneric dump-object (o))
 377
 378 (defmethod dump-object ((n double-float))
 379  (multiple-value-bind (int rem) (floor n)
 380   (if (eql 0d0 rem)
 381    (format nil "~A" int)
 382    (let
 383     ((output (format nil "~D" n)))
 384     ; Someday we'll have d<posint>, but this is not that day!
 385     (cl-ppcre:regex-replace "d-" (cl-ppcre:regex-replace "d0" output "") "E-")))))
 386
 387 (defmethod dump-object ((o string)) o)
 388
 389 (defmethod dump-object ((o (eql t))) "true")
 390 (defmethod dump-object ((o (eql nil))) "false")
 391
 392 (defmethod dump-object ((o list)) (format nil "[~{~A~^ ~}]" (mapcar #'dump-object o)))
 393
 394 (defun current-state ()
 395  "CURRENT-STATE => WORLD-STATE
 396
 397 ARGUMENTS AND VALUES:
 398
 399   WORLD-STATE: A list, the current state of the whole world
 400
 401 DESCRIPTION:
 402
 403   Dumps out the state of the world.
 404
 405   This is useful for visualizations and also storing in a common lisp
 406   data structure for easy usage in a common lisp instance.  It's preferable
 407   to use this when working with the nvm than the output done by export-world.
 408
 409   Currently this only dumps out turtle and patch information.
 410
 411   This is called CURRENT-STATE because export-world is an actual primitive
 412   used by NetLogo."
 413  (list
 414   (mapcar
 415    (lambda (turtle)
 416     (list
 417      :color (turtle-color turtle)
 418      :xcor (turtle-xcor turtle)
 419      :ycor (turtle-ycor turtle)
 420      :heading (turtle-heading turtle)))
 421    *turtles*)
 422   (mapcar
 423    (lambda (patch)
 424     (list
 425      :color (patch-color patch)
 426      :xcor (patch-xcor patch)
 427      :ycor (patch-ycor patch)))
 428    *patches*)))
 429
 430 (defun export-turtles ()
 431  (append
 432   (list
 433    "\"TURTLES\""
 434    (format nil "~A~A"
 435     "\"who\",\"color\",\"heading\",\"xcor\",\"ycor\",\"shape\",\"label\",\"label-color\","
 436     "\"breed\",\"hidden?\",\"size\",\"pen-size\",\"pen-mode\""))
 437   (mapcar
 438    (lambda (turtle)
 439     (format nil
 440      "\"~A\",\"~A\",\"~A\",\"~A\",\"~A\",~A"
 441      (dump-object (turtle-who turtle))
 442      (dump-object (turtle-color turtle))
 443      (dump-object (turtle-heading turtle))
 444      (dump-object (turtle-xcor turtle))
 445      (dump-object (turtle-ycor turtle))
 446      "\"\"\"default\"\"\",\"\"\"\"\"\",\"9.9\",\"{all-turtles}\",\"false\",\"1\",\"1\",\"\"\"up\"\"\""))
 447    *turtles*)))
 448
 449 (defun export-patches ()
 450  (append
 451   (list
 452    "\"PATCHES\""
 453    "\"pxcor\",\"pycor\",\"pcolor\",\"plabel\",\"plabel-color\"")
 454   (mapcar
 455    (lambda (patch)
 456     (format nil
 457      "\"~A\",\"~A\",\"~A\",\"\"\"\"\"\",\"9.9\""
 458      (dump-object (patch-xcor patch))
 459      (dump-object (patch-ycor patch))
 460      (dump-object (patch-color patch))))
 461    *patches*)))
 462
 463 (defun export-world ()
 464  "EXPORT-WORLD => WORLD-CSV
 465
 466 ARGUMENTS AND VALUES:
 467
 468   WORLD-CSV: A string, the csv of the world
 469
 470 DESCRIPTION:
 471
 472   Dumps out a csv matching NetLogo's export world.
 473
 474   This is useful for serializing the current state of the engine in order
 475   to compare against NetLogo or to reimport later.  Contains everything needed
 476   to boot up a NetLogo instance in the exact same state."
 477  (format nil "~{~A~%~}"
 478   (list
 479    (format nil "~S" "RANDOM STATE")
 480    (format nil "~S" (clnl-random:export))
 481    ""
 482    (format nil "~S" "GLOBALS")
 483    (format nil "~A~A"
 484     "\"min-pxcor\",\"max-pxcor\",\"min-pycor\",\"max-pycor\",\"perspective\",\"subject\","
 485     "\"nextIndex\",\"directed-links\",\"ticks\",")
 486    (format nil "\"~A\",\"~A\",\"~A\",\"~A\",\"0\",\"nobody\",\"~A\",\"\"\"NEITHER\"\"\",\"-1\""
 487     (min-pxcor) (max-pxcor) (min-pycor) (max-pycor) *current-id*)
 488    ""
 489    (format nil "~{~A~^~%~}" (export-turtles))
 490    ""
 491    (format nil "~{~A~^~%~}" (export-patches))
 492    ""
 493    (format nil "~S" "LINKS")
 494    "\"end1\",\"end2\",\"color\",\"label\",\"label-color\",\"hidden?\",\"breed\",\"thickness\",\"shape\",\"tie-mode\""
 495    "")))