From d429346c4e41599eaae8de2f4baa9c1b8a81aea6 Mon Sep 17 00:00:00 2001 From: Frank Duncan Date: Tue, 9 Jun 2015 07:43:14 -0500 Subject: [PATCH] Shufflerator now shuffles like the NL one does! --- bin/runcmd.scala | 1 - src/main/main.lisp | 6 ++-- src/main/nvm.lisp | 68 +++++++++++++++++++++++---------------- src/main/random.lisp | 5 ++- src/test/simpletests.lisp | 2 ++ 5 files changed, 49 insertions(+), 33 deletions(-) diff --git a/bin/runcmd.scala b/bin/runcmd.scala index f2487ae..8afdc36 100755 --- a/bin/runcmd.scala +++ b/bin/runcmd.scala @@ -18,7 +18,6 @@ exec scalas "$0" -q "$@" */ import org.nlogo.headless.HeadlessWorkspace -import org.nlogo.mirror import org.nlogo.api import org.nlogo.nvm import org.nlogo.util.Utils.url2String diff --git a/src/main/main.lisp b/src/main/main.lisp index 35cb2f7..9844d36 100644 --- a/src/main/main.lisp +++ b/src/main/main.lisp @@ -4,9 +4,9 @@ (defun r (str) (let* - ((lexed-ast (let ((ast (cl-nl.lexer:lex str))) (format t "Via lexing, AST for ~S became ~S~%" str ast) ast)) - (parsed-ast (let ((ast (cl-nl.parser:parse lexed-ast))) (format t "Via parsing, AST for ~S became ~S~%" lexed-ast ast) ast)) - (transpiled-ast (let ((ast (cl-nl.transpiler:transpile-commands parsed-ast))) (format t "Via transpiling, AST for ~S became ~S~%" parsed-ast ast) ast))) + ((lexed-ast (let ((ast (cl-nl.lexer:lex str))) (format t "Via lexing, AST for~%~S~% became~%~S~%~%" str ast) ast)) + (parsed-ast (let ((ast (cl-nl.parser:parse lexed-ast))) (format t "Via parsing, AST for~%~S~% became~%~S~%~%" lexed-ast ast) ast)) + (transpiled-ast (let ((ast (cl-nl.transpiler:transpile-commands parsed-ast))) (format t "Via transpiling, AST for~%~S~% became~%~S~%" parsed-ast ast) ast))) (eval transpiled-ast))) (defun p (result) result) diff --git a/src/main/nvm.lisp b/src/main/nvm.lisp index c203ebe..79b0b36 100644 --- a/src/main/nvm.lisp +++ b/src/main/nvm.lisp @@ -13,44 +13,53 @@ (format t "Showing: ~A~%" (dump-object n))) (defun create-turtle () - (push - (make-turtle :who *current-id* - :color (coerce (+ 5 (* 10 (cl-nl.random:next-int 14))) 'double-float) - :heading (coerce (cl-nl.random:next-int 360) 'double-float) - :xcor 0d0 - :ycor 0d0) - *turtles*) + (setf + *turtles* + (nconc + *turtles* + (list + (make-turtle :who *current-id* + :color (coerce (+ 5 (* 10 (cl-nl.random:next-int 14))) 'double-float) + :heading (coerce (cl-nl.random:next-int 360) 'double-float) + :xcor 0d0 + :ycor 0d0)))) (incf *current-id*)) (defun turtles () *turtles*) (defun ask (agent-set fn) - (mapcar - (lambda (agent) - (let - ((*myself* *self*) - (*self* agent)) - (funcall fn))) - (shuffle agent-set))) + (let + ((iter (shufflerator agent-set))) + (loop for agent = (funcall iter) + while agent + do (let ((*myself* *self*) (*self* agent)) (funcall fn))))) -(defun shuffle (agent-set) +(defun shufflerator (agent-set) (let - ((copy (copy-list agent-set))) - (append - (loop for i to (- (length copy) 2) - for idx = (+ i (cl-nl.random:next-int (- (length copy) i))) - for next = (nth idx copy) - do (setf (nth idx copy) (nth i copy)) - collect next) - (last copy)))) + ((copy (copy-list agent-set)) + (i 0) + (agent nil)) + (flet + ((fetch () + (let + ((idx (when (< i (1- (length copy))) (+ i (cl-nl.random:next-int (- (length copy) i)))))) + (when idx (setf agent (nth idx copy))) + (when idx (setf (nth idx copy) (nth i copy))) + (incf i)))) + (fetch) ; we pre-fetch because netlogo does, rng sync hype! + (lambda () + (cond + ((> i (length copy)) nil) + ((= i (length copy)) (incf i) (car (last copy))) + (t (let ((result agent)) (fetch) result))))))) (defun random-float (n) (cl-nl.random:next-double n)) (defun fd (n) - (when (not (turtle-p *self*)) (error "Gotta call fd in turtle scope, dude")) - (setf (turtle-xcor *self*) (+ (turtle-xcor *self*) (sin (* pi (/ (turtle-heading *self*) 180))))) - (setf (turtle-ycor *self*) (+ (turtle-ycor *self*) (cos (* pi (/ (turtle-heading *self*) 180)))))) + (when (not (turtle-p *self*)) (error "Gotta call fd in turtle scope, dude (~A)" *self*)) + (setf (turtle-xcor *self*) (+ (turtle-xcor *self*) (* n (sin (* pi (/ (turtle-heading *self*) 180)))))) + (setf (turtle-ycor *self*) (+ (turtle-ycor *self*) (* n (cos (* pi (/ (turtle-heading *self*) 180))))))) (defun create-turtles (n) (loop for i from 1 to n do (create-turtle))) @@ -59,12 +68,15 @@ (setf *turtles* nil) (setf *current-id* 0)) +; These match netlogo's dump (defgeneric dump-object (o)) (defmethod dump-object ((n double-float)) (multiple-value-bind (int rem) (floor n) (if (eql 0d0 rem) (format nil "~A" int) - (format nil "~F" n)))) + (let + ((output (format nil "~D" n))) + (cl-ppcre:regex-replace "d-" (cl-ppcre:regex-replace "d0" output "") "E-"))))) ; Someday we'll have d, but this is not that day! (defmethod dump-object ((o string)) o) (defun export-world () @@ -90,7 +102,7 @@ (dump-object (turtle-xcor turtle)) (dump-object (turtle-ycor turtle)) )) - (reverse *turtles*))) + *turtles*)) (format nil "~S" "PATCHES") "\"pxcor\",\"pycor\",\"pcolor\",\"plabel\",\"plabel-color\"" "\"-1\",\"1\",\"0\",\"\"\"\"\"\",\"9.9\"" diff --git a/src/main/random.lisp b/src/main/random.lisp index 508cb6b..6c9ecaa 100644 --- a/src/main/random.lisp +++ b/src/main/random.lisp @@ -7,7 +7,10 @@ (setf mt19937:*random-state* (mt19937::make-random-object :state (mt19937:init-random-state n)))) (defun next-int (n) - (rem (ash (mt19937:random-chunk mt19937:*random-state*) -1) n)) + (if + (= n (logand n (- n) )) + (ash (* n (ash (mt19937:random-chunk mt19937:*random-state*) -1) ) -31) + (rem (ash (mt19937:random-chunk mt19937:*random-state*) -1) n))) (defun next-double (&optional (n 1d0)) (let diff --git a/src/test/simpletests.lisp b/src/test/simpletests.lisp index 41c91ed..b47ac89 100644 --- a/src/test/simpletests.lisp +++ b/src/test/simpletests.lisp @@ -4,5 +4,7 @@ (defsimplecommandtest "Simple crt" "crt 1" "2F08B31AC06C9D5339E6B3E953C2B4B71FDB9CDE") (defsimplecommandtest "Simple crt 2" "crt 5" "9FE588C2749CD9CE66CB0EA451EFB80476E881FB") (defsimplecommandtest "Simple crt and fd" "crt 5 ask turtles [ fd 1 ]" "BEB43404EDC7852985A9A7FC312481785FE553A0") +(defsimplecommandtest "Simple crt and fd random" "crt 5 ask turtles [ fd random-float 1 ]" "F7AC3B3492CDFD01D1FB5BD69FAAA67E06D3A870") +;(defsimplecommandtest "Simple crt and fd random 2" "crt 30 ask turtles [ fd random-float 1 ]" "F7AC3B3492CDFD01D1FB5BD69FAAA67E06D3A870") ; we start getting floating errors, cool! (defsimplereportertest "Random 1" "random-float 5" "4.244088516651127" "17D1BF7FF7BF2C7F3F5F7DD7CF67CFF2772CFFFC") -- 2.25.1