X-Git-Url: https://code.consxy.com/gitweb/gitweb.cgi?a=blobdiff_plain;f=src%2Fmain%2Fnvm%2Fnvm.lisp;h=6fdc812964cb72e5f4c0a73b58d955615bcd3b52;hb=1dd12dd;hp=0a819ae4041322011e584b7dda08a59f2f792863;hpb=ef8590acac123b880b2719eaac691af310262cca;p=clnl diff --git a/src/main/nvm/nvm.lisp b/src/main/nvm/nvm.lisp index 0a819ae..6fdc812 100644 --- a/src/main/nvm/nvm.lisp +++ b/src/main/nvm/nvm.lisp @@ -48,19 +48,21 @@ DESCRIPTION: (: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 @@ -100,7 +102,7 @@ DESCRIPTION: each time it's used, so changes depending on the state of the engine. See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#patches" - *patches*) + :patches) (defun turtles () "TURTLES => ALL-TURTLES @@ -117,62 +119,124 @@ DESCRIPTION: each time it's used, so changes depending on the state of the engine. See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#turtles" - *turtles*) + :turtles) + +(defun ask (agent-or-agentset fn) + "ASK AGENT-OR-AGENTSET FN => RESULT -(defun ask (agent-set fn) - "ASK AGENT-SET FN => RESULT + AGENT-OR-AGENTSET: AGENT | AGENTSET ARGUMENTS AND VALUES: - AGENT-SET: a NetLogo agentset FN: a function, run on each agent RESULT: undefined, commands don't return + AGENT: a NetLogo agent + AGENTSET: a NetLogo agentset DESCRIPTION: ASK is equivalent to ask in NetLogo. - The specified AGENT-SET runs the given FN. 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. + 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" - (let - ((iter (shufflerator (agent-set-list agent-set)))) - (loop - :for agent := (funcall iter) - :while agent - :do (let ((*myself* *self*) (*self* agent)) (funcall fn))))) + (cond + ((agentset-p agent-or-agentset) + (let + ((iter (shufflerator (agentset-list agent-or-agentset)))) + (loop + :for agent := (funcall iter) + :while agent + :do (let ((*myself* *self*) (*self* agent)) (funcall fn))))) + ((agent-p agent-or-agentset) + (let ((*myself* *self*) (*self* agent-or-agentset)) (funcall fn))) + (t + (error "Ask requires an agentset or agent but got: ~A" agent-or-agentset)))) + +(defun count (agentset) + "COUNT AGENTSET => N + +ARGUMENTS AND VALUES: + + AGENTSET: a NetLogo agentset + N: a number + +DESCRIPTION: -(defun of (fn agent-set) - "OF FN AGENT-SET => RESULT + COUNT is equivalent to count in NetLogo. Returns N, the number of + agents in AGENTSET. + + See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#count" + (coerce (length (agentset-list agentset)) 'double-float)) + +(defun of (fn agent-or-agentset) + "OF FN AGENT-OR-AGENTSET => RESULT + + AGENT-OR-AGENTSET: AGENT | AGENTSET + RESULT: RESULT-LIST | RESULT-VALUE ARGUMENTS AND VALUES: FN: a function, run on each agent - AGENT-SET: a NetLogo agentset - RESULT: a list + AGENT: a NetLogo agent + AGENTSET: a NetLogo agentset + RESULT-LIST: a list + RESULT-VALUE: a single value DESCRIPTION: OF is equivalent to of in NetLogo. - The specified AGENT-SET runs the given FN. 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. A list is returned of the returned valuse of - FN. + 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. + + 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" - (let - ((iter (shufflerator (agent-set-list agent-set)))) - (loop - :for agent := (funcall iter) - :while agent - :collect (let ((*myself* *self*) (*self* agent)) (funcall fn))))) + (cond + ((agentset-p agent-or-agentset) + (let + ((iter (shufflerator (agentset-list agent-or-agentset)))) + (loop + :for agent := (funcall iter) + :while agent + :collect (let ((*myself* *self*) (*self* agent)) (funcall fn))))) + ((agent-p agent-or-agentset) + (let ((*myself* *self*) (*self* agent-or-agentset)) (funcall fn))) + (t + (error "Of requires an agentset or agent but got: ~A" agent-or-agentset)))) + +(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 -(defun shufflerator (agent-set-list) +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 - ((copy (copy-list agent-set-list)) + ((copy (copy-list agentset-list)) (i 0) (agent nil)) (flet @@ -212,28 +276,104 @@ DESCRIPTION: See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#random-float" (clnl-random:next-double n)) -(defun one-of (agent-set) - "ONE-OF AGENT-SET => RESULT +(defun random (n) + "RANDOM N => RANDOM-NUMBER + +ARGUMENTS AND VALUES: + + N: an integer, the upper bound of the random + RANDOM-NUMBER: an integer, the random result + +DESCRIPTION: + + Returns a random number strictly closer to zero than N. + + If number is positive, returns a random integer greater than or equal to 0, + but strictly less than number. + + If number is negative, returns a random integer less than or equal to 0, + but strictly greater than number. + + If number is zero, the result is always 0. + + See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#random" + (coerce (clnl-random:next-long (truncate n)) 'double-float)) - RESULT: RANDOM-AGENT | :nobody +(defun random-xcor () + "RANDOM-XCOR => RANDOM-NUMBER ARGUMENTS AND VALUES: - AGENT-SET: An agent set - RANDOM-AGENT: an agent if AGENT-SET is non empty + RANDOM-NUMBER: a float, the random result DESCRIPTION: - From an agentset, returns a random agent. If the agentset is empty, returns nobody. + Returns a random floating point number in the allowable range of turtle + coordinates along the x axis. + + These range from min-pxcor - 0.5 (inclusive) to max-pxcor + 0.5 (exclusive) + + See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#random-cor" + (let + ((min (- (min-pxcor) 0.5d0)) + (max (+ (max-pxcor) 0.5d0))) + (+ min (clnl-random:next-double (- max min))))) + +(defun random-ycor () + "RANDOM-YCOR => RANDOM-NUMBER + +ARGUMENTS AND VALUES: + + RANDOM-NUMBER: a float, the random result + +DESCRIPTION: + + Returns a random floating point number in the allowable range of turtle + coordinates along the y axis. + + These range from min-pycor - 0.5 (inclusive) to max-pycor + 0.5 (exclusive) + + See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#random-cor" + (let + ((min (- (min-pycor) 0.5d0)) + (max (+ (max-pycor) 0.5d0))) + (+ min (clnl-random:next-double (- max min))))) + +(defun one-of (list-or-agentset) + "ONE-OF LIST-OR-AGENTSET => RESULT + + LIST-OR-AGENTSET: LIST | AGENTSET + RESULT: RANDOM-VALUE | RANDOM-AGENT | :nobody + +ARGUMENTS AND VALUES: + + LIST: A list + AGENTSET: An agent set + RANDOM-VALUE: a value in LIST + RANDOM-AGENT: an agent if AGENTSET is non empty + +DESCRIPTION: + + 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" - (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 fd in turtle scope, dude (~A)" *self*)) + (when (not (turtle-p *self*)) (error "Gotta call jump in turtle scope, dude (~A)" *self*)) (setf (turtle-xcor *self*) (wrap-x *topology* @@ -243,6 +383,25 @@ DESCRIPTION: (wrap-y *topology* (+ (turtle-ycor *self*) (* n (using-cached-cos (turtle-heading *self*))))))) +(defun setxy (x y) + "SETXY X Y => RESULT + +ARGUMENTS AND VALUES: + + X: a double + Y: a double + RESULT: undefined + +DESCRIPTION: + + Sets the x-coordinate and y-coordinate for the turle. Equivalent to + set xcor x set ycor y, except it happens in one step inside of two. + + See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#setxy" + (when (not (turtle-p *self*)) (error "Gotta call setxy in turtle scope, dude (~A)" *self*)) + (setf (turtle-xcor *self*) (wrap-x *topology* x)) + (setf (turtle-ycor *self*) (wrap-y *topology* y))) + (defun forward (n) "FORWARD N => RESULT @@ -308,12 +467,13 @@ DESCRIPTION: 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 + FN: A function, applied to each turtle after creation RESULT: undefined DESCRIPTION: @@ -321,11 +481,35 @@ DESCRIPTION: 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" - (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 @@ -426,7 +610,10 @@ DESCRIPTION: (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))))