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