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