code.consxy.com Git - clnl/blob - src/main/nvm.lisp

   1 (in-package #:clnl-nvm)
   2
   3 ; This is the engine.  Yay.
   4
   5 (defvar *current-id* 0)
   6
   7 (defstruct turtle who color heading xcor ycor)
   8 (defvar *turtles* nil)
   9 (defvar *myself* nil)
  10 (defvar *self* nil)
  11
  12 (defun show (n)
  13  "Prints value in the Command Center, preceded by this agent, and followed by a carriage return.
  14
  15 See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#show"
  16  (format t "Showing: ~A~%" (dump-object n)))
  17
  18 (defun create-turtle ()
  19  (setf
  20   *turtles*
  21   (nconc
  22    *turtles*
  23    (list
  24     (make-turtle :who *current-id*
  25                  :color (coerce (+ 5 (* 10 (clnl-random:next-int 14))) 'double-float)
  26                  :heading (coerce (clnl-random:next-int 360) 'double-float)
  27                  :xcor 0d0
  28                  :ycor 0d0))))
  29  (incf *current-id*))
  30
  31 (defun turtles ()
  32 "Reports the agentset consisting of all turtles.
  33
  34 See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#turtles"
  35  *turtles*)
  36
  37 (defun ask (agent-set fn)
  38 "The specified agent or agentset runs the given commands.
  39
  40 See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#ask"
  41  (let
  42   ((iter (shufflerator agent-set)))
  43   (loop for agent = (funcall iter)
  44         while agent
  45         do (let ((*myself* *self*) (*self* agent)) (funcall fn)))))
  46
  47 (defun shufflerator (agent-set)
  48  (let
  49   ((copy (copy-list agent-set))
  50    (i 0)
  51    (agent nil))
  52   (flet
  53    ((fetch ()
  54      (let
  55       ((idx (when (< i (1- (length copy))) (+ i (clnl-random:next-int (- (length copy) i))))))
  56       (when idx (setf agent (nth idx copy)))
  57       (when idx (setf (nth idx copy) (nth i copy)))
  58       (incf i))))
  59    (fetch) ; we pre-fetch because netlogo does, rng sync hype!
  60    (lambda ()
  61     (cond
  62      ((> i (length copy)) nil)
  63      ((= i (length copy)) (incf i) (car (last copy)))
  64      (t (let ((result agent)) (fetch) result)))))))
  65
  66 (defun random-float (n)
  67 "If number is positive, returns a random floating point number greater than or equal to 0 but strictly less than number.
  68
  69 If number is negative, returns a random floating point number less than or equal to 0, but strictly greater than number.
  70
  71 If number is zero, the result is always 0.
  72
  73 See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#random-float"
  74  (clnl-random:next-double n))
  75
  76 (defun forward (n)
  77 "The turtle moves forward by number steps, one step at a time. (If number is negative, the turtle moves backward.)
  78
  79 See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#forward"
  80  (when (not (turtle-p *self*)) (error "Gotta call fd in turtle scope, dude (~A)" *self*))
  81  (setf (turtle-xcor *self*) (+ (turtle-xcor *self*) (* n (sin (* pi (/ (turtle-heading *self*) 180))))))
  82  (setf (turtle-ycor *self*) (+ (turtle-ycor *self*) (* n (cos (* pi (/ (turtle-heading *self*) 180)))))))
  83
  84 (defun create-turtles (n)
  85 "Creates number new turtles at the origin. New turtles have random integer
  86 headings and the color is randomly selected from the 14 primary colors.
  87
  88 If commands are supplied, the new turtles immediately run them.
  89
  90 See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#create-turtles"
  91  (loop for i from 1 to n do (create-turtle)))
  92
  93 (defun create-world ()
  94  (setf *turtles* nil)
  95  (setf *current-id* 0))
  96
  97 ; These match netlogo's dump
  98 (defgeneric dump-object (o))
  99 (defmethod dump-object ((n double-float))
 100  (multiple-value-bind (int rem) (floor n)
 101   (if (eql 0d0 rem)
 102       (format nil "~A" int)
 103       (let
 104        ((output (format nil "~D" n)))
 105        (cl-ppcre:regex-replace "d-" (cl-ppcre:regex-replace "d0" output "") "E-"))))) ; Someday we'll have d<posint>, but this is not that day!
 106 (defmethod dump-object ((o string)) o)
 107
 108 (defun export-world ()
 109  (format nil "~{~A~%~}"
 110   (list
 111    (format nil "~S" "RANDOM STATE")
 112    (format nil "~S" (clnl-random:export))
 113    ""
 114    (format nil "~S" "GLOBALS")
 115    "\"min-pxcor\",\"max-pxcor\",\"min-pycor\",\"max-pycor\",\"perspective\",\"subject\",\"nextIndex\",\"directed-links\",\"ticks\","
 116    (format nil "\"-1\",\"1\",\"-1\",\"1\",\"0\",\"nobody\",\"~A\",\"\"\"NEITHER\"\"\",\"-1\"" *current-id*)
 117    ""
 118    (format nil "~S" "TURTLES")
 119    "\"who\",\"color\",\"heading\",\"xcor\",\"ycor\",\"shape\",\"label\",\"label-color\",\"breed\",\"hidden?\",\"size\",\"pen-size\",\"pen-mode\""
 120    (format nil "~{~A~%~}"
 121     (mapcar
 122      (lambda (turtle)
 123       (format nil
 124        "\"~A\",\"~A\",\"~A\",\"~A\",\"~A\",\"\"\"default\"\"\",\"\"\"\"\"\",\"9.9\",\"{all-turtles}\",\"false\",\"1\",\"1\",\"\"\"up\"\"\""
 125        (turtle-who turtle)
 126        (dump-object (turtle-color turtle))
 127        (dump-object (turtle-heading turtle))
 128        (dump-object (turtle-xcor turtle))
 129        (dump-object (turtle-ycor turtle))
 130        ))
 131      *turtles*))
 132    (format nil "~S" "PATCHES")
 133    "\"pxcor\",\"pycor\",\"pcolor\",\"plabel\",\"plabel-color\""
 134    "\"-1\",\"1\",\"0\",\"\"\"\"\"\",\"9.9\""
 135    "\"0\",\"1\",\"0\",\"\"\"\"\"\",\"9.9\""
 136    "\"1\",\"1\",\"0\",\"\"\"\"\"\",\"9.9\""
 137    "\"-1\",\"0\",\"0\",\"\"\"\"\"\",\"9.9\""
 138    "\"0\",\"0\",\"0\",\"\"\"\"\"\",\"9.9\""
 139    "\"1\",\"0\",\"0\",\"\"\"\"\"\",\"9.9\""
 140    "\"-1\",\"-1\",\"0\",\"\"\"\"\"\",\"9.9\""
 141    "\"0\",\"-1\",\"0\",\"\"\"\"\"\",\"9.9\""
 142    "\"1\",\"-1\",\"0\",\"\"\"\"\"\",\"9.9\""
 143    ""
 144    (format nil "~S" "LINKS")
 145    "\"end1\",\"end2\",\"color\",\"label\",\"label-color\",\"hidden?\",\"breed\",\"thickness\",\"shape\",\"tie-mode\""
 146    ""
 147    )))