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