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

   1 (in-package #:clnl-nvm)
   2
   3 (defun create-turtles (n &optional breed fn)
   4  "CREATE-TURTLES N &optional BREED FN => RESULT
   5
   6 ARGUMENTS AND VALUES:
   7
   8   N: an integer, the numbers of turtles to create
   9   BREED: a breed
  10   FN: A function, applied to each turtle after creation
  11   RESULT: undefined
  12
  13 DESCRIPTION:
  14
  15   Creates N new turtles at the origin.
  16
  17   New turtles have random integer headings and the color is randomly selected
  18   from the 14 primary colors.  If FN is supplied, the new turtles immediately
  19   run it.  If a BREED is supplied, that is the breed the new turtles are set
  20   to.
  21
  22   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#create-turtles"
  23  (let
  24   ((new-turtles (loop :repeat n :collect (create-turtle breed))))
  25   (when fn (ask (list->agentset new-turtles :turtles) fn))))
  26
  27 (defun die ()
  28  "DIE => RESULT
  29
  30 ARGUMENTS AND VALUES:
  31
  32   RESULT: undefined, commands don't return
  33
  34 DESCRIPTION:
  35
  36   The turtle or link dies
  37
  38   A dead agent ceases to exist. The effects of this include:
  39   - The agent will not execute any further code.
  40   - The agent will disappear from any agentsets it was in, reducing the size of those agentsets by one.
  41   - Any variable that was storing the agent will now instead have nobody in it.
  42   - If the dead agent was a turtle, every link connected to it also dies.
  43   - If the observer was watching or following the agent, the observer's perspective resets.
  44
  45   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#die"
  46  (when (not (turtle-p *self*)) (error "Gotta call die in turtle scope, dude (~A)" *self*))
  47  (setf (turtle-who *self*) -1)
  48  (setf *turtles* (remove *self* *turtles*))
  49  (let
  50   ((patch (patch-at (turtle-xcor *self*) (turtle-ycor *self*))))
  51   (setf (patch-turtles patch) (remove *self* (patch-turtles patch))))
  52  (error (make-condition 'death)))
  53
  54 (defun hatch (n &optional fn)
  55  "HATCH N &optional FN => RESULT
  56
  57 ARGUMENTS AND VALUES:
  58
  59   N: an integer, the numbers of turtles to hatch
  60   FN: A function, applied to each turtle after creation
  61   RESULT: undefined
  62
  63 DESCRIPTION:
  64
  65   The turtle in *self* creates N new turtles. Each new turtle inherits of all its
  66   variables, including its location, from self.
  67
  68   If FN is supplied, the new turtles immediately run it.
  69
  70   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#hatch"
  71  (when (not (turtle-p *self*)) (error "Can only hatch from turtle scope"))
  72  (let
  73   ((new-turtles (loop :repeat n :collect (create-turtle nil *self*))))
  74   (when fn (ask (list->agentset new-turtles :turtles) fn))))
  75
  76 (defun forward (n)
  77  "FORWARD N => RESULT
  78
  79 ARGUMENTS AND VALUES:
  80
  81   N: a double, the amount the turtle moves forward
  82   RESULT: undefined
  83
  84 DESCRIPTION:
  85
  86   Moves the current turtle forward N steps, one step at a time.
  87
  88   This moves forward one at a time in order to make the view updates look
  89   good in the case of a purposefully slow running instance.  If the number
  90   is negative, the turtle moves backward.
  91
  92   If the current agent is not a turtle, it raises an error.
  93
  94   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#forward"
  95  (when (not (turtle-p *self*)) (error "Gotta call fd in turtle scope, dude (~A)" *self*))
  96  (labels
  97   ((internal (i)
  98     (cond
  99      ((< (abs i) 3.2e-15) nil)
 100      ((< (abs i) 1d0) (jump i))
 101      (t (jump (if (> i 0d0) 1d0 -1d0)) (internal (- i (if (> i 0d0) 1d0 -1d0)))))))
 102   (internal n)))
 103
 104 (defun jump (n)
 105  (when (not (turtle-p *self*)) (error "Gotta call jump in turtle scope, dude (~A)" *self*))
 106  (with-patch-update *self*
 107   (setf
 108    (turtle-xcor *self*)
 109    (wrap-x *topology*
 110     (+ (turtle-xcor *self*) (* n (using-cached-sin (turtle-heading *self*))))))
 111   (setf
 112    (turtle-ycor *self*)
 113    (wrap-y *topology*
 114     (+ (turtle-ycor *self*) (* n (using-cached-cos (turtle-heading *self*))))))))
 115
 116 (defun random-xcor ()
 117  "RANDOM-XCOR => RANDOM-NUMBER
 118
 119 ARGUMENTS AND VALUES:
 120
 121   RANDOM-NUMBER: a float, the random result
 122
 123 DESCRIPTION:
 124
 125   Returns a random floating point number in the allowable range of turtle
 126   coordinates along the x axis.
 127
 128   These range from min-pxcor - 0.5 (inclusive) to max-pxcor + 0.5 (exclusive)
 129
 130   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#random-cor"
 131  (let
 132   ((min (- (min-pxcor) 0.5d0))
 133    (max (+ (max-pxcor) 0.5d0)))
 134   (+ min (clnl-random:next-double (- max min)))))
 135
 136 (defun random-ycor ()
 137  "RANDOM-YCOR => RANDOM-NUMBER
 138
 139 ARGUMENTS AND VALUES:
 140
 141   RANDOM-NUMBER: a float, the random result
 142
 143 DESCRIPTION:
 144
 145   Returns a random floating point number in the allowable range of turtle
 146   coordinates along the y axis.
 147
 148   These range from min-pycor - 0.5 (inclusive) to max-pycor + 0.5 (exclusive)
 149
 150   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#random-cor"
 151  (let
 152   ((min (- (min-pycor) 0.5d0))
 153    (max (+ (max-pycor) 0.5d0)))
 154   (+ min (clnl-random:next-double (- max min)))))
 155
 156 (defun set-default-shape (breed shape)
 157  "SET-DEFAULT-SHAPE BREED SHAPE => RESULT
 158
 159 ARGUMENTS AND VALUES:
 160
 161   BREED: a valid breed
 162   SHAPE: a string
 163   RESULT: undefined
 164
 165 DESCRIPTION:
 166
 167   Specifies a default initial shape for a BREED. When a turtle, or it changes breeds,
 168   its shape is set to the given shape.
 169
 170   SET-DEFAULT-SHAPE doesn't affect existing agents, only agents you create afterwards.
 171
 172   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#set-default-shape"
 173  (when (not (breed-p breed)) (error "Need a valid breed"))
 174  (setf (breed-default-shape breed) shape))
 175
 176 (defun setxy (x y)
 177  "SETXY X Y => RESULT
 178
 179 ARGUMENTS AND VALUES:
 180
 181   X: a double
 182   Y: a double
 183   RESULT: undefined
 184
 185 DESCRIPTION:
 186
 187   Sets the x-coordinate and y-coordinate for the turle.  Equivalent to
 188   set xcor x set ycor y, except it happens in one step inside of two.
 189
 190   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#setxy"
 191  (when (not (turtle-p *self*)) (error "Gotta call setxy in turtle scope, dude (~A)" *self*))
 192  (setf (turtle-xcor *self*) (wrap-x *topology* x))
 193  (setf (turtle-ycor *self*) (wrap-y *topology* y)))
 194
 195 (defun turtles-here (&optional breed)
 196  "TURTLES-HERE => TURTLES
 197
 198 ARGUMENTS AND VALUES:
 199
 200   TURTLES: an agentset
 201
 202 DESCRIPTION:
 203
 204   Returns the agentset consisting of all the turtles sharing the patch
 205   with the agent in by *self*
 206
 207   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#turtles-here"
 208  (when (not (turtle-p *self*)) (error "Gotta call turtles-here with a turtle"))
 209  (let
 210   ((patch-turtles (patch-turtles (patch-at (turtle-xcor *self*) (turtle-ycor *self*)))))
 211   (list->agentset
 212    (if breed (remove breed patch-turtles :key #'turtle-breed :test-not #'eql) patch-turtles)
 213    (or breed :turtles))))
 214
 215 (defun turn-right (n)
 216  "TURN-RIGHT N => RESULT
 217
 218 ARGUMENTS AND VALUES:
 219
 220   N: a double, the amount the turtle turns
 221   RESULT: undefined
 222
 223 DESCRIPTION:
 224
 225   The turtle turns right by number degrees. (If number is negative, it turns left.)
 226
 227   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#right"
 228  (when (not (turtle-p *self*)) (error "Gotta call fd in turtle scope, dude (~A)" *self*))
 229  (let
 230   ((new-heading (+ (turtle-heading *self*) n)))
 231   (setf (turtle-heading *self*)
 232    (cond
 233     ((< new-heading 0) (+ (mod new-heading -360) 360))
 234     ((>= new-heading 360) (mod new-heading 360))
 235     (t new-heading)))))
 236
 237 (defun turn-left (n)
 238  "TURN-LEFT N => RESULT
 239
 240 ARGUMENTS AND VALUES:
 241
 242   N: a double, the amount the turtle turns
 243   RESULT: undefined
 244
 245 DESCRIPTION:
 246
 247   The turtle turns left by number degrees. (If number is negative, it turns right.)
 248
 249   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#right"
 250  (turn-right (- n)))