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

   1 (in-package #:cl-nl.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  (format t "Showing: ~A~%" (dump-object n)))
  14
  15 (defun create-turtle ()
  16  (setf
  17   *turtles*
  18   (nconc
  19    *turtles*
  20    (list
  21     (make-turtle :who *current-id*
  22                  :color (coerce (+ 5 (* 10 (cl-nl.random:next-int 14))) 'double-float)
  23                  :heading (coerce (cl-nl.random:next-int 360) 'double-float)
  24                  :xcor 0d0
  25                  :ycor 0d0))))
  26  (incf *current-id*))
  27
  28 (defun turtles () *turtles*)
  29
  30 (defun ask (agent-set fn)
  31  (let
  32   ((iter (shufflerator agent-set)))
  33   (loop for agent = (funcall iter)
  34         while agent
  35         do (let ((*myself* *self*) (*self* agent)) (funcall fn)))))
  36
  37 (defun shufflerator (agent-set)
  38  (let
  39   ((copy (copy-list agent-set))
  40    (i 0)
  41    (agent nil))
  42   (flet
  43    ((fetch ()
  44      (let
  45       ((idx (when (< i (1- (length copy))) (+ i (cl-nl.random:next-int (- (length copy) i))))))
  46       (when idx (setf agent (nth idx copy)))
  47       (when idx (setf (nth idx copy) (nth i copy)))
  48       (incf i))))
  49    (fetch) ; we pre-fetch because netlogo does, rng sync hype!
  50    (lambda ()
  51     (cond
  52      ((> i (length copy)) nil)
  53      ((= i (length copy)) (incf i) (car (last copy)))
  54      (t (let ((result agent)) (fetch) result)))))))
  55
  56 (defun random-float (n)
  57  (cl-nl.random:next-double n))
  58
  59 (defun fd (n)
  60  (when (not (turtle-p *self*)) (error "Gotta call fd in turtle scope, dude (~A)" *self*))
  61  (setf (turtle-xcor *self*) (+ (turtle-xcor *self*) (* n (sin (* pi (/ (turtle-heading *self*) 180))))))
  62  (setf (turtle-ycor *self*) (+ (turtle-ycor *self*) (* n (cos (* pi (/ (turtle-heading *self*) 180)))))))
  63
  64 (defun create-turtles (n)
  65  (loop for i from 1 to n do (create-turtle)))
  66
  67 (defun create-world ()
  68  (setf *turtles* nil)
  69  (setf *current-id* 0))
  70
  71 ; These match netlogo's dump
  72 (defgeneric dump-object (o))
  73 (defmethod dump-object ((n double-float))
  74  (multiple-value-bind (int rem) (floor n)
  75   (if (eql 0d0 rem)
  76       (format nil "~A" int)
  77       (let
  78        ((output (format nil "~D" n)))
  79        (cl-ppcre:regex-replace "d-" (cl-ppcre:regex-replace "d0" output "") "E-"))))) ; Someday we'll have d<posint>, but this is not that day!
  80 (defmethod dump-object ((o string)) o)
  81
  82 (defun export-world ()
  83  (format nil "~{~A~%~}"
  84   (list
  85    (format nil "~S" "RANDOM STATE")
  86    (format nil "~S" (cl-nl.random:export))
  87    ""
  88    (format nil "~S" "GLOBALS")
  89    "\"min-pxcor\",\"max-pxcor\",\"min-pycor\",\"max-pycor\",\"perspective\",\"subject\",\"nextIndex\",\"directed-links\",\"ticks\","
  90    (format nil "\"-1\",\"1\",\"-1\",\"1\",\"0\",\"nobody\",\"~A\",\"\"\"NEITHER\"\"\",\"-1\"" *current-id*)
  91    ""
  92    (format nil "~S" "TURTLES")
  93    "\"who\",\"color\",\"heading\",\"xcor\",\"ycor\",\"shape\",\"label\",\"label-color\",\"breed\",\"hidden?\",\"size\",\"pen-size\",\"pen-mode\""
  94    (format nil "~{~A~%~}"
  95     (mapcar
  96      (lambda (turtle)
  97       (format nil
  98        "\"~A\",\"~A\",\"~A\",\"~A\",\"~A\",\"\"\"default\"\"\",\"\"\"\"\"\",\"9.9\",\"{all-turtles}\",\"false\",\"1\",\"1\",\"\"\"up\"\"\""
  99        (turtle-who turtle)
 100        (dump-object (turtle-color turtle))
 101        (dump-object (turtle-heading turtle))
 102        (dump-object (turtle-xcor turtle))
 103        (dump-object (turtle-ycor turtle))
 104        ))
 105      *turtles*))
 106    (format nil "~S" "PATCHES")
 107    "\"pxcor\",\"pycor\",\"pcolor\",\"plabel\",\"plabel-color\""
 108    "\"-1\",\"1\",\"0\",\"\"\"\"\"\",\"9.9\""
 109    "\"0\",\"1\",\"0\",\"\"\"\"\"\",\"9.9\""
 110    "\"1\",\"1\",\"0\",\"\"\"\"\"\",\"9.9\""
 111    "\"-1\",\"0\",\"0\",\"\"\"\"\"\",\"9.9\""
 112    "\"0\",\"0\",\"0\",\"\"\"\"\"\",\"9.9\""
 113    "\"1\",\"0\",\"0\",\"\"\"\"\"\",\"9.9\""
 114    "\"-1\",\"-1\",\"0\",\"\"\"\"\"\",\"9.9\""
 115    "\"0\",\"-1\",\"0\",\"\"\"\"\"\",\"9.9\""
 116    "\"1\",\"-1\",\"0\",\"\"\"\"\"\",\"9.9\""
 117    ""
 118    (format nil "~S" "LINKS")
 119    "\"end1\",\"end2\",\"color\",\"label\",\"label-color\",\"hidden?\",\"breed\",\"thickness\",\"shape\",\"tie-mode\""
 120    ""
 121    )))