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

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