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