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 (&key dims)
 177  "CREATE-WORLD &key DIMS => RESULT
 178
 179   DIMS: (:xmin XMIN :xmax XMAX :ymin YMIN :ymax YMAX)
 180
 181 ARGUMENTS AND VALUES:
 182
 183   RESULT: undefined
 184   XMIN: An integer representing the minimum patch coord in X
 185   XMAX: An integer representing the maximum patch coord in X
 186   YMIN: An integer representing the minimum patch coord in Y
 187   YMAX: An integer representing the maximum patch coord in Y
 188
 189 DESCRIPTION:
 190
 191   Initializes the world in the NVM.
 192
 193   This should be called before using the engine in any real capacity.  If
 194   called when an engine is already running, it may do somethign weird."
 195  (setf *dimensions* dims)
 196  (setf *turtles* nil)
 197  (setf *current-id* 0))
 198
 199 ; These match netlogo's dump
 200 (defgeneric dump-object (o))
 201
 202 (defmethod dump-object ((n double-float))
 203  (multiple-value-bind (int rem) (floor n)
 204   (if (eql 0d0 rem)
 205    (format nil "~A" int)
 206    (let
 207     ((output (format nil "~D" n)))
 208     ; Someday we'll have d<posint>, but this is not that day!
 209     (cl-ppcre:regex-replace "d-" (cl-ppcre:regex-replace "d0" output "") "E-")))))
 210
 211 (defmethod dump-object ((o string)) o)
 212
 213 (defun current-state ()
 214  "CURRENT-STATE => WORLD-STATE
 215
 216 ARGUMENTS AND VALUES:
 217
 218   WORLD-STATE: A list, the current state of the whole world
 219
 220 DESCRIPTION:
 221
 222   Dumps out the state of the world.
 223
 224   This is useful for visualizations and also storing in a common lisp
 225   data structure for easy usage in a common lisp instance.  It's preferable
 226   to use this when working with the nvm than the output done by export-world.
 227
 228   Currently this only dumps out turtle information.
 229
 230   This is called CURRENT-STATE because export-world is an actual primitive
 231   used by NetLogo."
 232  (mapcar
 233   (lambda (turtle)
 234    (list
 235     :color (turtle-color turtle)
 236     :xcor (turtle-xcor turtle)
 237     :ycor (turtle-ycor turtle)
 238     :heading (turtle-heading turtle)))
 239   *turtles*))
 240
 241 (defun export-patches ()
 242  (list
 243   "\"pxcor\",\"pycor\",\"pcolor\",\"plabel\",\"plabel-color\""
 244   "\"-1\",\"1\",\"0\",\"\"\"\"\"\",\"9.9\""
 245   "\"0\",\"1\",\"0\",\"\"\"\"\"\",\"9.9\""
 246   "\"1\",\"1\",\"0\",\"\"\"\"\"\",\"9.9\""
 247   "\"-1\",\"0\",\"0\",\"\"\"\"\"\",\"9.9\""
 248   "\"0\",\"0\",\"0\",\"\"\"\"\"\",\"9.9\""
 249   "\"1\",\"0\",\"0\",\"\"\"\"\"\",\"9.9\""
 250   "\"-1\",\"-1\",\"0\",\"\"\"\"\"\",\"9.9\""
 251   "\"0\",\"-1\",\"0\",\"\"\"\"\"\",\"9.9\""
 252   "\"1\",\"-1\",\"0\",\"\"\"\"\"\",\"9.9\""))
 253
 254 (defun export-world ()
 255  "EXPORT-WORLD => WORLD-CSV
 256
 257 ARGUMENTS AND VALUES:
 258
 259   WORLD-CSV: A string, the csv of the world
 260
 261 DESCRIPTION:
 262
 263   Dumps out a csv matching NetLogo's export world.
 264
 265   This is useful for serializing the current state of the engine in order
 266   to compare against NetLogo or to reimport later.  Contains everything needed
 267   to boot up a NetLogo instance in the exact same state."
 268  (format nil "~{~A~%~}"
 269   (list
 270    (format nil "~S" "RANDOM STATE")
 271    (format nil "~S" (clnl-random:export))
 272    ""
 273    (format nil "~S" "GLOBALS")
 274    (format nil "~A~A"
 275     "\"min-pxcor\",\"max-pxcor\",\"min-pycor\",\"max-pycor\",\"perspective\",\"subject\","
 276     "\"nextIndex\",\"directed-links\",\"ticks\",")
 277    (format nil "\"~A\",\"~A\",\"~A\",\"~A\",\"0\",\"nobody\",\"~A\",\"\"\"NEITHER\"\"\",\"-1\""
 278     (min-pxcor) (max-pxcor) (min-pycor) (max-pycor) *current-id*)
 279    ""
 280    (format nil "~S" "TURTLES")
 281    (format nil "~A~A"
 282     "\"who\",\"color\",\"heading\",\"xcor\",\"ycor\",\"shape\",\"label\",\"label-color\","
 283     "\"breed\",\"hidden?\",\"size\",\"pen-size\",\"pen-mode\"")
 284    (format nil "~{~A~%~}"
 285     (mapcar
 286      (lambda (turtle)
 287       (format nil
 288        "\"~A\",\"~A\",\"~A\",\"~A\",\"~A\",~A"
 289        (turtle-who turtle)
 290        (dump-object (turtle-color turtle))
 291        (dump-object (turtle-heading turtle))
 292        (dump-object (turtle-xcor turtle))
 293        (dump-object (turtle-ycor turtle))
 294        "\"\"\"default\"\"\",\"\"\"\"\"\",\"9.9\",\"{all-turtles}\",\"false\",\"1\",\"1\",\"\"\"up\"\"\""))
 295      *turtles*))
 296    (format nil "~S" "PATCHES")
 297    (format nil "~{~A~^~%~}" (export-patches))
 298    ""
 299    (format nil "~S" "LINKS")
 300    "\"end1\",\"end2\",\"color\",\"label\",\"label-color\",\"hidden?\",\"breed\",\"thickness\",\"shape\",\"tie-mode\""
 301    "")))