1 (in-package #:clnl-model)
3 (defvar *separator* "@#$#@#$#@")
19 (defun default-model ()
20 "DEFAULT-MODEL => MODEL
24 MODEL: an object representing the model
28 Returns the default startup model."
32 (make-view :min-pxcor -5 :max-pxcor 5 :min-pycor -5 :max-pycor 5))))
34 (defun read-from-nlogo (str)
35 "READ-FROM-NLOGO STR => MODEL
39 STR: a readable stream
40 MODEL: an object representing the model
44 Takes a stream STR, reads in a nlogo file, parses it, and then
45 returns the model object."
49 ((read-sections (&optional section)
51 ((line (read-line str nil)))
53 (if (string= *separator* line)
54 (cons section (read-sections))
55 (read-sections (append section (list line))))))))
58 :code (format nil "~{~A~^~%~}" (nth 0 sections))
59 :interface (parse-interface (nth 1 sections))
60 :info (nth 2 sections)
61 :turtle-shapes (nth 3 sections)
62 :version (nth 4 sections)
63 :preview-commands (nth 5 sections)
64 :system-dynamics (nth 6 sections)
65 :behavior-space (nth 7 sections)
66 :hub-net-client (nth 8 sections)
67 :link-shapes (nth 9 sections)
68 :model-settings (nth 10 sections)
69 :delta-tick (nth 11 sections))))
73 (defparameter *widget-parsers* nil)
75 (defmacro defwidget-definition (type &rest definitions)
83 (when (find (car def) (list :int :double :inverted-boolean :boolean :choice :string :option)) (second def)))
93 ((line `(nth ,n ,lines)))
95 (:specified `(string= ,(second def) ,line))
96 (:int `(parse-integer ,line :junk-allowed t))
97 (:double `(ignore-errors (coerce (read-from-string ,line) 'double-float)))
98 (:boolean `(or (string= "1" ,line) (string= "0" ,line)))
99 (:inverted-boolean `(or (string= "0" ,line) (string= "1" ,line)))
100 (:choice `(find ,line ',(mapcar #'car (third def)) :test #'string=)))))
102 (loop for i to (length definitions) collect i)))))
104 (,(read-from-string (format nil "make-~A" type))
109 ((line `(nth ,n ,lines))
112 (:int `(parse-integer ,line))
113 (:double `(coerce (read-from-string ,line) 'double-float))
114 (:boolean `(string= "1" ,line))
115 (:inverted-boolean `(string= "0" ,line))
116 (:choice `(cadr (find ,line ',(third def) :key #'car :test #'string=)))
117 (:option `(when (string/= ,line ,(third def)) ,line))
119 (when val-getter (list (intern (symbol-name (cadr def)) :keyword) val-getter))))
121 (loop for i to (length definitions) collect i))))))
124 (defwidget-definition view
125 (:specified "GRAPHICS-WINDOW")
139 (:boolean wrapping-allowed-in-x)
140 (:boolean wrapping-allowed-in-y)
146 (:choice update-mode (("0" :continuous) ("1" :tick-based)))
148 (:boolean show-tick-counter)
149 (:string tick-counter-label)
150 (:double frame-rate 30))
152 (defwidget-definition slider
153 (:specified "SLIDER")
165 (:option units "NIL")
166 (:choice direction (("HORIZONTAL" :horizontal) ("VERTICAL" :vertical))))
168 (defwidget-definition switch
169 (:specified "SWITCH")
176 (:inverted-boolean on)
180 (defun parse-interface (interface-as-strings)
184 ((separate-widgets-as-strings (lines &optional widget-as-strings)
186 (if (string= "" (car lines))
187 (cons widget-as-strings (separate-widgets-as-strings (cdr lines)))
188 (separate-widgets-as-strings (cdr lines) (append widget-as-strings (list (car lines))))))))
189 (separate-widgets-as-strings interface-as-strings))))
193 (lambda (widget-as-strings)
195 ((parser (find-if (lambda (validator) (funcall validator widget-as-strings)) *widget-parsers* :key #'car)))
196 (when parser (funcall (cadr parser) widget-as-strings))))
197 widgets-as-strings))))
199 ;; INFORMATION ABOUT MODEL
201 (defun world-dimensions (model)
202 "WORLD-DIMENSIONS MODEL => DIMS
204 DIMS: (:xmin XMIN :xmax XMAX :ymin YMIN :ymax YMAX)
206 ARGUMENTS AND VALUES:
208 MODEL: A valid model containing a view
209 XMIN: An integer representing the minimum patch coord in X
210 XMAX: An integer representing the maximum patch coord in X
211 YMIN: An integer representing the minimum patch coord in Y
212 YMAX: An integer representing the maximum patch coord in Y
216 Returns the dimensions of MODEL. MODEL must be a valid model
217 as parsed by CLNL, and have a valid view in it."
219 ((view (find-if #'view-p (model-interface model))))
221 :xmin (view-min-pxcor view)
222 :xmax (view-max-pxcor view)
223 :ymin (view-min-pycor view)
224 :ymax (view-max-pycor view))))
226 (defun widget-globals (model)
227 "WIDGET-GLOBALS MODEL => GLOBALS
230 GLOBAL: (NAME DEFAULT)
232 ARGUMENTS AND VALUES:
235 NAME: A symbol interned in the keyworkd package
236 DEFAULT: The widget default value
240 Returns the globals that get declared in the model from widgets.
241 They are interned in the keyword package package set for clnl, so
242 that they can later be used for multiple purposes."
247 (slider (list (intern (string-upcase (slider-varname widget)) :keyword) (slider-default widget)))
248 (switch (list (intern (string-upcase (switch-varname widget)) :keyword) (switch-on widget)))))
249 (model-interface model))))
254 ARGUMENTS AND VALUES:
257 CODE: The string representing the netlogo code in this model
261 Returns the code from the model."