Code - breeds

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

diff --git a/src/main/nvm/nvm.lisp b/src/main/nvm/nvm.lisp
index a272a34526490aa84b4d189831beef373dd1fa54..098133282e58a53c9cb8229a8f7d5a6f7e89b727 100644 (file)
--- a/src/main/nvm/nvm.lisp
+++ b/src/main/nvm/nvm.lisp
@@ -48,9 +48,10 @@ DESCRIPTION:
   (:magenta 125d0)
   (:pink 135d0)))
 
   (:magenta 125d0)
   (:pink 135d0)))
 

-(defun create-turtle (&optional base-turtle)
- (let
-  ((new-turtle (make-turtle
+(defun create-turtle (breed &optional base-turtle)
+ (let*
+  ((breed (or breed (and base-turtle (turtle-breed base-turtle)) :turtles))
+   (new-turtle (make-turtle

                 :who (coerce *current-id* 'double-float)
                 :color (if base-turtle
                         (turtle-color base-turtle)
                 :who (coerce *current-id* 'double-float)
                 :color (if base-turtle
                         (turtle-color base-turtle)


@@ -58,9 +59,13 @@ DESCRIPTION:
                 :heading (if base-turtle
                           (turtle-heading base-turtle)
                           (coerce (clnl-random:next-int 360) 'double-float))
                 :heading (if base-turtle
                           (turtle-heading base-turtle)
                           (coerce (clnl-random:next-int 360) 'double-float))

-                :shape (breed-default-shape :turtles)
+                :breed breed
+                :shape (breed-default-shape breed)

                 :xcor (if base-turtle (turtle-xcor base-turtle) 0d0)
                 :ycor (if base-turtle (turtle-ycor base-turtle) 0d0))))
                 :xcor (if base-turtle (turtle-xcor base-turtle) 0d0)
                 :ycor (if base-turtle (turtle-ycor base-turtle) 0d0))))

+  (let
+   ((patch (patch-at (turtle-xcor new-turtle) (turtle-ycor new-turtle))))
+   (setf (patch-turtles patch) (nconc (patch-turtles patch) (list new-turtle))))

   (setf *turtles* (nconc *turtles* (list new-turtle)))
   (incf *current-id*)
   new-turtle))
   (setf *turtles* (nconc *turtles* (list new-turtle)))
   (incf *current-id*)
   new-turtle))


@@ -122,6 +127,26 @@ DESCRIPTION:
   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#turtles"
  :turtles)
 
   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#turtles"
  :turtles)
 

+(defun turtles-here (&optional breed)
+ "TURTLES-HERE => TURTLES
+
+ARGUMENTS AND VALUES:
+
+  TURTLES: an agentset
+
+DESCRIPTION:
+
+  Returns the agentset consisting of all the turtles sharing the patch
+  with the agent in by *self*
+
+  See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#turtles-here"
+ (when (not (turtle-p *self*)) (error "Gotta call turtles-here with a turtle"))
+ (let
+  ((patch-turtles (patch-turtles (patch-at (turtle-xcor *self*) (turtle-ycor *self*)))))
+  (list->agentset
+   (if breed (remove breed patch-turtles :key #'turtle-breed :test-not #'eql) patch-turtles)
+   (or breed :turtles))))
+

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


@@ -422,14 +447,15 @@ DESCRIPTION:
 
 (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*))

- (setf
-  (turtle-xcor *self*)
-  (wrap-x *topology*
-   (+ (turtle-xcor *self*) (* n (using-cached-sin (turtle-heading *self*))))))
- (setf
-  (turtle-ycor *self*)
-  (wrap-y *topology*
-   (+ (turtle-ycor *self*) (* n (using-cached-cos (turtle-heading *self*)))))))
+ (with-patch-update *self*
+  (setf
+   (turtle-xcor *self*)
+   (wrap-x *topology*
+    (+ (turtle-xcor *self*) (* n (using-cached-sin (turtle-heading *self*))))))
+  (setf
+   (turtle-ycor *self*)
+   (wrap-y *topology*
+    (+ (turtle-ycor *self*) (* n (using-cached-cos (turtle-heading *self*))))))))

 
 (defun setxy (x y)
  "SETXY X Y => RESULT
 
 (defun setxy (x y)
  "SETXY X Y => RESULT


@@ -535,26 +561,28 @@ 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 &optional fn)
- "CREATE-TURTLES N &optional FN => RESULT
+(defun create-turtles (n &optional breed fn)
+ "CREATE-TURTLES N &optional BREED 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

+  BREED: a breed

   FN: A function, applied to each turtle after creation
   RESULT: undefined
 
 DESCRIPTION:
 
   FN: A function, applied to each turtle after creation
   RESULT: undefined
 
 DESCRIPTION:
 

-  Creates number new turtles at the origin.
+  Creates N new turtles at the origin.

 
   New turtles have random integer headings and the color is randomly selected
 
   New turtles have random integer headings and the color is randomly selected

-  from the 14 primary colors.  If a function is supplied, the new turtles
-  immediately run it.
+  from the 14 primary colors.  If FN is supplied, the new turtles immediately
+  run it.  If a BREED is supplied, that is the breed the new turtles are set
+  to.

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

-  ((new-turtles (loop :repeat n :collect (create-turtle))))
+  ((new-turtles (loop :repeat n :collect (create-turtle breed))))

   (when fn (ask (list->agentset new-turtles :turtles) fn))))
 
 (defun hatch (n &optional fn)
   (when fn (ask (list->agentset new-turtles :turtles) fn))))
 
 (defun hatch (n &optional fn)


@@ -576,7 +604,7 @@ DESCRIPTION:
   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#hatch"
  (when (not (turtle-p *self*)) (error "Can only hatch from turtle scope"))
  (let
   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*))))
+  ((new-turtles (loop :repeat n :collect (create-turtle nil *self*))))

   (when fn (ask (list->agentset new-turtles :turtles) fn))))
 
 (defun reset-ticks ()
   (when fn (ask (list->agentset new-turtles :turtles) fn))))
 
 (defun reset-ticks ()


@@ -647,10 +675,15 @@ DESCRIPTION:
 (defun clear-ticks ()
  (setf *ticks* nil))
 
 (defun clear-ticks ()
  (setf *ticks* nil))
 

-(defun create-world (&key dims)
- "CREATE-WORLD &key DIMS => RESULT
+(defun create-world (&key dims globals turtles-own-vars patches-own-vars breeds)
+ "CREATE-WORLD &key DIMS GLOBALS TURTLES-OWN-VARS PATCHES-OWN-VARS BREEDS => RESULT

 
   DIMS: (:xmin XMIN :xmax XMAX :ymin YMIN :ymax YMAX)
 
   DIMS: (:xmin XMIN :xmax XMAX :ymin YMIN :ymax YMAX)

+  GLOBALS: GLOBAL*
+  TURTLES-OWN-VARS: TURTLES-OWN-VAR*
+  PATCHES-OWN-VARS: PATCHES-OWN-VAR*
+  BREEDS: BREED*
+  GLOBAL: (GLOBAL-NAME GLOBAL-ACCESS-FUNC)

 
 ARGUMENTS AND VALUES:
 
 
 ARGUMENTS AND VALUES:
 


@@ -659,6 +692,11 @@ ARGUMENTS AND VALUES:
   XMAX: An integer representing the maximum patch coord in X
   YMIN: An integer representing the minimum patch coord in Y
   YMAX: An integer representing the maximum patch coord in Y
   XMAX: An integer representing the maximum patch coord in X
   YMIN: An integer representing the minimum patch coord in Y
   YMAX: An integer representing the maximum patch coord in Y

+  TURTLES-OWN-VAR: Symbol for the turtles own variable in the keyword package
+  PATCHES-OWN-VAR: Symbol for the patches own variable in the keyword package
+  BREED: A list of symbols representing the possible preeds
+  GLOBAL-NAME: Symbol for the global in the keyword package
+  GLOBAL-ACCESS-FUNC: Function to get the value of the global

 
 DESCRIPTION:
 
 
 DESCRIPTION:
 


@@ -666,8 +704,14 @@ DESCRIPTION:
 
   This should be called before using the engine in any real capacity.  If
   called when an engine is already running, it may do somethign weird."
 
   This should be called before using the engine in any real capacity.  If
   called when an engine is already running, it may do somethign weird."

+ (setf *turtles-own-vars* turtles-own-vars)
+ (setf *patches-own-vars* patches-own-vars)

  (setf *dimensions* dims)
  (setf *dimensions* dims)

- (setf *breeds* (list (list :turtles "default")))
+ (setf *globals* globals)
+ (setf *breeds*
+  (append
+   (list (list :turtles "default"))
+   (mapcar (lambda (breed) (list breed "default")) breeds)))

  (clear-ticks)
  (clear-patches)
  (clear-turtles))
  (clear-ticks)
  (clear-patches)
  (clear-turtles))


@@ -699,6 +743,11 @@ DESCRIPTION:
 
 (defmethod dump-object ((o turtle)) (format nil "(turtle ~A)" (dump-object (turtle-who o))))
 (defmethod dump-object ((o (eql :nobody))) (format nil "nobody"))
 
 (defmethod dump-object ((o turtle)) (format nil "(turtle ~A)" (dump-object (turtle-who o))))
 (defmethod dump-object ((o (eql :nobody))) (format nil "nobody"))

+(defmethod dump-object ((o (eql :turtles))) (format nil "{all-turtles}"))
+(defmethod dump-object ((o symbol))
+ (cond
+  ((find o *breeds* :key #'car) (format nil "{breed ~(~A~)}" o))
+  (t (error "Keyword unrecognized by dump object: ~A" o))))

 
 (defun current-state ()
  "CURRENT-STATE => WORLD-STATE
 
 (defun current-state ()
  "CURRENT-STATE => WORLD-STATE


@@ -741,13 +790,14 @@ DESCRIPTION:
  (append
   (list
    "\"TURTLES\""
  (append
   (list
    "\"TURTLES\""

-   (format nil "~A~A"
+   (format nil "~A~A~{,\"~A\"~}"

     "\"who\",\"color\",\"heading\",\"xcor\",\"ycor\",\"shape\",\"label\",\"label-color\","
     "\"who\",\"color\",\"heading\",\"xcor\",\"ycor\",\"shape\",\"label\",\"label-color\","

-    "\"breed\",\"hidden?\",\"size\",\"pen-size\",\"pen-mode\""))
+    "\"breed\",\"hidden?\",\"size\",\"pen-size\",\"pen-mode\""
+    (mapcar #'string-downcase *turtles-own-vars*)))

   (mapcar
    (lambda (turtle)
     (format nil
   (mapcar
    (lambda (turtle)
     (format nil

-     "\"~A\",\"~A\",\"~A\",\"~A\",\"~A\",\"~A\",\"~A\",\"~A\",\"{all-turtles}\",\"false\",\"~A\",~A"
+     "\"~A\",\"~A\",\"~A\",\"~A\",\"~A\",\"~A\",\"~A\",\"~A\",\"~A\",\"false\",\"~A\",~A~{,\"~A\"~}"

      (dump-object (turtle-who turtle))
      (dump-object (turtle-color turtle))
      (dump-object (turtle-heading turtle))
      (dump-object (turtle-who turtle))
      (dump-object (turtle-color turtle))
      (dump-object (turtle-heading turtle))


@@ -756,22 +806,26 @@ DESCRIPTION:
      (dump-object (turtle-shape turtle))
      (dump-object (turtle-label turtle))
      (dump-object (turtle-label-color turtle))
      (dump-object (turtle-shape turtle))
      (dump-object (turtle-label turtle))
      (dump-object (turtle-label-color turtle))

+     (dump-object (turtle-breed turtle))

      (dump-object (turtle-size turtle))
      (dump-object (turtle-size turtle))

-     "\"1\",\"\"\"up\"\"\""))
+     "\"1\",\"\"\"up\"\"\""
+     (mapcar #'dump-object (mapcar (lambda (var) (agent-value-inner turtle var)) *turtles-own-vars*))))

    *turtles*)))
 
 (defun export-patches ()
  (append
   (list
    "\"PATCHES\""
    *turtles*)))
 
 (defun export-patches ()
  (append
   (list
    "\"PATCHES\""

-   "\"pxcor\",\"pycor\",\"pcolor\",\"plabel\",\"plabel-color\"")
+   (format nil "\"pxcor\",\"pycor\",\"pcolor\",\"plabel\",\"plabel-color\"~{,\"~A\"~}"
+    (mapcar #'string-downcase *patches-own-vars*)))

   (mapcar
    (lambda (patch)
     (format nil
   (mapcar
    (lambda (patch)
     (format nil

-     "\"~A\",\"~A\",\"~A\",\"\"\"\"\"\",\"9.9\""
+     "\"~A\",\"~A\",\"~A\",\"\"\"\"\"\",\"9.9\"~{,\"~A\"~}"

      (dump-object (patch-xcor patch))
      (dump-object (patch-ycor patch))
      (dump-object (patch-xcor patch))
      (dump-object (patch-ycor patch))

-     (dump-object (patch-color patch))))
+     (dump-object (patch-color patch))
+     (mapcar #'dump-object (mapcar (lambda (var) (agent-value-inner patch var)) *patches-own-vars*))))

    *patches*)))
 
 (defun export-world ()
    *patches*)))
 
 (defun export-world ()


@@ -794,11 +848,13 @@ DESCRIPTION:
    (format nil "~S" (clnl-random:export))
    ""
    (format nil "~S" "GLOBALS")
    (format nil "~S" (clnl-random:export))
    ""
    (format nil "~S" "GLOBALS")

-   (format nil "~A~A"
+   (format nil "~A~A~{\"~A\"~^,~}"

     "\"min-pxcor\",\"max-pxcor\",\"min-pycor\",\"max-pycor\",\"perspective\",\"subject\","
     "\"min-pxcor\",\"max-pxcor\",\"min-pycor\",\"max-pycor\",\"perspective\",\"subject\","

-    "\"nextIndex\",\"directed-links\",\"ticks\",")
-   (format nil "\"~A\",\"~A\",\"~A\",\"~A\",\"0\",\"nobody\",\"~A\",\"\"\"NEITHER\"\"\",\"-1\""
-    (min-pxcor) (max-pxcor) (min-pycor) (max-pycor) *current-id*)
+    "\"nextIndex\",\"directed-links\",\"ticks\","
+    (mapcar #'string-downcase (mapcar #'car *globals*)))
+   (format nil "\"~A\",\"~A\",\"~A\",\"~A\",\"0\",\"nobody\",\"~A\",\"\"\"NEITHER\"\"\",\"~A\"~{,\"~A\"~}"
+    (min-pxcor) (max-pxcor) (min-pycor) (max-pycor) *current-id* (dump-object (or *ticks* -1d0))
+    (mapcar #'dump-object (mapcar #'funcall (mapcar #'cadr *globals*))))

    ""
    (format nil "~{~A~^~%~}" (export-turtles))
    ""
    ""
    (format nil "~{~A~^~%~}" (export-turtles))
    ""