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 world-dimensions ()
  26  (list :xmin -10 :xmax 10 :ymin -10 :ymax 10))
  27
  28 (defun create-turtle ()
  29  (setf
  30   *turtles*
  31   (nconc
  32    *turtles*
  33    (list
  34     (make-turtle
  35      :who *current-id*
  36      :color (coerce (+ 5 (* 10 (clnl-random:next-int 14))) 'double-float)
  37      :heading (coerce (clnl-random:next-int 360) 'double-float)
  38      :xcor 0d0
  39      :ycor 0d0))))
  40  (incf *current-id*))
  41
  42 (defun turtles ()
  43  "TURTLES => ALL-TURTLES
  44
  45 ARGUMENTS AND VALUES:
  46
  47   ALL-TURTLES: a NetLogo agentset, all turtles
  48
  49 DESCRIPTION:
  50
  51   Reports the agentset consisting of all the turtles.
  52
  53   This agentset is special in that it represents the living turtles
  54   each time it's used, so changes depending on the state of the engine.
  55
  56   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#turtles"
  57  *turtles*)
  58
  59 (defun ask (agent-set fn)
  60  "ASK AGENT-SET FN => RESULT
  61
  62 ARGUMENTS AND VALUES:
  63
  64   AGENT-SET: a NetLogo agentset
  65   FN: a function, run on each agent
  66   RESULT: undefined, commands don't return
  67
  68 DESCRIPTION:
  69
  70   ASK is equivalent to ask in NetLogo.
  71
  72   The specified AGENT-SET runs the given FN.  The order in which the agents
  73   are run is random each time, and only agents that are in the set at the
  74   beginning of the call.
  75
  76   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#ask"
  77  (let
  78   ((iter (shufflerator agent-set)))
  79   (loop
  80    :for agent := (funcall iter)
  81    :while agent
  82    :do (let ((*myself* *self*) (*self* agent)) (funcall fn)))))
  83
  84 (defun shufflerator (agent-set)
  85  (let
  86   ((copy (copy-list agent-set))
  87    (i 0)
  88    (agent nil))
  89   (flet
  90    ((fetch ()
  91      (let
  92       ((idx (when (< i (1- (length copy))) (+ i (clnl-random:next-int (- (length copy) i))))))
  93       (when idx (setf agent (nth idx copy)))
  94       (when idx (setf (nth idx copy) (nth i copy)))
  95       (incf i))))
  96    (fetch) ; we pre-fetch because netlogo does, rng sync hype!
  97    (lambda ()
  98     (cond
  99      ((> i (length copy)) nil)
 100      ((= i (length copy)) (incf i) (car (last copy)))
 101      (t (let ((result agent)) (fetch) result)))))))
 102
 103 (defun random-float (n)
 104  "RANDOM-FLOAT N => RANDOM-NUMBER
 105
 106 ARGUMENTS AND VALUES:
 107
 108   N: a double, the upper bound of the random float
 109   RANDOM-NUMBER: a double, the random result
 110
 111 DESCRIPTION:
 112
 113   Returns a random number strictly closer to zero than N.
 114
 115   If number is positive, returns a random floating point number greater than
 116   or equal to 0 but strictly less than number.
 117
 118   If number is negative, returns a random floating point number less than or equal
 119   to 0, but strictly greater than number.
 120
 121   If number is zero, the result is always 0.
 122
 123   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#random-float"
 124  (clnl-random:next-double n))
 125
 126 (defun forward (n)
 127  "FORWARD N => RESULT
 128
 129 ARGUMENTS AND VALUES:
 130
 131   N: a double, the amount the turtle moves forward
 132   RESULT: undefined
 133
 134 DESCRIPTION:
 135
 136   Moves the current turtle forward N steps, one step at a time.
 137
 138   This moves forward one at a time in order to make the view updates look
 139   good in the case of a purposefully slow running instance.  If the number
 140   is negative, the turtle moves backward.
 141
 142   If the current agent is not a turtle, it raises an error.
 143
 144   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#forward"
 145  (when (not (turtle-p *self*)) (error "Gotta call fd in turtle scope, dude (~A)" *self*))
 146  (setf (turtle-xcor *self*) (+ (turtle-xcor *self*) (* n (sin (* pi (/ (turtle-heading *self*) 180))))))
 147  (setf (turtle-ycor *self*) (+ (turtle-ycor *self*) (* n (cos (* pi (/ (turtle-heading *self*) 180)))))))
 148
 149 (defun create-turtles (n)
 150  "CREATE-TURTLES N => RESULT
 151
 152 ARGUMENTS AND VALUES:
 153
 154   N: an integer, the numbers of turtles to create
 155   RESULT: undefined
 156
 157 DESCRIPTION:
 158
 159   Creates number new turtles at the origin.
 160
 161   New turtles have random integer headings and the color is randomly selected
 162   from the 14 primary colors.  If commands are supplied, the new turtles
 163   immediately run them (unimplemented).
 164
 165   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#create-turtles"
 166  (loop :for i :from 1 :to n :do (create-turtle)))
 167
 168 (defun create-world ()
 169  "CREATE-WORLD => RESULT
 170
 171 ARGUMENTS AND VALUES:
 172
 173   RESULT: undefined
 174
 175 DESCRIPTION:
 176
 177   Initializes the world in the NVM.
 178
 179   This should be called before using the engine in any real capacity.  If
 180   called when an engine is already running, it may do somethign weird."
 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 "\"-1\",\"1\",\"-1\",\"1\",\"0\",\"nobody\",\"~A\",\"\"\"NEITHER\"\"\",\"-1\"" *current-id*)
 263    ""
 264    (format nil "~S" "TURTLES")
 265    (format nil "~A~A"
 266     "\"who\",\"color\",\"heading\",\"xcor\",\"ycor\",\"shape\",\"label\",\"label-color\","
 267     "\"breed\",\"hidden?\",\"size\",\"pen-size\",\"pen-mode\"")
 268    (format nil "~{~A~%~}"
 269     (mapcar
 270      (lambda (turtle)
 271       (format nil
 272        "\"~A\",\"~A\",\"~A\",\"~A\",\"~A\",~A"
 273        (turtle-who turtle)
 274        (dump-object (turtle-color turtle))
 275        (dump-object (turtle-heading turtle))
 276        (dump-object (turtle-xcor turtle))
 277        (dump-object (turtle-ycor turtle))
 278        "\"\"\"default\"\"\",\"\"\"\"\"\",\"9.9\",\"{all-turtles}\",\"false\",\"1\",\"1\",\"\"\"up\"\"\""))
 279      *turtles*))
 280    (format nil "~S" "PATCHES")
 281    (format nil "~{~A~^~%~}" (export-patches))
 282    ""
 283    (format nil "~S" "LINKS")
 284    "\"end1\",\"end2\",\"color\",\"label\",\"label-color\",\"hidden?\",\"breed\",\"thickness\",\"shape\",\"tie-mode\""
 285    "")))