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

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