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