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