Prims - Implement hatch

[clnl] / src / main / nvm / nvm.lisp

diff --git a/src/main/nvm/nvm.lisp b/src/main/nvm/nvm.lisp
index a59247442d02fa2fa5a927865ae2a0dacd8023ac..6fdc812964cb72e5f4c0a73b58d955615bcd3b52 100644 (file)
--- a/src/main/nvm/nvm.lisp
+++ b/src/main/nvm/nvm.lisp
@@ -48,19 +48,21 @@ DESCRIPTION:
   (:magenta 125d0)
   (:pink 135d0)))
 
   (:magenta 125d0)
   (:pink 135d0)))
 

-(defun create-turtle ()
- (setf
-  *turtles*
-  (nconc
-   *turtles*
-   (list
-    (make-turtle
-     :who (coerce *current-id* 'double-float)
-     :color (coerce (+ 5 (* 10 (clnl-random:next-int 14))) 'double-float)
-     :heading (coerce (clnl-random:next-int 360) 'double-float)
-     :xcor 0d0
-     :ycor 0d0))))
- (incf *current-id*))
+(defun create-turtle (&optional base-turtle)
+ (let
+  ((new-turtle (make-turtle
+                :who (coerce *current-id* 'double-float)
+                :color (if base-turtle
+                        (turtle-color base-turtle)
+                        (coerce (+ 5 (* 10 (clnl-random:next-int 14))) 'double-float))
+                :heading (if base-turtle
+                          (turtle-heading base-turtle)
+                          (coerce (clnl-random:next-int 360) 'double-float))
+                :xcor (if base-turtle (turtle-xcor base-turtle) 0d0)
+                :ycor (if base-turtle (turtle-ycor base-turtle) 0d0))))
+  (setf *turtles* (nconc *turtles* (list new-turtle)))
+  (incf *current-id*)
+  new-turtle))

 
 (defun die ()
  "DIE => RESULT
 
 (defun die ()
  "DIE => RESULT


@@ -119,67 +121,67 @@ DESCRIPTION:
   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#turtles"
  :turtles)
 
   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#turtles"
  :turtles)
 

-(defun ask (agent-or-agent-set fn)
- "ASK AGENT-OR-AGENT-SET FN => RESULT
+(defun ask (agent-or-agentset fn)
+ "ASK AGENT-OR-AGENTSET FN => RESULT

 
 

-  AGENT-OR-AGENT-SET: AGENT | AGENT-SET
+  AGENT-OR-AGENTSET: AGENT | AGENTSET

 
 ARGUMENTS AND VALUES:
 
   FN: a function, run on each agent
   RESULT: undefined, commands don't return
   AGENT: a NetLogo agent
 
 ARGUMENTS AND VALUES:
 
   FN: a function, run on each agent
   RESULT: undefined, commands don't return
   AGENT: a NetLogo agent

-  AGENT-SET: a NetLogo agentset
+  AGENTSET: a NetLogo agentset

 
 DESCRIPTION:
 
   ASK is equivalent to ask in NetLogo.
 
 
 DESCRIPTION:
 
   ASK is equivalent to ask in NetLogo.
 

-  The specified AGENT-SET or AGENT runs the given FN.  In the case of an
-  AGENT-SET, the order in which the agents are run is random each time,
+  The specified AGENTSET or AGENT runs the given FN.  In the case of an
+  AGENTSET, the order in which the agents are run is random each time,

   and only agents that are in the set at the beginning of the call.
 
   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#ask"
  (cond
   and only agents that are in the set at the beginning of the call.
 
   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#ask"
  (cond

-  ((agent-set-p agent-or-agent-set)
+  ((agentset-p agent-or-agentset)

    (let
    (let

-    ((iter (shufflerator (agent-set-list agent-or-agent-set))))
+    ((iter (shufflerator (agentset-list agent-or-agentset))))

     (loop
      :for agent := (funcall iter)
      :while agent
      :do (let ((*myself* *self*) (*self* agent)) (funcall fn)))))
     (loop
      :for agent := (funcall iter)
      :while agent
      :do (let ((*myself* *self*) (*self* agent)) (funcall fn)))))

-  ((agent-p agent-or-agent-set)
-   (let ((*myself* *self*) (*self* agent-or-agent-set)) (funcall fn)))
+  ((agent-p agent-or-agentset)
+   (let ((*myself* *self*) (*self* agent-or-agentset)) (funcall fn)))

   (t
   (t

-   (error "Ask requires an agent-set or agent but got: ~A" agent-or-agent-set))))
+   (error "Ask requires an agentset or agent but got: ~A" agent-or-agentset))))

 
 

-(defun count (agent-set)
- "COUNT AGENT-SET => N
+(defun count (agentset)
+ "COUNT AGENTSET => N

 
 ARGUMENTS AND VALUES:
 
 
 ARGUMENTS AND VALUES:
 

-  AGENT-SET: a NetLogo agentset
+  AGENTSET: a NetLogo agentset

   N: a number
 
 DESCRIPTION:
 
   COUNT is equivalent to count in NetLogo.  Returns N, the number of
   N: a number
 
 DESCRIPTION:
 
   COUNT is equivalent to count in NetLogo.  Returns N, the number of

-  agents in AGENT-SET.
+  agents in AGENTSET.

 
   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#count"
 
   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#count"

- (coerce (length (agent-set-list agent-set)) 'double-float))
+ (coerce (length (agentset-list agentset)) 'double-float))

 
 

-(defun of (fn agent-or-agent-set)
- "OF FN AGENT-OR-AGENT-SET => RESULT
+(defun of (fn agent-or-agentset)
+ "OF FN AGENT-OR-AGENTSET => RESULT

 
 

-  AGENT-OR-AGENT-SET: AGENT | AGENT-SET
+  AGENT-OR-AGENTSET: AGENT | AGENTSET

   RESULT: RESULT-LIST | RESULT-VALUE
 
 ARGUMENTS AND VALUES:
 
   FN: a function, run on each agent
   AGENT: a NetLogo agent
   RESULT: RESULT-LIST | RESULT-VALUE
 
 ARGUMENTS AND VALUES:
 
   FN: a function, run on each agent
   AGENT: a NetLogo agent

-  AGENT-SET: a NetLogo agentset
+  AGENTSET: a NetLogo agentset

   RESULT-LIST: a list
   RESULT-VALUE: a single value
 
   RESULT-LIST: a list
   RESULT-VALUE: a single value
 


@@ -187,30 +189,54 @@ DESCRIPTION:
 
   OF is equivalent to of in NetLogo.
 
 
   OF is equivalent to of in NetLogo.
 

-  The specified AGENT-SET or AGENT runs the given FN.  In the case of an
-  AGENT-SET, the order in which the agents are run is random each time,
+  The specified AGENTSET or AGENT runs the given FN.  In the case of an
+  AGENTSET, the order in which the agents are run is random each time,

   and only agents that are in the set at the beginning of the call.
 
   and only agents that are in the set at the beginning of the call.
 

-  RESULT-LIST is returned when the input is an AGENT-SET, but RESULT-VALUE
+  RESULT-LIST is returned when the input is an AGENTSET, but RESULT-VALUE

   is returned when only passed an AGENT.
 
   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#of"
  (cond
   is returned when only passed an AGENT.
 
   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#of"
  (cond

-  ((agent-set-p agent-or-agent-set)
+  ((agentset-p agent-or-agentset)

    (let
    (let

-    ((iter (shufflerator (agent-set-list agent-or-agent-set))))
+    ((iter (shufflerator (agentset-list agent-or-agentset))))

     (loop
      :for agent := (funcall iter)
      :while agent
      :collect (let ((*myself* *self*) (*self* agent)) (funcall fn)))))
     (loop
      :for agent := (funcall iter)
      :while agent
      :collect (let ((*myself* *self*) (*self* agent)) (funcall fn)))))

-  ((agent-p agent-or-agent-set)
-   (let ((*myself* *self*) (*self* agent-or-agent-set)) (funcall fn)))
+  ((agent-p agent-or-agentset)
+   (let ((*myself* *self*) (*self* agent-or-agentset)) (funcall fn)))

   (t
   (t

-   (error "Of requires an agent-set or agent but got: ~A" agent-or-agent-set))))
+   (error "Of requires an agentset or agent but got: ~A" agent-or-agentset))))

 
 

-(defun shufflerator (agent-set-list)
+(defun with (agentset fn)
+ "WITH AGENTSET FN => RESULT-AGENTSET
+
+ARGUMENTS AND VALUES:
+
+  AGENTSET: a NetLogo agentset
+  FN: a boolean function, run on each agent to determine if included
+  RESULT-AGENTSET: an agentset of valid agents
+
+DESCRIPTION:
+
+  WITH is equivalent to with in NetLogo.
+
+  Returns a new agentset containing only those agents that reported true
+  when FN is called.
+
+  See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#with"
+ (list->agentset
+  (remove-if-not
+   (lambda (agent)
+    (let ((*myself* *self*) (*self* agent)) (funcall fn)))
+   (agentset-list agentset))
+  (agentset-breed agentset)))
+
+(defun shufflerator (agentset-list)

  (let
  (let

-  ((copy (copy-list agent-set-list))
+  ((copy (copy-list agentset-list))

    (i 0)
    (agent nil))
   (flet
    (i 0)
    (agent nil))
   (flet


@@ -313,25 +339,38 @@ DESCRIPTION:
    (max (+ (max-pycor) 0.5d0)))
   (+ min (clnl-random:next-double (- max min)))))
 
    (max (+ (max-pycor) 0.5d0)))
   (+ min (clnl-random:next-double (- max min)))))
 

-(defun one-of (agent-set)
- "ONE-OF AGENT-SET => RESULT
+(defun one-of (list-or-agentset)
+ "ONE-OF LIST-OR-AGENTSET => RESULT

 
 

-  RESULT: RANDOM-AGENT | :nobody
+  LIST-OR-AGENTSET: LIST | AGENTSET
+  RESULT: RANDOM-VALUE | RANDOM-AGENT | :nobody

 
 ARGUMENTS AND VALUES:
 
 
 ARGUMENTS AND VALUES:
 

-  AGENT-SET: An agent set
-  RANDOM-AGENT: an agent if AGENT-SET is non empty
+  LIST: A list
+  AGENTSET: An agent set
+  RANDOM-VALUE: a value in LIST
+  RANDOM-AGENT: an agent if AGENTSET is non empty

 
 DESCRIPTION:
 
 
 DESCRIPTION:
 

-  From an agentset, returns a random agent. If the agentset is empty, returns nobody.
+  From an AGENTSET, returns a RANDOM-AGENT. If the agentset is empty, returns :nobody.
+  From a list, returns a RANDOM-VALUE.  If the list is empty, an error occurs.

 
   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#one-of"
 
   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#one-of"

- (let*
-  ((agent-set-list (agent-set-list agent-set))
-   (length (length agent-set-list)))
-  (if (zerop length) :nobody (nth (clnl-random:next-int length) agent-set-list))))
+ (cond
+  ((agentset-p list-or-agentset)
+   (let*
+    ((agentset-list (agentset-list list-or-agentset))
+     (length (length agentset-list)))
+    (if (zerop length) :nobody (nth (clnl-random:next-int length) agentset-list))))
+  ((listp list-or-agentset)
+   (let*
+    ((length (length list-or-agentset)))
+    (if (zerop length)
+     (error "one-of requires a nonempty list")
+     (nth (clnl-random:next-int length) list-or-agentset))))
+  (t (error "one-of requires a list or agentset"))))

 
 (defun jump (n)
  (when (not (turtle-p *self*)) (error "Gotta call jump in turtle scope, dude (~A)" *self*))
 
 (defun jump (n)
  (when (not (turtle-p *self*)) (error "Gotta call jump in turtle scope, dude (~A)" *self*))


@@ -428,12 +467,13 @@ DESCRIPTION:
   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#right"
  (turn-right (- n)))
 
   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#right"
  (turn-right (- n)))
 

-(defun create-turtles (n)
- "CREATE-TURTLES N => RESULT
+(defun create-turtles (n &optional fn)
+ "CREATE-TURTLES N &optional FN => RESULT

 
 ARGUMENTS AND VALUES:
 
   N: an integer, the numbers of turtles to create
 
 ARGUMENTS AND VALUES:
 
   N: an integer, the numbers of turtles to create

+  FN: A function, applied to each turtle after creation

   RESULT: undefined
 
 DESCRIPTION:
   RESULT: undefined
 
 DESCRIPTION:


@@ -441,11 +481,35 @@ DESCRIPTION:
   Creates number new turtles at the origin.
 
   New turtles have random integer headings and the color is randomly selected
   Creates number new turtles at the origin.
 
   New turtles have random integer headings and the color is randomly selected

-  from the 14 primary colors.  If commands are supplied, the new turtles
-  immediately run them (unimplemented).
+  from the 14 primary colors.  If a function is supplied, the new turtles
+  immediately run it.

 
   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#create-turtles"
 
   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#create-turtles"

- (loop :for i :from 1 :to n :do (create-turtle)))
+ (let
+  ((new-turtles (loop :repeat n :collect (create-turtle))))
+  (when fn (ask (list->agentset new-turtles :turtles) fn))))
+
+(defun hatch (n &optional fn)
+ "HATCH N &optional FN => RESULT
+
+ARGUMENTS AND VALUES:
+
+  N: an integer, the numbers of turtles to hatch
+  FN: A function, applied to each turtle after creation
+  RESULT: undefined
+
+DESCRIPTION:
+
+  The turtle in *self* creates N new turtles. Each new turtle inherits of all its
+  variables, including its location, from self.
+
+  If FN is supplied, the new turtles immediately run it.
+
+  See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#hatch"
+ (when (not (turtle-p *self*)) (error "Can only hatch from turtle scope"))
+ (let
+  ((new-turtles (loop :repeat n :collect (create-turtle *self*))))
+  (when fn (ask (list->agentset new-turtles :turtles) fn))))

 
 (defun reset-ticks ()
  "RESET-TICKS => RESULT
 
 (defun reset-ticks ()
  "RESET-TICKS => RESULT


@@ -546,7 +610,10 @@ DESCRIPTION:
 (defmethod dump-object ((o (eql t))) "true")
 (defmethod dump-object ((o (eql nil))) "false")
 
 (defmethod dump-object ((o (eql t))) "true")
 (defmethod dump-object ((o (eql nil))) "false")
 

-(defmethod dump-object ((o list)) (format nil "[~{~A~^ ~}]" (mapcar #'dump-object o)))
+(defmethod dump-object ((o list))
+ (cond
+  ((agentset-p o) (format nil "(agentset, ~A ~A)" (dump-object (count o)) (string-downcase (agentset-breed o))))
+  (t (format nil "[~{~A~^ ~}]" (mapcar #'dump-object o)))))

 
 (defmethod dump-object ((o patch))
  (format nil "(patch ~A ~A)" (dump-object (patch-xcor o)) (dump-object (patch-ycor o))))
 
 (defmethod dump-object ((o patch))
  (format nil "(patch ~A ~A)" (dump-object (patch-xcor o)) (dump-object (patch-ycor o))))