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 ()
  52  (setf
  53   *turtles*
  54   (nconc
  55    *turtles*
  56    (list
  57     (make-turtle
  58      :who (coerce *current-id* 'double-float)
  59      :color (coerce (+ 5 (* 10 (clnl-random:next-int 14))) 'double-float)
  60      :heading (coerce (clnl-random:next-int 360) 'double-float)
  61      :xcor 0d0
  62      :ycor 0d0))))
  63  (incf *current-id*))
  64
  65 (defun die ()
  66  "DIE => RESULT
  67
  68 ARGUMENTS AND VALUES:
  69
  70   RESULT: undefined, commands don't return
  71
  72 DESCRIPTION:
  73
  74   The turtle or link dies
  75
  76   A dead agent ceases to exist. The effects of this include:
  77   - The agent will not execute any further code.
  78   - The agent will disappear from any agentsets it was in, reducing the size of those agentsets by one.
  79   - Any variable that was storing the agent will now instead have nobody in it.
  80   - If the dead agent was a turtle, every link connected to it also dies.
  81   - If the observer was watching or following the agent, the observer's perspective resets.
  82
  83   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#die"
  84  (when (not (turtle-p *self*)) (error "Gotta call die in turtle scope, dude (~A)" *self*))
  85  (setf (turtle-who *self*) -1)
  86  (setf *turtles* (remove *self* *turtles*)))
  87
  88 (defun patches ()
  89  "PATCHES => ALL-PATCHES
  90
  91 ARGUMENTS AND VALUES:
  92
  93   ALL-PATCHES: a NetLogo agentset, all patches
  94
  95 DESCRIPTION:
  96
  97   Reports the agentset consisting of all the patches.
  98
  99   This agentset is special in that it represents the living patches
 100   each time it's used, so changes depending on the state of the engine.
 101
 102   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#patches"
 103  *patches*)
 104
 105 (defun turtles ()
 106  "TURTLES => ALL-TURTLES
 107
 108 ARGUMENTS AND VALUES:
 109
 110   ALL-TURTLES: a NetLogo agentset, all turtles
 111
 112 DESCRIPTION:
 113
 114   Reports the agentset consisting of all the turtles.
 115
 116   This agentset is special in that it represents the living turtles
 117   each time it's used, so changes depending on the state of the engine.
 118
 119   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#turtles"
 120  *turtles*)
 121
 122 (defun ask (agent-set fn)
 123  "ASK AGENT-SET FN => RESULT
 124
 125 ARGUMENTS AND VALUES:
 126
 127   AGENT-SET: a NetLogo agentset
 128   FN: a function, run on each agent
 129   RESULT: undefined, commands don't return
 130
 131 DESCRIPTION:
 132
 133   ASK is equivalent to ask in NetLogo.
 134
 135   The specified AGENT-SET runs the given FN.  The order in which the agents
 136   are run is random each time, and only agents that are in the set at the
 137   beginning of the call.
 138
 139   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#ask"
 140  (let
 141   ((iter (shufflerator (agent-set-list agent-set))))
 142   (loop
 143    :for agent := (funcall iter)
 144    :while agent
 145    :do (let ((*myself* *self*) (*self* agent)) (funcall fn)))))
 146
 147 (defun of (fn agent-set)
 148  "OF FN AGENT-SET => RESULT
 149
 150 ARGUMENTS AND VALUES:
 151
 152   FN: a function, run on each agent
 153   AGENT-SET: a NetLogo agentset
 154   RESULT: a list
 155
 156 DESCRIPTION:
 157
 158   OF is equivalent to of in NetLogo.
 159
 160   The specified AGENT-SET runs the given FN.  The order in which the agents
 161   are run is random each time, and only agents that are in the set at the
 162   beginning of the call.  A list is returned of the returned valuse of
 163   FN.
 164
 165   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#of"
 166  (let
 167   ((iter (shufflerator (agent-set-list agent-set))))
 168   (loop
 169    :for agent := (funcall iter)
 170    :while agent
 171    :collect (let ((*myself* *self*) (*self* agent)) (funcall fn)))))
 172
 173 (defun shufflerator (agent-set-list)
 174  (let
 175   ((copy (copy-list agent-set-list))
 176    (i 0)
 177    (agent nil))
 178   (flet
 179    ((fetch ()
 180      (let
 181       ((idx (when (< i (1- (length copy))) (+ i (clnl-random:next-int (- (length copy) i))))))
 182       (when idx (setf agent (nth idx copy)))
 183       (when idx (setf (nth idx copy) (nth i copy)))
 184       (incf i))))
 185    (fetch) ; we pre-fetch because netlogo does, rng sync hype!
 186    (lambda ()
 187     (cond
 188      ((> i (length copy)) nil)
 189      ((= i (length copy)) (incf i) (car (last copy)))
 190      (t (let ((result agent)) (fetch) result)))))))
 191
 192 (defun random-float (n)
 193  "RANDOM-FLOAT N => RANDOM-NUMBER
 194
 195 ARGUMENTS AND VALUES:
 196
 197   N: a double, the upper bound of the random float
 198   RANDOM-NUMBER: a double, the random result
 199
 200 DESCRIPTION:
 201
 202   Returns a random number strictly closer to zero than N.
 203
 204   If number is positive, returns a random floating point number greater than
 205   or equal to 0 but strictly less than number.
 206
 207   If number is negative, returns a random floating point number less than or equal
 208   to 0, but strictly greater than number.
 209
 210   If number is zero, the result is always 0.
 211
 212   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#random-float"
 213  (clnl-random:next-double n))
 214
 215 (defun random (n)
 216  "RANDOM N => RANDOM-NUMBER
 217
 218 ARGUMENTS AND VALUES:
 219
 220   N: an integer, the upper bound of the random
 221   RANDOM-NUMBER: an integer, the random result
 222
 223 DESCRIPTION:
 224
 225   Returns a random number strictly closer to zero than N.
 226
 227   If number is positive, returns a random integer greater than or equal to 0,
 228   but strictly less than number.
 229
 230   If number is negative, returns a random integer less than or equal to 0,
 231   but strictly greater than number.
 232
 233   If number is zero, the result is always 0.
 234
 235   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#random"
 236  (coerce (clnl-random:next-long (truncate n)) 'double-float))
 237
 238 (defun random-xcor ()
 239  "RANDOM-XCOR => RANDOM-NUMBER
 240
 241 ARGUMENTS AND VALUES:
 242
 243   RANDOM-NUMBER: a float, the random result
 244
 245 DESCRIPTION:
 246
 247   Returns a random floating point number in the allowable range of turtle
 248   coordinates along the x axis.
 249
 250   These range from min-pxcor - 0.5 (inclusive) to max-pxcor + 0.5 (exclusive)
 251
 252   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#random-cor"
 253  (let
 254   ((min (- (min-pxcor) 0.5d0))
 255    (max (+ (max-pxcor) 0.5d0)))
 256   (+ min (clnl-random:next-double (- max min)))))
 257
 258 (defun random-ycor ()
 259  "RANDOM-YCOR => RANDOM-NUMBER
 260
 261 ARGUMENTS AND VALUES:
 262
 263   RANDOM-NUMBER: a float, the random result
 264
 265 DESCRIPTION:
 266
 267   Returns a random floating point number in the allowable range of turtle
 268   coordinates along the y axis.
 269
 270   These range from min-pycor - 0.5 (inclusive) to max-pycor + 0.5 (exclusive)
 271
 272   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#random-cor"
 273  (let
 274   ((min (- (min-pycor) 0.5d0))
 275    (max (+ (max-pycor) 0.5d0)))
 276   (+ min (clnl-random:next-double (- max min)))))
 277
 278 (defun one-of (agent-set)
 279  "ONE-OF AGENT-SET => RESULT
 280
 281   RESULT: RANDOM-AGENT | :nobody
 282
 283 ARGUMENTS AND VALUES:
 284
 285   AGENT-SET: An agent set
 286   RANDOM-AGENT: an agent if AGENT-SET is non empty
 287
 288 DESCRIPTION:
 289
 290   From an agentset, returns a random agent. If the agentset is empty, returns nobody.
 291
 292   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#one-of"
 293  (let*
 294   ((agent-set-list (agent-set-list agent-set))
 295    (length (length agent-set-list)))
 296   (if (zerop length) :nobody (nth (clnl-random:next-int length) agent-set-list))))
 297
 298 (defun jump (n)
 299  (when (not (turtle-p *self*)) (error "Gotta call jump in turtle scope, dude (~A)" *self*))
 300  (setf
 301   (turtle-xcor *self*)
 302   (wrap-x *topology*
 303    (+ (turtle-xcor *self*) (* n (using-cached-sin (turtle-heading *self*))))))
 304  (setf
 305   (turtle-ycor *self*)
 306   (wrap-y *topology*
 307    (+ (turtle-ycor *self*) (* n (using-cached-cos (turtle-heading *self*)))))))
 308
 309 (defun setxy (x y)
 310  "SETXY X Y => RESULT
 311
 312 ARGUMENTS AND VALUES:
 313
 314   X: a double
 315   Y: a double
 316   RESULT: undefined
 317
 318 DESCRIPTION:
 319
 320   Sets the x-coordinate and y-coordinate for the turle.  Equivalent to
 321   set xcor x set ycor y, except it happens in one step inside of two.
 322
 323   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#setxy"
 324  (when (not (turtle-p *self*)) (error "Gotta call setxy in turtle scope, dude (~A)" *self*))
 325  (setf (turtle-xcor *self*) (wrap-x *topology* x))
 326  (setf (turtle-ycor *self*) (wrap-y *topology* y)))
 327
 328 (defun forward (n)
 329  "FORWARD N => RESULT
 330
 331 ARGUMENTS AND VALUES:
 332
 333   N: a double, the amount the turtle moves forward
 334   RESULT: undefined
 335
 336 DESCRIPTION:
 337
 338   Moves the current turtle forward N steps, one step at a time.
 339
 340   This moves forward one at a time in order to make the view updates look
 341   good in the case of a purposefully slow running instance.  If the number
 342   is negative, the turtle moves backward.
 343
 344   If the current agent is not a turtle, it raises an error.
 345
 346   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#forward"
 347  (when (not (turtle-p *self*)) (error "Gotta call fd in turtle scope, dude (~A)" *self*))
 348  (labels
 349   ((internal (i)
 350     (cond
 351      ((< (abs i) 3.2e-15) nil)
 352      ((< (abs i) 1d0) (jump i))
 353      (t (jump (if (> i 0d0) 1d0 -1d0)) (internal (- i (if (> i 0d0) 1d0 -1d0)))))))
 354   (internal n)))
 355
 356 (defun turn-right (n)
 357  "TURN-RIGHT N => RESULT
 358
 359 ARGUMENTS AND VALUES:
 360
 361   N: a double, the amount the turtle turns
 362   RESULT: undefined
 363
 364 DESCRIPTION:
 365
 366   The turtle turns right by number degrees. (If number is negative, it turns left.)
 367
 368   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#right"
 369  (when (not (turtle-p *self*)) (error "Gotta call fd in turtle scope, dude (~A)" *self*))
 370  (let
 371   ((new-heading (+ (turtle-heading *self*) n)))
 372   (setf (turtle-heading *self*)
 373    (cond
 374     ((< new-heading 0) (+ (mod new-heading -360) 360))
 375     ((>= new-heading 360) (mod new-heading 360))
 376     (t new-heading)))))
 377
 378 (defun turn-left (n)
 379  "TURN-LEFT N => RESULT
 380
 381 ARGUMENTS AND VALUES:
 382
 383   N: a double, the amount the turtle turns
 384   RESULT: undefined
 385
 386 DESCRIPTION:
 387
 388   The turtle turns left by number degrees. (If number is negative, it turns right.)
 389
 390   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#right"
 391  (turn-right (- n)))
 392
 393 (defun create-turtles (n)
 394  "CREATE-TURTLES N => RESULT
 395
 396 ARGUMENTS AND VALUES:
 397
 398   N: an integer, the numbers of turtles to create
 399   RESULT: undefined
 400
 401 DESCRIPTION:
 402
 403   Creates number new turtles at the origin.
 404
 405   New turtles have random integer headings and the color is randomly selected
 406   from the 14 primary colors.  If commands are supplied, the new turtles
 407   immediately run them (unimplemented).
 408
 409   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#create-turtles"
 410  (loop :for i :from 1 :to n :do (create-turtle)))
 411
 412 (defun reset-ticks ()
 413  "RESET-TICKS => RESULT
 414
 415 ARGUMENTS AND VALUES:
 416
 417   RESULT: undefined
 418
 419 DESCRIPTION:
 420
 421   Resets the tick counter to zero, sets up all plots, then updates all plots.
 422
 423   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#reset-ticks"
 424  (setf *ticks* 0d0))
 425
 426 (defun tick ()
 427  "RESET-TICKS => RESULT
 428
 429 ARGUMENTS AND VALUES:
 430
 431   RESULT: undefined
 432
 433 DESCRIPTION:
 434
 435   Advances the tick counter by one and updates all plots.
 436
 437   If the tick counter has not been started yet with reset-ticks, an error results.
 438
 439   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#tick"
 440
 441  (when (not *ticks*) (error "reset-ticks must be called"))
 442  (incf *ticks*))
 443
 444 (defun ticks ()
 445  "TICKS => CURRENT-TICKS
 446
 447 ARGUMENTS AND VALUES:
 448
 449   CURRENT-TICKS: A positiv double, representing the current number of ticks
 450
 451 DESCRIPTION:
 452
 453   Reports the current value of the tick counter. The result is always a number and never negative.
 454
 455   If the tick counter has not been started yet with reset-ticks, an error results.
 456
 457   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#ticks"
 458  (when (not *ticks*) (error "reset-ticks must be called"))
 459  *ticks*)
 460
 461 (defun create-world (&key dims)
 462  "CREATE-WORLD &key DIMS => RESULT
 463
 464   DIMS: (:xmin XMIN :xmax XMAX :ymin YMIN :ymax YMAX)
 465
 466 ARGUMENTS AND VALUES:
 467
 468   RESULT: undefined
 469   XMIN: An integer representing the minimum patch coord in X
 470   XMAX: An integer representing the maximum patch coord in X
 471   YMIN: An integer representing the minimum patch coord in Y
 472   YMAX: An integer representing the maximum patch coord in Y
 473
 474 DESCRIPTION:
 475
 476   Initializes the world in the NVM.
 477
 478   This should be called before using the engine in any real capacity.  If
 479   called when an engine is already running, it may do somethign weird."
 480  (setf *dimensions* dims)
 481  (setf
 482   *patches*
 483   (loop
 484    :for y :from (max-pycor) :downto (min-pycor)
 485    :append (loop
 486             :for x :from (min-pxcor) :to (max-pxcor)
 487             :collect (make-patch
 488                       :xcor (coerce x 'double-float)
 489                       :ycor (coerce y 'double-float)
 490                       :color 0d0))))
 491  (setf *turtles* nil)
 492  (setf *current-id* 0))
 493
 494 ; These match netlogo's dump
 495 (defgeneric dump-object (o))
 496
 497 (defmethod dump-object ((n double-float))
 498  (multiple-value-bind (int rem) (floor n)
 499   (if (eql 0d0 rem)
 500    (format nil "~A" int)
 501    (let
 502     ((output (format nil "~D" n)))
 503     ; Someday we'll have d<posint>, but this is not that day!
 504     (cl-ppcre:regex-replace "d-" (cl-ppcre:regex-replace "d0" output "") "E-")))))
 505
 506 (defmethod dump-object ((o string)) (format nil "~A" (cl-ppcre:regex-replace-all "\"" (format nil "~S" o) "\"\"")))
 507
 508 (defmethod dump-object ((o (eql t))) "true")
 509 (defmethod dump-object ((o (eql nil))) "false")
 510
 511 (defmethod dump-object ((o list)) (format nil "[~{~A~^ ~}]" (mapcar #'dump-object o)))
 512
 513 (defmethod dump-object ((o patch))
 514  (format nil "(patch ~A ~A)" (dump-object (patch-xcor o)) (dump-object (patch-ycor o))))
 515
 516 (defmethod dump-object ((o turtle)) (format nil "(turtle ~A)" (dump-object (turtle-who o))))
 517 (defmethod dump-object ((o (eql :nobody))) (format nil "nobody"))
 518
 519 (defun current-state ()
 520  "CURRENT-STATE => WORLD-STATE
 521
 522 ARGUMENTS AND VALUES:
 523
 524   WORLD-STATE: A list, the current state of the whole world
 525
 526 DESCRIPTION:
 527
 528   Dumps out the state of the world.
 529
 530   This is useful for visualizations and also storing in a common lisp
 531   data structure for easy usage in a common lisp instance.  It's preferable
 532   to use this when working with the nvm than the output done by export-world.
 533
 534   Currently this only dumps out turtle and patch information.
 535
 536   This is called CURRENT-STATE because export-world is an actual primitive
 537   used by NetLogo."
 538  (list
 539   (mapcar
 540    (lambda (turtle)
 541     (list
 542      :color (turtle-color turtle)
 543      :xcor (turtle-xcor turtle)
 544      :ycor (turtle-ycor turtle)
 545      :heading (turtle-heading turtle)
 546      :size (turtle-size turtle)))
 547    *turtles*)
 548   (mapcar
 549    (lambda (patch)
 550     (list
 551      :color (patch-color patch)
 552      :xcor (patch-xcor patch)
 553      :ycor (patch-ycor patch)))
 554    *patches*)))
 555
 556 (defun export-turtles ()
 557  (append
 558   (list
 559    "\"TURTLES\""
 560    (format nil "~A~A"
 561     "\"who\",\"color\",\"heading\",\"xcor\",\"ycor\",\"shape\",\"label\",\"label-color\","
 562     "\"breed\",\"hidden?\",\"size\",\"pen-size\",\"pen-mode\""))
 563   (mapcar
 564    (lambda (turtle)
 565     (format nil
 566      "\"~A\",\"~A\",\"~A\",\"~A\",\"~A\",\"\"\"default\"\"\",\"~A\",\"~A\",\"{all-turtles}\",\"false\",\"~A\",~A"
 567      (dump-object (turtle-who turtle))
 568      (dump-object (turtle-color turtle))
 569      (dump-object (turtle-heading turtle))
 570      (dump-object (turtle-xcor turtle))
 571      (dump-object (turtle-ycor turtle))
 572      (dump-object (turtle-label turtle))
 573      (dump-object (turtle-label-color turtle))
 574      (dump-object (turtle-size turtle))
 575      "\"1\",\"\"\"up\"\"\""))
 576    *turtles*)))
 577
 578 (defun export-patches ()
 579  (append
 580   (list
 581    "\"PATCHES\""
 582    "\"pxcor\",\"pycor\",\"pcolor\",\"plabel\",\"plabel-color\"")
 583   (mapcar
 584    (lambda (patch)
 585     (format nil
 586      "\"~A\",\"~A\",\"~A\",\"\"\"\"\"\",\"9.9\""
 587      (dump-object (patch-xcor patch))
 588      (dump-object (patch-ycor patch))
 589      (dump-object (patch-color patch))))
 590    *patches*)))
 591
 592 (defun export-world ()
 593  "EXPORT-WORLD => WORLD-CSV
 594
 595 ARGUMENTS AND VALUES:
 596
 597   WORLD-CSV: A string, the csv of the world
 598
 599 DESCRIPTION:
 600
 601   Dumps out a csv matching NetLogo's export world.
 602
 603   This is useful for serializing the current state of the engine in order
 604   to compare against NetLogo or to reimport later.  Contains everything needed
 605   to boot up a NetLogo instance in the exact same state."
 606  (format nil "~{~A~%~}"
 607   (list
 608    (format nil "~S" "RANDOM STATE")
 609    (format nil "~S" (clnl-random:export))
 610    ""
 611    (format nil "~S" "GLOBALS")
 612    (format nil "~A~A"
 613     "\"min-pxcor\",\"max-pxcor\",\"min-pycor\",\"max-pycor\",\"perspective\",\"subject\","
 614     "\"nextIndex\",\"directed-links\",\"ticks\",")
 615    (format nil "\"~A\",\"~A\",\"~A\",\"~A\",\"0\",\"nobody\",\"~A\",\"\"\"NEITHER\"\"\",\"-1\""
 616     (min-pxcor) (max-pxcor) (min-pycor) (max-pycor) *current-id*)
 617    ""
 618    (format nil "~{~A~^~%~}" (export-turtles))
 619    ""
 620    (format nil "~{~A~^~%~}" (export-patches))
 621    ""
 622    (format nil "~S" "LINKS")
 623    "\"end1\",\"end2\",\"color\",\"label\",\"label-color\",\"hidden?\",\"breed\",\"thickness\",\"shape\",\"tie-mode\""
 624    "")))