code.consxy.com Git - clnl/blob - src/main/nvm.lisp

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