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

   1 ; Copyright 2022 Frank Duncan (frank@consxy.com) under AGPL3.  See distributed LICENSE.txt.
   2 (in-package #:clnl-nvm)
   3
   4 (defun lookup-color (color)
   5  "LOOKUP-COLOR COLOR => COLOR-NUMBER
   6
   7 ARGUMENTS AND VALUES:
   8
   9   COLOR: a symbol representing a color
  10   COLOR-NUMBER: the NetLogo color integer
  11
  12 DESCRIPTION:
  13
  14   Returns the number used to represent colors in NetLogo.
  15
  16   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#Constants"
  17  (case color
  18   (:black 0d0)
  19   (:gray 5d0)
  20   (:white 9.9d0)
  21   (:red 15d0)
  22   (:orange 25d0)
  23   (:brown 35d0)
  24   (:yellow 45d0)
  25   (:green 55d0)
  26   (:lime 65d0)
  27   (:turquoise 75d0)
  28   (:cyan 85d0)
  29   (:sky 95d0)
  30   (:blue 105d0)
  31   (:violet 115d0)
  32   (:magenta 125d0)
  33   (:pink 135d0)))
  34
  35 (defun create-turtle (breed &optional base-turtle)
  36  (let*
  37   ((breed (or breed (and base-turtle (turtle-breed base-turtle)) :turtles))
  38    (new-turtle (make-turtle
  39                 :who (coerce *current-id* 'double-float)
  40                 :color (if base-turtle
  41                         (turtle-color base-turtle)
  42                         (coerce (+ 5 (* 10 (clnl-random:next-int 14))) 'double-float))
  43                 :heading (if base-turtle
  44                           (turtle-heading base-turtle)
  45                           (coerce (clnl-random:next-int 360) 'double-float))
  46                 :label-color (if base-turtle (turtle-label-color base-turtle) 9.9d0)
  47                 :size (if base-turtle (turtle-size base-turtle) 1d0)
  48                 :breed breed
  49                 :shape (breed-default-shape breed)
  50                 :xcor (if base-turtle (turtle-xcor base-turtle) 0d0)
  51                 :ycor (if base-turtle (turtle-ycor base-turtle) 0d0)
  52                 :own-vars (when base-turtle (copy-list (turtle-own-vars base-turtle))))))
  53   (let
  54    ((patch (patch-at (turtle-xcor new-turtle) (turtle-ycor new-turtle))))
  55    (setf (patch-turtles patch) (nconc (patch-turtles patch) (list new-turtle))))
  56   (setf *turtles* (nconc *turtles* (list new-turtle)))
  57   (incf *current-id*)
  58   new-turtle))
  59
  60 (defun shufflerator (agentset-list)
  61  (let
  62   ((copy (copy-list agentset-list))
  63    (i 0)
  64    (agent nil))
  65   (labels
  66    ((fetch ()
  67      (let
  68       ((idx (when (< i (1- (length copy))) (+ i (clnl-random:next-int (- (length copy) i))))))
  69       (when idx (setf agent (nth idx copy)))
  70       (when idx (setf (nth idx copy) (nth i copy)))
  71       (incf i)
  72       (when (and (<= i (length copy)) (turtle-p agent) (= -1 (turtle-who agent))) (fetch)))))
  73    (fetch) ; we pre-fetch because netlogo does, rng sync hype!
  74    (lambda ()
  75     (cond
  76      ((> i (length copy)) nil)
  77      ((= i (length copy)) (incf i) (car (last copy)))
  78      (t (let ((result agent)) (fetch) result)))))))
  79
  80 (defcommand create-world (&key dims globals turtles-own-vars patches-own-vars breeds)
  81  "CREATE-WORLD &key DIMS GLOBALS TURTLES-OWN-VARS PATCHES-OWN-VARS BREEDS => RESULT
  82
  83   DIMS: (:xmin XMIN :xmax XMAX :ymin YMIN :ymax YMAX)
  84   GLOBALS: GLOBAL*
  85   TURTLES-OWN-VARS: TURTLES-OWN-VAR*
  86   PATCHES-OWN-VARS: PATCHES-OWN-VAR*
  87   BREEDS: BREED*
  88   RESULT: :undefined
  89   GLOBAL: (GLOBAL-NAME GLOBAL-ACCESS-FUNC)
  90
  91 ARGUMENTS AND VALUES:
  92
  93   XMIN: An integer representing the minimum patch coord in X
  94   XMAX: An integer representing the maximum patch coord in X
  95   YMIN: An integer representing the minimum patch coord in Y
  96   YMAX: An integer representing the maximum patch coord in Y
  97   TURTLES-OWN-VAR: Symbol for the turtles own variable in the keyword package
  98   PATCHES-OWN-VAR: Symbol for the patches own variable in the keyword package
  99   BREED: A list of symbols representing the possible preeds
 100   GLOBAL-NAME: Symbol for the global in the keyword package
 101   GLOBAL-ACCESS-FUNC: Function to get the value of the global
 102
 103 DESCRIPTION:
 104
 105   Initializes the world in the NVM.
 106
 107   This should be called before using the engine in any real capacity.  If
 108   called when an engine is already running, it may do somethign weird."
 109  (setf *turtles-own-vars* turtles-own-vars)
 110  (setf *patches-own-vars* patches-own-vars)
 111  (setf *dimensions* dims)
 112  (setf *globals* globals)
 113  (setf *breeds*
 114   (append
 115    (list (list :turtles "default"))
 116    (mapcar (lambda (breed) (list breed "default")) breeds)))
 117  (clear-ticks)
 118  (clear-patches)
 119  (clear-turtles))
 120
 121 (defun current-state ()
 122  "CURRENT-STATE => WORLD-STATE
 123
 124 ARGUMENTS AND VALUES:
 125
 126   WORLD-STATE: A list, the current state of the whole world
 127
 128 DESCRIPTION:
 129
 130   Dumps out the state of the world.
 131
 132   This is useful for visualizations and also storing in a common lisp
 133   data structure for easy usage in a common lisp instance.  It's preferable
 134   to use this when working with the nvm than the output done by export-world.
 135
 136   Currently this only dumps out turtle and patch information.
 137
 138   This is called CURRENT-STATE because export-world is an actual primitive
 139   used by NetLogo."
 140  (list
 141   (mapcar
 142    (lambda (turtle)
 143     (list
 144      :color (turtle-color turtle)
 145      :xcor (turtle-xcor turtle)
 146      :ycor (turtle-ycor turtle)
 147      :heading (turtle-heading turtle)
 148      :shape (turtle-shape turtle)
 149      :size (turtle-size turtle)))
 150    *turtles*)
 151   (mapcar
 152    (lambda (patch)
 153     (list
 154      :color (patch-color patch)
 155      :xcor (patch-xcor patch)
 156      :ycor (patch-ycor patch)))
 157    *patches*)
 158   (mapcar
 159    (lambda (global)
 160     (list
 161      :name (car global)
 162      :value (funcall (cadr global))))
 163    *globals*)))
 164
 165 ; These match netlogo's dump
 166 (defgeneric dump-object (o))
 167
 168 (defmethod dump-object ((n double-float))
 169  (multiple-value-bind (int rem) (floor n)
 170   (if (eql 0d0 rem)
 171    (format nil "~A" int)
 172    (let
 173     ((output (format nil "~D" n)))
 174     ; Someday we'll have d<posint>, but this is not that day!
 175     (cl-ppcre:regex-replace "d-" (cl-ppcre:regex-replace "d0" output "") "E-")))))
 176
 177 (defmethod dump-object ((o string)) (format nil "~A" (cl-ppcre:regex-replace-all "\"" (format nil "~S" o) "\"\"")))
 178
 179 (defmethod dump-object ((o (eql t))) "true")
 180 (defmethod dump-object ((o (eql nil))) "false")
 181
 182 (defmethod dump-object ((o list))
 183  (cond
 184   ((agentset-p o) (format nil "(agentset, ~A ~A)" (dump-object (count o)) (string-downcase (agentset-breed o))))
 185   (t (format nil "[~{~A~^ ~}]" (mapcar #'dump-object o)))))
 186
 187 (defmethod dump-object ((o patch))
 188  (format nil "(patch ~A ~A)" (dump-object (patch-xcor o)) (dump-object (patch-ycor o))))
 189
 190 (defmethod dump-object ((o turtle)) (format nil "(turtle ~A)" (dump-object (turtle-who o))))
 191 (defmethod dump-object ((o (eql :nobody))) (format nil "nobody"))
 192 (defmethod dump-object ((o (eql :turtles))) (format nil "{all-turtles}"))
 193 (defmethod dump-object ((o symbol))
 194  (cond
 195   ((find o *breeds* :key #'car) (format nil "{breed ~(~A~)}" o))
 196   (t (error "Keyword unrecognized by dump object: ~A" o))))