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 (&optional base-turtle)
  52  (let
  53   ((new-turtle (make-turtle
  54                 :who (coerce *current-id* 'double-float)
  55                 :color (if base-turtle
  56                         (turtle-color base-turtle)
  57                         (coerce (+ 5 (* 10 (clnl-random:next-int 14))) 'double-float))
  58                 :heading (if base-turtle
  59                           (turtle-heading base-turtle)
  60                           (coerce (clnl-random:next-int 360) 'double-float))
  61                 :shape (breed-default-shape :turtles)
  62                 :xcor (if base-turtle (turtle-xcor base-turtle) 0d0)
  63                 :ycor (if base-turtle (turtle-ycor base-turtle) 0d0))))
  64   (setf *turtles* (nconc *turtles* (list new-turtle)))
  65   (incf *current-id*)
  66   new-turtle))
  67
  68 (defun die ()
  69  "DIE => RESULT
  70
  71 ARGUMENTS AND VALUES:
  72
  73   RESULT: undefined, commands don't return
  74
  75 DESCRIPTION:
  76
  77   The turtle or link dies
  78
  79   A dead agent ceases to exist. The effects of this include:
  80   - The agent will not execute any further code.
  81   - The agent will disappear from any agentsets it was in, reducing the size of those agentsets by one.
  82   - Any variable that was storing the agent will now instead have nobody in it.
  83   - If the dead agent was a turtle, every link connected to it also dies.
  84   - If the observer was watching or following the agent, the observer's perspective resets.
  85
  86   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#die"
  87  (when (not (turtle-p *self*)) (error "Gotta call die in turtle scope, dude (~A)" *self*))
  88  (setf (turtle-who *self*) -1)
  89  (setf *turtles* (remove *self* *turtles*)))
  90
  91 (defun patches ()
  92  "PATCHES => ALL-PATCHES
  93
  94 ARGUMENTS AND VALUES:
  95
  96   ALL-PATCHES: a NetLogo agentset, all patches
  97
  98 DESCRIPTION:
  99
 100   Reports the agentset consisting of all the patches.
 101
 102   This agentset is special in that it represents the living patches
 103   each time it's used, so changes depending on the state of the engine.
 104
 105   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#patches"
 106  :patches)
 107
 108 (defun turtles ()
 109  "TURTLES => ALL-TURTLES
 110
 111 ARGUMENTS AND VALUES:
 112
 113   ALL-TURTLES: a NetLogo agentset, all turtles
 114
 115 DESCRIPTION:
 116
 117   Reports the agentset consisting of all the turtles.
 118
 119   This agentset is special in that it represents the living turtles
 120   each time it's used, so changes depending on the state of the engine.
 121
 122   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#turtles"
 123  :turtles)
 124
 125 (defun ask (agent-or-agentset fn)
 126  "ASK AGENT-OR-AGENTSET FN => RESULT
 127
 128   AGENT-OR-AGENTSET: AGENT | AGENTSET
 129
 130 ARGUMENTS AND VALUES:
 131
 132   FN: a function, run on each agent
 133   RESULT: undefined, commands don't return
 134   AGENT: a NetLogo agent
 135   AGENTSET: a NetLogo agentset
 136
 137 DESCRIPTION:
 138
 139   ASK is equivalent to ask in NetLogo.
 140
 141   The specified AGENTSET or AGENT runs the given FN.  In the case of an
 142   AGENTSET, the order in which the agents are run is random each time,
 143   and only agents that are in the set at the beginning of the call.
 144
 145   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#ask"
 146  (cond
 147   ((agentset-p agent-or-agentset)
 148    (let
 149     ((iter (shufflerator (agentset-list agent-or-agentset))))
 150     (loop
 151      :for agent := (funcall iter)
 152      :while agent
 153      :do (let ((*myself* *self*) (*self* agent)) (funcall fn)))))
 154   ((agent-p agent-or-agentset)
 155    (let ((*myself* *self*) (*self* agent-or-agentset)) (funcall fn)))
 156   (t
 157    (error "Ask requires an agentset or agent but got: ~A" agent-or-agentset))))
 158
 159 (defun count (agentset)
 160  "COUNT AGENTSET => N
 161
 162 ARGUMENTS AND VALUES:
 163
 164   AGENTSET: a NetLogo agentset
 165   N: a number
 166
 167 DESCRIPTION:
 168
 169   COUNT is equivalent to count in NetLogo.  Returns N, the number of
 170   agents in AGENTSET.
 171
 172   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#count"
 173  (coerce (length (agentset-list agentset)) 'double-float))
 174
 175 (defun clear-all ()
 176  "CLEAR-ALL => RESULT
 177
 178 ARGUMENTS AND VALUES:
 179
 180   RESULT: undefined
 181
 182 DESCRIPTION:
 183
 184   Clears ticks, turtles, patches, globals (unimplemented).
 185
 186   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#clear-all"
 187  (clear-turtles)
 188  (clear-patches)
 189  (clear-ticks))
 190
 191 (defun display ()
 192  "DISPLAY => RESULT
 193
 194 ARGUMENTS AND VALUES:
 195
 196   RESULT: undefined
 197
 198 DESCRIPTION:
 199
 200   As of yet, this does nothing.  A placeholder method for forced dipslay
 201   updates from the engine.
 202
 203   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#display"
 204  nil)
 205
 206 (defun of (fn agent-or-agentset)
 207  "OF FN AGENT-OR-AGENTSET => RESULT
 208
 209   AGENT-OR-AGENTSET: AGENT | AGENTSET
 210   RESULT: RESULT-LIST | RESULT-VALUE
 211
 212 ARGUMENTS AND VALUES:
 213
 214   FN: a function, run on each agent
 215   AGENT: a NetLogo agent
 216   AGENTSET: a NetLogo agentset
 217   RESULT-LIST: a list
 218   RESULT-VALUE: a single value
 219
 220 DESCRIPTION:
 221
 222   OF is equivalent to of in NetLogo.
 223
 224   The specified AGENTSET or AGENT runs the given FN.  In the case of an
 225   AGENTSET, the order in which the agents are run is random each time,
 226   and only agents that are in the set at the beginning of the call.
 227
 228   RESULT-LIST is returned when the input is an AGENTSET, but RESULT-VALUE
 229   is returned when only passed an AGENT.
 230
 231   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#of"
 232  (cond
 233   ((agentset-p agent-or-agentset)
 234    (let
 235     ((iter (shufflerator (agentset-list agent-or-agentset))))
 236     (loop
 237      :for agent := (funcall iter)
 238      :while agent
 239      :collect (let ((*myself* *self*) (*self* agent)) (funcall fn)))))
 240   ((agent-p agent-or-agentset)
 241    (let ((*myself* *self*) (*self* agent-or-agentset)) (funcall fn)))
 242   (t
 243    (error "Of requires an agentset or agent but got: ~A" agent-or-agentset))))
 244
 245 (defun with (agentset fn)
 246  "WITH AGENTSET FN => RESULT-AGENTSET
 247
 248 ARGUMENTS AND VALUES:
 249
 250   AGENTSET: a NetLogo agentset
 251   FN: a boolean function, run on each agent to determine if included
 252   RESULT-AGENTSET: an agentset of valid agents
 253
 254 DESCRIPTION:
 255
 256   WITH is equivalent to with in NetLogo.
 257
 258   Returns a new agentset containing only those agents that reported true
 259   when FN is called.
 260
 261   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#with"
 262  (list->agentset
 263   (remove-if-not
 264    (lambda (agent)
 265     (let ((*myself* *self*) (*self* agent)) (funcall fn)))
 266    (agentset-list agentset))
 267   (agentset-breed agentset)))
 268
 269 (defun shufflerator (agentset-list)
 270  (let
 271   ((copy (copy-list agentset-list))
 272    (i 0)
 273    (agent nil))
 274   (flet
 275    ((fetch ()
 276      (let
 277       ((idx (when (< i (1- (length copy))) (+ i (clnl-random:next-int (- (length copy) i))))))
 278       (when idx (setf agent (nth idx copy)))
 279       (when idx (setf (nth idx copy) (nth i copy)))
 280       (incf i))))
 281    (fetch) ; we pre-fetch because netlogo does, rng sync hype!
 282    (lambda ()
 283     (cond
 284      ((> i (length copy)) nil)
 285      ((= i (length copy)) (incf i) (car (last copy)))
 286      (t (let ((result agent)) (fetch) result)))))))
 287
 288 (defun random-float (n)
 289  "RANDOM-FLOAT N => RANDOM-NUMBER
 290
 291 ARGUMENTS AND VALUES:
 292
 293   N: a double, the upper bound of the random float
 294   RANDOM-NUMBER: a double, the random result
 295
 296 DESCRIPTION:
 297
 298   Returns a random number strictly closer to zero than N.
 299
 300   If number is positive, returns a random floating point number greater than
 301   or equal to 0 but strictly less than number.
 302
 303   If number is negative, returns a random floating point number less than or equal
 304   to 0, but strictly greater than number.
 305
 306   If number is zero, the result is always 0.
 307
 308   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#random-float"
 309  (clnl-random:next-double n))
 310
 311 (defun random (n)
 312  "RANDOM N => RANDOM-NUMBER
 313
 314 ARGUMENTS AND VALUES:
 315
 316   N: an integer, the upper bound of the random
 317   RANDOM-NUMBER: an integer, the random result
 318
 319 DESCRIPTION:
 320
 321   Returns a random number strictly closer to zero than N.
 322
 323   If number is positive, returns a random integer greater than or equal to 0,
 324   but strictly less than number.
 325
 326   If number is negative, returns a random integer less than or equal to 0,
 327   but strictly greater than number.
 328
 329   If number is zero, the result is always 0.
 330
 331   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#random"
 332  (coerce (clnl-random:next-long (truncate n)) 'double-float))
 333
 334 (defun random-xcor ()
 335  "RANDOM-XCOR => RANDOM-NUMBER
 336
 337 ARGUMENTS AND VALUES:
 338
 339   RANDOM-NUMBER: a float, the random result
 340
 341 DESCRIPTION:
 342
 343   Returns a random floating point number in the allowable range of turtle
 344   coordinates along the x axis.
 345
 346   These range from min-pxcor - 0.5 (inclusive) to max-pxcor + 0.5 (exclusive)
 347
 348   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#random-cor"
 349  (let
 350   ((min (- (min-pxcor) 0.5d0))
 351    (max (+ (max-pxcor) 0.5d0)))
 352   (+ min (clnl-random:next-double (- max min)))))
 353
 354 (defun random-ycor ()
 355  "RANDOM-YCOR => RANDOM-NUMBER
 356
 357 ARGUMENTS AND VALUES:
 358
 359   RANDOM-NUMBER: a float, the random result
 360
 361 DESCRIPTION:
 362
 363   Returns a random floating point number in the allowable range of turtle
 364   coordinates along the y axis.
 365
 366   These range from min-pycor - 0.5 (inclusive) to max-pycor + 0.5 (exclusive)
 367
 368   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#random-cor"
 369  (let
 370   ((min (- (min-pycor) 0.5d0))
 371    (max (+ (max-pycor) 0.5d0)))
 372   (+ min (clnl-random:next-double (- max min)))))
 373
 374 (defun one-of (list-or-agentset)
 375  "ONE-OF LIST-OR-AGENTSET => RESULT
 376
 377   LIST-OR-AGENTSET: LIST | AGENTSET
 378   RESULT: RANDOM-VALUE | RANDOM-AGENT | :nobody
 379
 380 ARGUMENTS AND VALUES:
 381
 382   LIST: A list
 383   AGENTSET: An agent set
 384   RANDOM-VALUE: a value in LIST
 385   RANDOM-AGENT: an agent if AGENTSET is non empty
 386
 387 DESCRIPTION:
 388
 389   From an AGENTSET, returns a RANDOM-AGENT. If the agentset is empty, returns :nobody.
 390   From a list, returns a RANDOM-VALUE.  If the list is empty, an error occurs.
 391
 392   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#one-of"
 393  (cond
 394   ((agentset-p list-or-agentset)
 395    (let*
 396     ((agentset-list (agentset-list list-or-agentset))
 397      (length (length agentset-list)))
 398     (if (zerop length) :nobody (nth (clnl-random:next-int length) agentset-list))))
 399   ((listp list-or-agentset)
 400    (let*
 401     ((length (length list-or-agentset)))
 402     (if (zerop length)
 403      (error "one-of requires a nonempty list")
 404      (nth (clnl-random:next-int length) list-or-agentset))))
 405   (t (error "one-of requires a list or agentset"))))
 406
 407 (defun jump (n)
 408  (when (not (turtle-p *self*)) (error "Gotta call jump in turtle scope, dude (~A)" *self*))
 409  (setf
 410   (turtle-xcor *self*)
 411   (wrap-x *topology*
 412    (+ (turtle-xcor *self*) (* n (using-cached-sin (turtle-heading *self*))))))
 413  (setf
 414   (turtle-ycor *self*)
 415   (wrap-y *topology*
 416    (+ (turtle-ycor *self*) (* n (using-cached-cos (turtle-heading *self*)))))))
 417
 418 (defun setxy (x y)
 419  "SETXY X Y => RESULT
 420
 421 ARGUMENTS AND VALUES:
 422
 423   X: a double
 424   Y: a double
 425   RESULT: undefined
 426
 427 DESCRIPTION:
 428
 429   Sets the x-coordinate and y-coordinate for the turle.  Equivalent to
 430   set xcor x set ycor y, except it happens in one step inside of two.
 431
 432   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#setxy"
 433  (when (not (turtle-p *self*)) (error "Gotta call setxy in turtle scope, dude (~A)" *self*))
 434  (setf (turtle-xcor *self*) (wrap-x *topology* x))
 435  (setf (turtle-ycor *self*) (wrap-y *topology* y)))
 436
 437 (defun set-default-shape (breed shape)
 438  "SET-DEFAULT-SHAPE BREED SHAPE => RESULT
 439
 440 ARGUMENTS AND VALUES:
 441
 442   BREED: a valid breed
 443   SHAPE: a string
 444   RESULT: undefined
 445
 446 DESCRIPTION:
 447
 448   Specifies a default initial shape for a BREED. When a turtle, or it changes breeds,
 449   its shape is set to the given shape.
 450
 451   SET-DEFAULT-SHAPE doesn't affect existing agents, only agents you create afterwards.
 452
 453   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#set-default-shape"
 454  (when (not (breed-p breed)) (error "Need a valid breed"))
 455  (setf (breed-default-shape breed) shape))
 456
 457 (defun forward (n)
 458  "FORWARD N => RESULT
 459
 460 ARGUMENTS AND VALUES:
 461
 462   N: a double, the amount the turtle moves forward
 463   RESULT: undefined
 464
 465 DESCRIPTION:
 466
 467   Moves the current turtle forward N steps, one step at a time.
 468
 469   This moves forward one at a time in order to make the view updates look
 470   good in the case of a purposefully slow running instance.  If the number
 471   is negative, the turtle moves backward.
 472
 473   If the current agent is not a turtle, it raises an error.
 474
 475   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#forward"
 476  (when (not (turtle-p *self*)) (error "Gotta call fd in turtle scope, dude (~A)" *self*))
 477  (labels
 478   ((internal (i)
 479     (cond
 480      ((< (abs i) 3.2e-15) nil)
 481      ((< (abs i) 1d0) (jump i))
 482      (t (jump (if (> i 0d0) 1d0 -1d0)) (internal (- i (if (> i 0d0) 1d0 -1d0)))))))
 483   (internal n)))
 484
 485 (defun turn-right (n)
 486  "TURN-RIGHT N => RESULT
 487
 488 ARGUMENTS AND VALUES:
 489
 490   N: a double, the amount the turtle turns
 491   RESULT: undefined
 492
 493 DESCRIPTION:
 494
 495   The turtle turns right by number degrees. (If number is negative, it turns left.)
 496
 497   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#right"
 498  (when (not (turtle-p *self*)) (error "Gotta call fd in turtle scope, dude (~A)" *self*))
 499  (let
 500   ((new-heading (+ (turtle-heading *self*) n)))
 501   (setf (turtle-heading *self*)
 502    (cond
 503     ((< new-heading 0) (+ (mod new-heading -360) 360))
 504     ((>= new-heading 360) (mod new-heading 360))
 505     (t new-heading)))))
 506
 507 (defun turn-left (n)
 508  "TURN-LEFT N => RESULT
 509
 510 ARGUMENTS AND VALUES:
 511
 512   N: a double, the amount the turtle turns
 513   RESULT: undefined
 514
 515 DESCRIPTION:
 516
 517   The turtle turns left by number degrees. (If number is negative, it turns right.)
 518
 519   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#right"
 520  (turn-right (- n)))
 521
 522 (defun create-turtles (n &optional fn)
 523  "CREATE-TURTLES N &optional FN => RESULT
 524
 525 ARGUMENTS AND VALUES:
 526
 527   N: an integer, the numbers of turtles to create
 528   FN: A function, applied to each turtle after creation
 529   RESULT: undefined
 530
 531 DESCRIPTION:
 532
 533   Creates number new turtles at the origin.
 534
 535   New turtles have random integer headings and the color is randomly selected
 536   from the 14 primary colors.  If a function is supplied, the new turtles
 537   immediately run it.
 538
 539   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#create-turtles"
 540  (let
 541   ((new-turtles (loop :repeat n :collect (create-turtle))))
 542   (when fn (ask (list->agentset new-turtles :turtles) fn))))
 543
 544 (defun hatch (n &optional fn)
 545  "HATCH N &optional FN => RESULT
 546
 547 ARGUMENTS AND VALUES:
 548
 549   N: an integer, the numbers of turtles to hatch
 550   FN: A function, applied to each turtle after creation
 551   RESULT: undefined
 552
 553 DESCRIPTION:
 554
 555   The turtle in *self* creates N new turtles. Each new turtle inherits of all its
 556   variables, including its location, from self.
 557
 558   If FN is supplied, the new turtles immediately run it.
 559
 560   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#hatch"
 561  (when (not (turtle-p *self*)) (error "Can only hatch from turtle scope"))
 562  (let
 563   ((new-turtles (loop :repeat n :collect (create-turtle *self*))))
 564   (when fn (ask (list->agentset new-turtles :turtles) fn))))
 565
 566 (defun reset-ticks ()
 567  "RESET-TICKS => RESULT
 568
 569 ARGUMENTS AND VALUES:
 570
 571   RESULT: undefined
 572
 573 DESCRIPTION:
 574
 575   Resets the tick counter to zero, sets up all plots, then updates all plots.
 576
 577   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#reset-ticks"
 578  (setf *ticks* 0d0))
 579
 580 (defun tick ()
 581  "RESET-TICKS => RESULT
 582
 583 ARGUMENTS AND VALUES:
 584
 585   RESULT: undefined
 586
 587 DESCRIPTION:
 588
 589   Advances the tick counter by one and updates all plots.
 590
 591   If the tick counter has not been started yet with reset-ticks, an error results.
 592
 593   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#tick"
 594
 595  (when (not *ticks*) (error "reset-ticks must be called"))
 596  (incf *ticks*))
 597
 598 (defun ticks ()
 599  "TICKS => CURRENT-TICKS
 600
 601 ARGUMENTS AND VALUES:
 602
 603   CURRENT-TICKS: A positiv double, representing the current number of ticks
 604
 605 DESCRIPTION:
 606
 607   Reports the current value of the tick counter. The result is always a number and never negative.
 608
 609   If the tick counter has not been started yet with reset-ticks, an error results.
 610
 611   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#ticks"
 612  (when (not *ticks*) (error "reset-ticks must be called"))
 613  *ticks*)
 614
 615 (defun clear-patches ()
 616  (setf
 617   *patches*
 618   (loop
 619    :for y :from (max-pycor) :downto (min-pycor)
 620    :append (loop
 621             :for x :from (min-pxcor) :to (max-pxcor)
 622             :collect (make-patch
 623                       :xcor (coerce x 'double-float)
 624                       :ycor (coerce y 'double-float)
 625                       :color 0d0)))))
 626
 627 (defun clear-turtles ()
 628  (setf *turtles* nil)
 629  (setf *current-id* 0))
 630
 631 (defun clear-ticks ()
 632  (setf *ticks* nil))
 633
 634 (defun create-world (&key dims)
 635  "CREATE-WORLD &key DIMS => RESULT
 636
 637   DIMS: (:xmin XMIN :xmax XMAX :ymin YMIN :ymax YMAX)
 638
 639 ARGUMENTS AND VALUES:
 640
 641   RESULT: undefined
 642   XMIN: An integer representing the minimum patch coord in X
 643   XMAX: An integer representing the maximum patch coord in X
 644   YMIN: An integer representing the minimum patch coord in Y
 645   YMAX: An integer representing the maximum patch coord in Y
 646
 647 DESCRIPTION:
 648
 649   Initializes the world in the NVM.
 650
 651   This should be called before using the engine in any real capacity.  If
 652   called when an engine is already running, it may do somethign weird."
 653  (setf *dimensions* dims)
 654  (setf *breeds* (list (list :turtles "default")))
 655  (clear-ticks)
 656  (clear-patches)
 657  (clear-turtles))
 658
 659 ; These match netlogo's dump
 660 (defgeneric dump-object (o))
 661
 662 (defmethod dump-object ((n double-float))
 663  (multiple-value-bind (int rem) (floor n)
 664   (if (eql 0d0 rem)
 665    (format nil "~A" int)
 666    (let
 667     ((output (format nil "~D" n)))
 668     ; Someday we'll have d<posint>, but this is not that day!
 669     (cl-ppcre:regex-replace "d-" (cl-ppcre:regex-replace "d0" output "") "E-")))))
 670
 671 (defmethod dump-object ((o string)) (format nil "~A" (cl-ppcre:regex-replace-all "\"" (format nil "~S" o) "\"\"")))
 672
 673 (defmethod dump-object ((o (eql t))) "true")
 674 (defmethod dump-object ((o (eql nil))) "false")
 675
 676 (defmethod dump-object ((o list))
 677  (cond
 678   ((agentset-p o) (format nil "(agentset, ~A ~A)" (dump-object (count o)) (string-downcase (agentset-breed o))))
 679   (t (format nil "[~{~A~^ ~}]" (mapcar #'dump-object o)))))
 680
 681 (defmethod dump-object ((o patch))
 682  (format nil "(patch ~A ~A)" (dump-object (patch-xcor o)) (dump-object (patch-ycor o))))
 683
 684 (defmethod dump-object ((o turtle)) (format nil "(turtle ~A)" (dump-object (turtle-who o))))
 685 (defmethod dump-object ((o (eql :nobody))) (format nil "nobody"))
 686
 687 (defun current-state ()
 688  "CURRENT-STATE => WORLD-STATE
 689
 690 ARGUMENTS AND VALUES:
 691
 692   WORLD-STATE: A list, the current state of the whole world
 693
 694 DESCRIPTION:
 695
 696   Dumps out the state of the world.
 697
 698   This is useful for visualizations and also storing in a common lisp
 699   data structure for easy usage in a common lisp instance.  It's preferable
 700   to use this when working with the nvm than the output done by export-world.
 701
 702   Currently this only dumps out turtle and patch information.
 703
 704   This is called CURRENT-STATE because export-world is an actual primitive
 705   used by NetLogo."
 706  (list
 707   (mapcar
 708    (lambda (turtle)
 709     (list
 710      :color (turtle-color turtle)
 711      :xcor (turtle-xcor turtle)
 712      :ycor (turtle-ycor turtle)
 713      :heading (turtle-heading turtle)
 714      :size (turtle-size turtle)))
 715    *turtles*)
 716   (mapcar
 717    (lambda (patch)
 718     (list
 719      :color (patch-color patch)
 720      :xcor (patch-xcor patch)
 721      :ycor (patch-ycor patch)))
 722    *patches*)))
 723
 724 (defun export-turtles ()
 725  (append
 726   (list
 727    "\"TURTLES\""
 728    (format nil "~A~A"
 729     "\"who\",\"color\",\"heading\",\"xcor\",\"ycor\",\"shape\",\"label\",\"label-color\","
 730     "\"breed\",\"hidden?\",\"size\",\"pen-size\",\"pen-mode\""))
 731   (mapcar
 732    (lambda (turtle)
 733     (format nil
 734      "\"~A\",\"~A\",\"~A\",\"~A\",\"~A\",\"~A\",\"~A\",\"~A\",\"{all-turtles}\",\"false\",\"~A\",~A"
 735      (dump-object (turtle-who turtle))
 736      (dump-object (turtle-color turtle))
 737      (dump-object (turtle-heading turtle))
 738      (dump-object (turtle-xcor turtle))
 739      (dump-object (turtle-ycor turtle))
 740      (dump-object (turtle-shape turtle))
 741      (dump-object (turtle-label turtle))
 742      (dump-object (turtle-label-color turtle))
 743      (dump-object (turtle-size turtle))
 744      "\"1\",\"\"\"up\"\"\""))
 745    *turtles*)))
 746
 747 (defun export-patches ()
 748  (append
 749   (list
 750    "\"PATCHES\""
 751    "\"pxcor\",\"pycor\",\"pcolor\",\"plabel\",\"plabel-color\"")
 752   (mapcar
 753    (lambda (patch)
 754     (format nil
 755      "\"~A\",\"~A\",\"~A\",\"\"\"\"\"\",\"9.9\""
 756      (dump-object (patch-xcor patch))
 757      (dump-object (patch-ycor patch))
 758      (dump-object (patch-color patch))))
 759    *patches*)))
 760
 761 (defun export-world ()
 762  "EXPORT-WORLD => WORLD-CSV
 763
 764 ARGUMENTS AND VALUES:
 765
 766   WORLD-CSV: A string, the csv of the world
 767
 768 DESCRIPTION:
 769
 770   Dumps out a csv matching NetLogo's export world.
 771
 772   This is useful for serializing the current state of the engine in order
 773   to compare against NetLogo or to reimport later.  Contains everything needed
 774   to boot up a NetLogo instance in the exact same state."
 775  (format nil "~{~A~%~}"
 776   (list
 777    (format nil "~S" "RANDOM STATE")
 778    (format nil "~S" (clnl-random:export))
 779    ""
 780    (format nil "~S" "GLOBALS")
 781    (format nil "~A~A"
 782     "\"min-pxcor\",\"max-pxcor\",\"min-pycor\",\"max-pycor\",\"perspective\",\"subject\","
 783     "\"nextIndex\",\"directed-links\",\"ticks\",")
 784    (format nil "\"~A\",\"~A\",\"~A\",\"~A\",\"0\",\"nobody\",\"~A\",\"\"\"NEITHER\"\"\",\"-1\""
 785     (min-pxcor) (max-pxcor) (min-pycor) (max-pycor) *current-id*)
 786    ""
 787    (format nil "~{~A~^~%~}" (export-turtles))
 788    ""
 789    (format nil "~{~A~^~%~}" (export-patches))
 790    ""
 791    (format nil "~S" "LINKS")
 792    "\"end1\",\"end2\",\"color\",\"label\",\"label-color\",\"hidden?\",\"breed\",\"thickness\",\"shape\",\"tie-mode\""
 793    "")))