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