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