Shufflerator now shuffles like the NL one does!

diff --git a/bin/runcmd.scala b/bin/runcmd.scala
index f2487aef0769fbfb7ca9aa60698725db1bbf1cfb..8afdc36a8ac9a26cc7d24f2a71e88016477f8a1d 100755 (executable)
--- 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 35cb2f737d3b5d43d75c52c9d6ddd9e13519245b..9844d36923a1aed078244d6252e94a8e4eb769e7 100644 (file)
--- 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 c203ebea5f9e0c933df21476a43a6b4758ab8356..79b0b36be2fa3d463e95fd02c470a7f1a2de30a0 100644 (file)
--- 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<posint>, 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 508cb6b798681abaced12cfa0a3e2b813928c394..6c9ecaa7c6fd42b6d4cba8653d665b74a42c29a2 100644 (file)
--- 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 41c91edf975b0ba4a7a89c1194076dee7fdbcd70..b47ac89f1c181c64e2ff35b316d5ccfd835f93ca 100644 (file)
--- 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")