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