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