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