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