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 create-turtle ()
  21  (setf
  22   *turtles*
  23   (nconc
  24    *turtles*
  25    (list
  26     (make-turtle
  27      :who *current-id*
  28      :color (coerce (+ 5 (* 10 (clnl-random:next-int 14))) 'double-float)
  29      :heading (coerce (clnl-random:next-int 360) 'double-float)
  30      :xcor 0d0
  31      :ycor 0d0))))
  32  (incf *current-id*))
  33
  34 (defun die ()
  35  "DIE => RESULT
  36
  37 ARGUMENTS AND VALUES:
  38
  39   RESULT: undefined, commands don't return
  40
  41 DESCRIPTION:
  42
  43   The turtle or link dies
  44
  45   A dead agent ceases to exist. The effects of this include:
  46   - The agent will not execute any further code.
  47   - The agent will disappear from any agentsets it was in, reducing the size of those agentsets by one.
  48   - Any variable that was storing the agent will now instead have nobody in it.
  49   - If the dead agent was a turtle, every link connected to it also dies.
  50   - If the observer was watching or following the agent, the observer's perspective resets.
  51
  52   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#die"
  53  (when (not (turtle-p *self*)) (error "Gotta call die in turtle scope, dude (~A)" *self*))
  54  (setf (turtle-who *self*) -1)
  55  (setf *turtles* (remove *self* *turtles*)))
  56
  57 (defun turtles ()
  58  "TURTLES => ALL-TURTLES
  59
  60 ARGUMENTS AND VALUES:
  61
  62   ALL-TURTLES: a NetLogo agentset, all turtles
  63
  64 DESCRIPTION:
  65
  66   Reports the agentset consisting of all the turtles.
  67
  68   This agentset is special in that it represents the living turtles
  69   each time it's used, so changes depending on the state of the engine.
  70
  71   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#turtles"
  72  *turtles*)
  73
  74 (defun ask (agent-set fn)
  75  "ASK AGENT-SET FN => RESULT
  76
  77 ARGUMENTS AND VALUES:
  78
  79   AGENT-SET: a NetLogo agentset
  80   FN: a function, run on each agent
  81   RESULT: undefined, commands don't return
  82
  83 DESCRIPTION:
  84
  85   ASK is equivalent to ask in NetLogo.
  86
  87   The specified AGENT-SET runs the given FN.  The order in which the agents
  88   are run is random each time, and only agents that are in the set at the
  89   beginning of the call.
  90
  91   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#ask"
  92  (let
  93   ((iter (shufflerator agent-set)))
  94   (loop
  95    :for agent := (funcall iter)
  96    :while agent
  97    :do (let ((*myself* *self*) (*self* agent)) (funcall fn)))))
  98
  99 (defun shufflerator (agent-set)
 100  (let
 101   ((copy (copy-list agent-set))
 102    (i 0)
 103    (agent nil))
 104   (flet
 105    ((fetch ()
 106      (let
 107       ((idx (when (< i (1- (length copy))) (+ i (clnl-random:next-int (- (length copy) i))))))
 108       (when idx (setf agent (nth idx copy)))
 109       (when idx (setf (nth idx copy) (nth i copy)))
 110       (incf i))))
 111    (fetch) ; we pre-fetch because netlogo does, rng sync hype!
 112    (lambda ()
 113     (cond
 114      ((> i (length copy)) nil)
 115      ((= i (length copy)) (incf i) (car (last copy)))
 116      (t (let ((result agent)) (fetch) result)))))))
 117
 118 (defun random-float (n)
 119  "RANDOM-FLOAT N => RANDOM-NUMBER
 120
 121 ARGUMENTS AND VALUES:
 122
 123   N: a double, the upper bound of the random float
 124   RANDOM-NUMBER: a double, the random result
 125
 126 DESCRIPTION:
 127
 128   Returns a random number strictly closer to zero than N.
 129
 130   If number is positive, returns a random floating point number greater than
 131   or equal to 0 but strictly less than number.
 132
 133   If number is negative, returns a random floating point number less than or equal
 134   to 0, but strictly greater than number.
 135
 136   If number is zero, the result is always 0.
 137
 138   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#random-float"
 139  (clnl-random:next-double n))
 140
 141 (defun jump (n)
 142  (when (not (turtle-p *self*)) (error "Gotta call fd in turtle scope, dude (~A)" *self*))
 143  (setf
 144   (turtle-xcor *self*)
 145   (wrap-x *topology*
 146    (+ (turtle-xcor *self*) (* n (strictmath:sin (strictmath:to-radians (turtle-heading *self*)))))))
 147  (setf
 148   (turtle-ycor *self*)
 149   (wrap-y *topology*
 150    (+ (turtle-ycor *self*) (* n (strictmath:cos (strictmath:to-radians (turtle-heading *self*))))))))
 151
 152 (defun forward (n)
 153  "FORWARD N => RESULT
 154
 155 ARGUMENTS AND VALUES:
 156
 157   N: a double, the amount the turtle moves forward
 158   RESULT: undefined
 159
 160 DESCRIPTION:
 161
 162   Moves the current turtle forward N steps, one step at a time.
 163
 164   This moves forward one at a time in order to make the view updates look
 165   good in the case of a purposefully slow running instance.  If the number
 166   is negative, the turtle moves backward.
 167
 168   If the current agent is not a turtle, it raises an error.
 169
 170   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#forward"
 171  (when (not (turtle-p *self*)) (error "Gotta call fd in turtle scope, dude (~A)" *self*))
 172  (labels
 173   ((internal (i)
 174     (cond
 175      ((< (abs i) 3.2e-15) nil)
 176      ((< (abs i) 1d0) (jump i))
 177      (t (jump (if (> i 0d0) 1d0 -1d0)) (internal (- i (if (> i 0d0) 1d0 -1d0)))))))
 178   (internal n)))
 179
 180 (defun create-turtles (n)
 181  "CREATE-TURTLES N => RESULT
 182
 183 ARGUMENTS AND VALUES:
 184
 185   N: an integer, the numbers of turtles to create
 186   RESULT: undefined
 187
 188 DESCRIPTION:
 189
 190   Creates number new turtles at the origin.
 191
 192   New turtles have random integer headings and the color is randomly selected
 193   from the 14 primary colors.  If commands are supplied, the new turtles
 194   immediately run them (unimplemented).
 195
 196   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#create-turtles"
 197  (loop :for i :from 1 :to n :do (create-turtle)))
 198
 199 (defun create-world (&key dims)
 200  "CREATE-WORLD &key DIMS => RESULT
 201
 202   DIMS: (:xmin XMIN :xmax XMAX :ymin YMIN :ymax YMAX)
 203
 204 ARGUMENTS AND VALUES:
 205
 206   RESULT: undefined
 207   XMIN: An integer representing the minimum patch coord in X
 208   XMAX: An integer representing the maximum patch coord in X
 209   YMIN: An integer representing the minimum patch coord in Y
 210   YMAX: An integer representing the maximum patch coord in Y
 211
 212 DESCRIPTION:
 213
 214   Initializes the world in the NVM.
 215
 216   This should be called before using the engine in any real capacity.  If
 217   called when an engine is already running, it may do somethign weird."
 218  (setf *dimensions* dims)
 219  (setf *turtles* nil)
 220  (setf *current-id* 0))
 221
 222 ; These match netlogo's dump
 223 (defgeneric dump-object (o))
 224
 225 (defmethod dump-object ((n double-float))
 226  (multiple-value-bind (int rem) (floor n)
 227   (if (eql 0d0 rem)
 228    (format nil "~A" int)
 229    (let
 230     ((output (format nil "~D" n)))
 231     ; Someday we'll have d<posint>, but this is not that day!
 232     (cl-ppcre:regex-replace "d-" (cl-ppcre:regex-replace "d0" output "") "E-")))))
 233
 234 (defmethod dump-object ((o string)) o)
 235
 236 (defmethod dump-object ((o (eql t))) "true")
 237 (defmethod dump-object ((o (eql nil))) "false")
 238
 239 (defun current-state ()
 240  "CURRENT-STATE => WORLD-STATE
 241
 242 ARGUMENTS AND VALUES:
 243
 244   WORLD-STATE: A list, the current state of the whole world
 245
 246 DESCRIPTION:
 247
 248   Dumps out the state of the world.
 249
 250   This is useful for visualizations and also storing in a common lisp
 251   data structure for easy usage in a common lisp instance.  It's preferable
 252   to use this when working with the nvm than the output done by export-world.
 253
 254   Currently this only dumps out turtle information.
 255
 256   This is called CURRENT-STATE because export-world is an actual primitive
 257   used by NetLogo."
 258  (mapcar
 259   (lambda (turtle)
 260    (list
 261     :color (turtle-color turtle)
 262     :xcor (turtle-xcor turtle)
 263     :ycor (turtle-ycor turtle)
 264     :heading (turtle-heading turtle)))
 265   *turtles*))
 266
 267 (defun export-patches ()
 268  (list
 269   "\"pxcor\",\"pycor\",\"pcolor\",\"plabel\",\"plabel-color\""
 270   "\"-1\",\"1\",\"0\",\"\"\"\"\"\",\"9.9\""
 271   "\"0\",\"1\",\"0\",\"\"\"\"\"\",\"9.9\""
 272   "\"1\",\"1\",\"0\",\"\"\"\"\"\",\"9.9\""
 273   "\"-1\",\"0\",\"0\",\"\"\"\"\"\",\"9.9\""
 274   "\"0\",\"0\",\"0\",\"\"\"\"\"\",\"9.9\""
 275   "\"1\",\"0\",\"0\",\"\"\"\"\"\",\"9.9\""
 276   "\"-1\",\"-1\",\"0\",\"\"\"\"\"\",\"9.9\""
 277   "\"0\",\"-1\",\"0\",\"\"\"\"\"\",\"9.9\""
 278   "\"1\",\"-1\",\"0\",\"\"\"\"\"\",\"9.9\""))
 279
 280 (defun export-world ()
 281  "EXPORT-WORLD => WORLD-CSV
 282
 283 ARGUMENTS AND VALUES:
 284
 285   WORLD-CSV: A string, the csv of the world
 286
 287 DESCRIPTION:
 288
 289   Dumps out a csv matching NetLogo's export world.
 290
 291   This is useful for serializing the current state of the engine in order
 292   to compare against NetLogo or to reimport later.  Contains everything needed
 293   to boot up a NetLogo instance in the exact same state."
 294  (format nil "~{~A~%~}"
 295   (list
 296    (format nil "~S" "RANDOM STATE")
 297    (format nil "~S" (clnl-random:export))
 298    ""
 299    (format nil "~S" "GLOBALS")
 300    (format nil "~A~A"
 301     "\"min-pxcor\",\"max-pxcor\",\"min-pycor\",\"max-pycor\",\"perspective\",\"subject\","
 302     "\"nextIndex\",\"directed-links\",\"ticks\",")
 303    (format nil "\"~A\",\"~A\",\"~A\",\"~A\",\"0\",\"nobody\",\"~A\",\"\"\"NEITHER\"\"\",\"-1\""
 304     (min-pxcor) (max-pxcor) (min-pycor) (max-pycor) *current-id*)
 305    ""
 306    (format nil "~S" "TURTLES")
 307    (format nil "~A~A"
 308     "\"who\",\"color\",\"heading\",\"xcor\",\"ycor\",\"shape\",\"label\",\"label-color\","
 309     "\"breed\",\"hidden?\",\"size\",\"pen-size\",\"pen-mode\"")
 310    (format nil "~{~A~%~}"
 311     (mapcar
 312      (lambda (turtle)
 313       (format nil
 314        "\"~A\",\"~A\",\"~A\",\"~A\",\"~A\",~A"
 315        (turtle-who turtle)
 316        (dump-object (turtle-color turtle))
 317        (dump-object (turtle-heading turtle))
 318        (dump-object (turtle-xcor turtle))
 319        (dump-object (turtle-ycor turtle))
 320        "\"\"\"default\"\"\",\"\"\"\"\"\",\"9.9\",\"{all-turtles}\",\"false\",\"1\",\"1\",\"\"\"up\"\"\""))
 321      *turtles*))
 322    (format nil "~S" "PATCHES")
 323    (format nil "~{~A~^~%~}" (export-patches))
 324    ""
 325    (format nil "~S" "LINKS")
 326    "\"end1\",\"end2\",\"color\",\"label\",\"label-color\",\"hidden?\",\"breed\",\"thickness\",\"shape\",\"tie-mode\""
 327    "")))