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
 145   (turtle-xcor *self*)
 146   (+ (turtle-xcor *self*) (* n (strictmath:sin (strictmath:to-radians (turtle-heading *self*))))))
 147  (setf
 148   (turtle-ycor *self*)
 149   (+ (turtle-ycor *self*) (* n (strictmath:cos (strictmath:to-radians (turtle-heading *self*)))))))
 150
 151 (defun create-turtles (n)
 152  "CREATE-TURTLES N => RESULT
 153
 154 ARGUMENTS AND VALUES:
 155
 156   N: an integer, the numbers of turtles to create
 157   RESULT: undefined
 158
 159 DESCRIPTION:
 160
 161   Creates number new turtles at the origin.
 162
 163   New turtles have random integer headings and the color is randomly selected
 164   from the 14 primary colors.  If commands are supplied, the new turtles
 165   immediately run them (unimplemented).
 166
 167   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#create-turtles"
 168  (loop :for i :from 1 :to n :do (create-turtle)))
 169
 170 (defun create-world (model)
 171  "CREATE-WORLD MODEL => RESULT
 172
 173 ARGUMENTS AND VALUES:
 174
 175   MODEL: A clnl-model:model to use to initialize the vm
 176   RESULT: undefined
 177
 178 DESCRIPTION:
 179
 180   Initializes the world in the NVM.
 181
 182   This should be called before using the engine in any real capacity.  If
 183   called when an engine is already running, it may do somethign weird."
 184  (setf *model* model)
 185  (setf *turtles* nil)
 186  (setf *current-id* 0))
 187
 188 ; These match netlogo's dump
 189 (defgeneric dump-object (o))
 190
 191 (defmethod dump-object ((n double-float))
 192  (multiple-value-bind (int rem) (floor n)
 193   (if (eql 0d0 rem)
 194    (format nil "~A" int)
 195    (let
 196     ((output (format nil "~D" n)))
 197     ; Someday we'll have d<posint>, but this is not that day!
 198     (cl-ppcre:regex-replace "d-" (cl-ppcre:regex-replace "d0" output "") "E-")))))
 199
 200 (defmethod dump-object ((o string)) o)
 201
 202 (defun current-state ()
 203  "CURRENT-STATE => WORLD-STATE
 204
 205 ARGUMENTS AND VALUES:
 206
 207   WORLD-STATE: A list, the current state of the whole world
 208
 209 DESCRIPTION:
 210
 211   Dumps out the state of the world.
 212
 213   This is useful for visualizations and also storing in a common lisp
 214   data structure for easy usage in a common lisp instance.  It's preferable
 215   to use this when working with the nvm than the output done by export-world.
 216
 217   Currently this only dumps out turtle information.
 218
 219   This is called CURRENT-STATE because export-world is an actual primitive
 220   used by NetLogo."
 221  (mapcar
 222   (lambda (turtle)
 223    (list
 224     :color (turtle-color turtle)
 225     :xcor (turtle-xcor turtle)
 226     :ycor (turtle-ycor turtle)
 227     :heading (turtle-heading turtle)))
 228   *turtles*))
 229
 230 (defun export-patches ()
 231  (list
 232   "\"pxcor\",\"pycor\",\"pcolor\",\"plabel\",\"plabel-color\""
 233   "\"-1\",\"1\",\"0\",\"\"\"\"\"\",\"9.9\""
 234   "\"0\",\"1\",\"0\",\"\"\"\"\"\",\"9.9\""
 235   "\"1\",\"1\",\"0\",\"\"\"\"\"\",\"9.9\""
 236   "\"-1\",\"0\",\"0\",\"\"\"\"\"\",\"9.9\""
 237   "\"0\",\"0\",\"0\",\"\"\"\"\"\",\"9.9\""
 238   "\"1\",\"0\",\"0\",\"\"\"\"\"\",\"9.9\""
 239   "\"-1\",\"-1\",\"0\",\"\"\"\"\"\",\"9.9\""
 240   "\"0\",\"-1\",\"0\",\"\"\"\"\"\",\"9.9\""
 241   "\"1\",\"-1\",\"0\",\"\"\"\"\"\",\"9.9\""))
 242
 243 (defun export-world ()
 244  "EXPORT-WORLD => WORLD-CSV
 245
 246 ARGUMENTS AND VALUES:
 247
 248   WORLD-CSV: A string, the csv of the world
 249
 250 DESCRIPTION:
 251
 252   Dumps out a csv matching NetLogo's export world.
 253
 254   This is useful for serializing the current state of the engine in order
 255   to compare against NetLogo or to reimport later.  Contains everything needed
 256   to boot up a NetLogo instance in the exact same state."
 257  (format nil "~{~A~%~}"
 258   (list
 259    (format nil "~S" "RANDOM STATE")
 260    (format nil "~S" (clnl-random:export))
 261    ""
 262    (format nil "~S" "GLOBALS")
 263    (format nil "~A~A"
 264     "\"min-pxcor\",\"max-pxcor\",\"min-pycor\",\"max-pycor\",\"perspective\",\"subject\","
 265     "\"nextIndex\",\"directed-links\",\"ticks\",")
 266    (format nil "\"~A\",\"~A\",\"~A\",\"~A\",\"0\",\"nobody\",\"~A\",\"\"\"NEITHER\"\"\",\"-1\""
 267     (getf (clnl-model:world-dimensions *model*) :xmin) (getf (clnl-model:world-dimensions *model*) :xmax)
 268     (getf (clnl-model:world-dimensions *model*) :ymin) (getf (clnl-model:world-dimensions *model*) :ymax)
 269     *current-id*)
 270    ""
 271    (format nil "~S" "TURTLES")
 272    (format nil "~A~A"
 273     "\"who\",\"color\",\"heading\",\"xcor\",\"ycor\",\"shape\",\"label\",\"label-color\","
 274     "\"breed\",\"hidden?\",\"size\",\"pen-size\",\"pen-mode\"")
 275    (format nil "~{~A~%~}"
 276     (mapcar
 277      (lambda (turtle)
 278       (format nil
 279        "\"~A\",\"~A\",\"~A\",\"~A\",\"~A\",~A"
 280        (turtle-who turtle)
 281        (dump-object (turtle-color turtle))
 282        (dump-object (turtle-heading turtle))
 283        (dump-object (turtle-xcor turtle))
 284        (dump-object (turtle-ycor turtle))
 285        "\"\"\"default\"\"\",\"\"\"\"\"\",\"9.9\",\"{all-turtles}\",\"false\",\"1\",\"1\",\"\"\"up\"\"\""))
 286      *turtles*))
 287    (format nil "~S" "PATCHES")
 288    (format nil "~{~A~^~%~}" (export-patches))
 289    ""
 290    (format nil "~S" "LINKS")
 291    "\"end1\",\"end2\",\"color\",\"label\",\"label-color\",\"hidden?\",\"breed\",\"thickness\",\"shape\",\"tie-mode\""
 292    "")))