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 *current-id*
  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 turtles ()
  89  "TURTLES => ALL-TURTLES
  90
  91 ARGUMENTS AND VALUES:
  92
  93   ALL-TURTLES: a NetLogo agentset, all turtles
  94
  95 DESCRIPTION:
  96
  97   Reports the agentset consisting of all the turtles.
  98
  99   This agentset is special in that it represents the living turtles
 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#turtles"
 103  *turtles*)
 104
 105 (defun ask (agent-set fn)
 106  "ASK AGENT-SET FN => RESULT
 107
 108 ARGUMENTS AND VALUES:
 109
 110   AGENT-SET: a NetLogo agentset
 111   FN: a function, run on each agent
 112   RESULT: undefined, commands don't return
 113
 114 DESCRIPTION:
 115
 116   ASK is equivalent to ask in NetLogo.
 117
 118   The specified AGENT-SET runs the given FN.  The order in which the agents
 119   are run is random each time, and only agents that are in the set at the
 120   beginning of the call.
 121
 122   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#ask"
 123  (let
 124   ((iter (shufflerator agent-set)))
 125   (loop
 126    :for agent := (funcall iter)
 127    :while agent
 128    :do (let ((*myself* *self*) (*self* agent)) (funcall fn)))))
 129
 130 (defun shufflerator (agent-set)
 131  (let
 132   ((copy (copy-list agent-set))
 133    (i 0)
 134    (agent nil))
 135   (flet
 136    ((fetch ()
 137      (let
 138       ((idx (when (< i (1- (length copy))) (+ i (clnl-random:next-int (- (length copy) i))))))
 139       (when idx (setf agent (nth idx copy)))
 140       (when idx (setf (nth idx copy) (nth i copy)))
 141       (incf i))))
 142    (fetch) ; we pre-fetch because netlogo does, rng sync hype!
 143    (lambda ()
 144     (cond
 145      ((> i (length copy)) nil)
 146      ((= i (length copy)) (incf i) (car (last copy)))
 147      (t (let ((result agent)) (fetch) result)))))))
 148
 149 (defun random-float (n)
 150  "RANDOM-FLOAT N => RANDOM-NUMBER
 151
 152 ARGUMENTS AND VALUES:
 153
 154   N: a double, the upper bound of the random float
 155   RANDOM-NUMBER: a double, the random result
 156
 157 DESCRIPTION:
 158
 159   Returns a random number strictly closer to zero than N.
 160
 161   If number is positive, returns a random floating point number greater than
 162   or equal to 0 but strictly less than number.
 163
 164   If number is negative, returns a random floating point number less than or equal
 165   to 0, but strictly greater than number.
 166
 167   If number is zero, the result is always 0.
 168
 169   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#random-float"
 170  (clnl-random:next-double n))
 171
 172 (defun jump (n)
 173  (when (not (turtle-p *self*)) (error "Gotta call fd in turtle scope, dude (~A)" *self*))
 174  (setf
 175   (turtle-xcor *self*)
 176   (wrap-x *topology*
 177    (+ (turtle-xcor *self*) (* n (using-cached-sin (turtle-heading *self*))))))
 178  (setf
 179   (turtle-ycor *self*)
 180   (wrap-y *topology*
 181    (+ (turtle-ycor *self*) (* n (using-cached-cos (turtle-heading *self*)))))))
 182
 183 (defun forward (n)
 184  "FORWARD N => RESULT
 185
 186 ARGUMENTS AND VALUES:
 187
 188   N: a double, the amount the turtle moves forward
 189   RESULT: undefined
 190
 191 DESCRIPTION:
 192
 193   Moves the current turtle forward N steps, one step at a time.
 194
 195   This moves forward one at a time in order to make the view updates look
 196   good in the case of a purposefully slow running instance.  If the number
 197   is negative, the turtle moves backward.
 198
 199   If the current agent is not a turtle, it raises an error.
 200
 201   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#forward"
 202  (when (not (turtle-p *self*)) (error "Gotta call fd in turtle scope, dude (~A)" *self*))
 203  (labels
 204   ((internal (i)
 205     (cond
 206      ((< (abs i) 3.2e-15) nil)
 207      ((< (abs i) 1d0) (jump i))
 208      (t (jump (if (> i 0d0) 1d0 -1d0)) (internal (- i (if (> i 0d0) 1d0 -1d0)))))))
 209   (internal n)))
 210
 211 (defun turn-right (n)
 212  "TURN-RIGHT N => RESULT
 213
 214 ARGUMENTS AND VALUES:
 215
 216   N: a double, the amount the turtle turns
 217   RESULT: undefined
 218
 219 DESCRIPTION:
 220
 221   The turtle turns right by number degrees. (If number is negative, it turns left.)
 222
 223   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#right"
 224  (when (not (turtle-p *self*)) (error "Gotta call fd in turtle scope, dude (~A)" *self*))
 225  (let
 226   ((new-heading (+ (turtle-heading *self*) n)))
 227   (setf (turtle-heading *self*)
 228    (cond
 229     ((< new-heading 0) (+ (mod new-heading -360) 360))
 230     ((>= new-heading 360) (mod new-heading 360))
 231     (t new-heading)))))
 232
 233 (defun turn-left (n)
 234  "TURN-LEFT N => RESULT
 235
 236 ARGUMENTS AND VALUES:
 237
 238   N: a double, the amount the turtle turns
 239   RESULT: undefined
 240
 241 DESCRIPTION:
 242
 243   The turtle turns left by number degrees. (If number is negative, it turns right.)
 244
 245   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#right"
 246  (turn-right (- n)))
 247
 248 (defun create-turtles (n)
 249  "CREATE-TURTLES N => RESULT
 250
 251 ARGUMENTS AND VALUES:
 252
 253   N: an integer, the numbers of turtles to create
 254   RESULT: undefined
 255
 256 DESCRIPTION:
 257
 258   Creates number new turtles at the origin.
 259
 260   New turtles have random integer headings and the color is randomly selected
 261   from the 14 primary colors.  If commands are supplied, the new turtles
 262   immediately run them (unimplemented).
 263
 264   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#create-turtles"
 265  (loop :for i :from 1 :to n :do (create-turtle)))
 266
 267 (defun create-world (&key dims)
 268  "CREATE-WORLD &key DIMS => RESULT
 269
 270   DIMS: (:xmin XMIN :xmax XMAX :ymin YMIN :ymax YMAX)
 271
 272 ARGUMENTS AND VALUES:
 273
 274   RESULT: undefined
 275   XMIN: An integer representing the minimum patch coord in X
 276   XMAX: An integer representing the maximum patch coord in X
 277   YMIN: An integer representing the minimum patch coord in Y
 278   YMAX: An integer representing the maximum patch coord in Y
 279
 280 DESCRIPTION:
 281
 282   Initializes the world in the NVM.
 283
 284   This should be called before using the engine in any real capacity.  If
 285   called when an engine is already running, it may do somethign weird."
 286  (setf *dimensions* dims)
 287  (setf
 288   *patches*
 289   (loop
 290    :for y :from (max-pycor) :downto (min-pycor)
 291    :append (loop
 292             :for x :from (min-pxcor) :to (max-pxcor)
 293             :collect (make-patch
 294                       :xcor (coerce x 'double-float)
 295                       :ycor (coerce y 'double-float)
 296                       :color 0d0))))
 297  (setf *turtles* nil)
 298  (setf *current-id* 0))
 299
 300 ; These match netlogo's dump
 301 (defgeneric dump-object (o))
 302
 303 (defmethod dump-object ((n double-float))
 304  (multiple-value-bind (int rem) (floor n)
 305   (if (eql 0d0 rem)
 306    (format nil "~A" int)
 307    (let
 308     ((output (format nil "~D" n)))
 309     ; Someday we'll have d<posint>, but this is not that day!
 310     (cl-ppcre:regex-replace "d-" (cl-ppcre:regex-replace "d0" output "") "E-")))))
 311
 312 (defmethod dump-object ((o string)) o)
 313
 314 (defmethod dump-object ((o (eql t))) "true")
 315 (defmethod dump-object ((o (eql nil))) "false")
 316
 317 (defun current-state ()
 318  "CURRENT-STATE => WORLD-STATE
 319
 320 ARGUMENTS AND VALUES:
 321
 322   WORLD-STATE: A list, the current state of the whole world
 323
 324 DESCRIPTION:
 325
 326   Dumps out the state of the world.
 327
 328   This is useful for visualizations and also storing in a common lisp
 329   data structure for easy usage in a common lisp instance.  It's preferable
 330   to use this when working with the nvm than the output done by export-world.
 331
 332   Currently this only dumps out turtle and patch information.
 333
 334   This is called CURRENT-STATE because export-world is an actual primitive
 335   used by NetLogo."
 336  (list
 337   (mapcar
 338    (lambda (turtle)
 339     (list
 340      :color (turtle-color turtle)
 341      :xcor (turtle-xcor turtle)
 342      :ycor (turtle-ycor turtle)
 343      :heading (turtle-heading turtle)))
 344    *turtles*)
 345   (mapcar
 346    (lambda (patch)
 347     (list
 348      :color (patch-color patch)
 349      :xcor (patch-xcor patch)
 350      :ycor (patch-ycor patch)))
 351    *patches*)))
 352
 353 (defun export-turtles ()
 354  (append
 355   (list
 356    "\"TURTLES\""
 357    (format nil "~A~A"
 358     "\"who\",\"color\",\"heading\",\"xcor\",\"ycor\",\"shape\",\"label\",\"label-color\","
 359     "\"breed\",\"hidden?\",\"size\",\"pen-size\",\"pen-mode\""))
 360   (mapcar
 361    (lambda (turtle)
 362     (format nil
 363      "\"~A\",\"~A\",\"~A\",\"~A\",\"~A\",~A"
 364      (turtle-who turtle)
 365      (dump-object (turtle-color turtle))
 366      (dump-object (turtle-heading turtle))
 367      (dump-object (turtle-xcor turtle))
 368      (dump-object (turtle-ycor turtle))
 369      "\"\"\"default\"\"\",\"\"\"\"\"\",\"9.9\",\"{all-turtles}\",\"false\",\"1\",\"1\",\"\"\"up\"\"\""))
 370    *turtles*)))
 371
 372 (defun export-patches ()
 373  (append
 374   (list
 375    "\"PATCHES\""
 376    "\"pxcor\",\"pycor\",\"pcolor\",\"plabel\",\"plabel-color\"")
 377   (mapcar
 378    (lambda (patch)
 379     (format nil
 380      "\"~A\",\"~A\",\"~A\",\"\"\"\"\"\",\"9.9\""
 381      (dump-object (patch-xcor patch))
 382      (dump-object (patch-ycor patch))
 383      (dump-object (patch-color patch))))
 384    *patches*)))
 385
 386 (defun export-world ()
 387  "EXPORT-WORLD => WORLD-CSV
 388
 389 ARGUMENTS AND VALUES:
 390
 391   WORLD-CSV: A string, the csv of the world
 392
 393 DESCRIPTION:
 394
 395   Dumps out a csv matching NetLogo's export world.
 396
 397   This is useful for serializing the current state of the engine in order
 398   to compare against NetLogo or to reimport later.  Contains everything needed
 399   to boot up a NetLogo instance in the exact same state."
 400  (format nil "~{~A~%~}"
 401   (list
 402    (format nil "~S" "RANDOM STATE")
 403    (format nil "~S" (clnl-random:export))
 404    ""
 405    (format nil "~S" "GLOBALS")
 406    (format nil "~A~A"
 407     "\"min-pxcor\",\"max-pxcor\",\"min-pycor\",\"max-pycor\",\"perspective\",\"subject\","
 408     "\"nextIndex\",\"directed-links\",\"ticks\",")
 409    (format nil "\"~A\",\"~A\",\"~A\",\"~A\",\"0\",\"nobody\",\"~A\",\"\"\"NEITHER\"\"\",\"-1\""
 410     (min-pxcor) (max-pxcor) (min-pycor) (max-pycor) *current-id*)
 411    ""
 412    (format nil "~{~A~^~%~}" (export-turtles))
 413    ""
 414    (format nil "~{~A~^~%~}" (export-patches))
 415    ""
 416    (format nil "~S" "LINKS")
 417    "\"end1\",\"end2\",\"color\",\"label\",\"label-color\",\"hidden?\",\"breed\",\"thickness\",\"shape\",\"tie-mode\""
 418    "")))