1 (in-package #:clnl-model)
3 (defvar *separator* "@#$#@#$#@")
5 (defvar *current-interface* nil)
6 (defvar *current-callback* nil)
8 ; At this time, this is the only stateful part of the model. If more get added,
9 ; a more general concept can be introduced.
10 (defvar *enabled-forever-buttons* nil)
26 (defun set-callback (callback)
27 "SET-CALLBACK CALLBACK => RESULT
31 CALLBACK: a function that can take netlogo code
36 Sets the means by which the interface can call arbitrary netlogo code."
37 (setf *current-callback* callback))
39 (defun set-current-interface (interface)
40 "SET-CURRENT-INTERFACE INTERFACE => RESULT
44 INTERFACE: a list of widgets for display
49 Sets the currently running model to INTERFACE.
51 The widgets set here are comprised of the bare necessary
52 to run the engine with or without an actual visual component."
53 (setf *current-interface* interface))
55 (defun interface (model)
56 "INTERFACE MODEL => INTERFACE
60 MODEL: an object representing the model
61 INTERFACE: a list of widgets for display
65 INTERFACE returns the widgets in MODEL, used for display, or
66 setting with SET-CURRENT-INTERFACE."
67 (model-interface model))
69 (defun default-model ()
70 "DEFAULT-MODEL => MODEL
74 MODEL: an object representing the model
78 Returns the default startup model."
82 (make-view :left 10 :top 10 :min-pxcor -5 :max-pxcor 5 :min-pycor -5 :max-pycor 5 :patch-size 13d0))))
84 (defun read-from-nlogo (str)
85 "READ-FROM-NLOGO STR => MODEL
89 STR: a readable stream
90 MODEL: an object representing the model
94 Takes a stream STR, reads in a nlogo file, parses it, and then
95 returns the model object."
99 ((read-sections (&optional section)
101 ((line (read-line str nil)))
103 (if (string= *separator* line)
104 (cons section (read-sections))
105 (read-sections (append section (list line))))))))
108 :code (format nil "~{~A~^~%~}" (nth 0 sections))
109 :interface (parse-interface (nth 1 sections))
110 :info (nth 2 sections)
111 :turtle-shapes (nth 3 sections)
112 :version (nth 4 sections)
113 :preview-commands (nth 5 sections)
114 :system-dynamics (nth 6 sections)
115 :behavior-space (nth 7 sections)
116 :hub-net-client (nth 8 sections)
117 :link-shapes (nth 9 sections)
118 :model-settings (nth 10 sections)
119 :delta-tick (nth 11 sections))))
123 (defparameter *widget-parsers* nil)
125 (defmacro defwidget-definition (type &rest definitions)
134 (find (car def) (list :int :double :tnil-boolean :inverted-boolean :boolean :choice :string :option :code))
139 (lambda (,lines) ; Validator
145 ((line `(nth ,n ,lines)))
147 (:specified `(string= ,(second def) ,line))
148 (:int `(parse-integer ,line :junk-allowed t))
149 (:double `(ignore-errors (coerce (read-from-string ,line) 'double-float)))
150 (:boolean `(or (string= "1" ,line) (string= "0" ,line)))
151 (:inverted-boolean `(or (string= "0" ,line) (string= "1" ,line)))
152 (:tnil-boolean `(or (string= "T" ,line) (string= "NIL" ,line)))
153 (:choice `(find ,line ',(mapcar #'car (third def)) :test #'string=)))))
154 definitions (loop for i to (length definitions) collect i)))))
155 (lambda (,lines) ; Parser
156 (,(read-from-string (format nil "make-~A" type))
161 ((line `(nth ,n ,lines))
164 (:int `(parse-integer ,line))
165 (:double `(coerce (read-from-string ,line) 'double-float))
166 (:boolean `(string= "1" ,line))
167 (:inverted-boolean `(string= "0" ,line))
168 (:tnil-boolean `(string/= "NIL" ,line))
169 (:choice `(cadr (find ,line ',(third def) :key #'car :test #'string=)))
170 (:option `(when (string/= ,line ,(third def)) ,line))
171 (:code `(unescape-code ,line))
173 (when val-getter (list (intern (symbol-name (cadr def)) :keyword) val-getter))))
174 definitions (loop for i to (length definitions) collect i))))))
177 (defwidget-definition view
178 (:specified "GRAPHICS-WINDOW")
192 (:boolean wrapping-allowed-in-x)
193 (:boolean wrapping-allowed-in-y)
199 (:choice update-mode (("0" :continuous) ("1" :tick-based)))
201 (:boolean show-tick-counter)
202 (:string tick-counter-label)
203 (:double frame-rate 30))
205 (defwidget-definition slider
206 (:specified "SLIDER")
218 (:option units "NIL")
219 (:choice direction (("HORIZONTAL" :horizontal) ("VERTICAL" :vertical))))
221 (defwidget-definition switch
222 (:specified "SWITCH")
229 (:inverted-boolean on)
233 (defwidget-definition button
234 (:specified "BUTTON")
239 (:option display "NIL")
241 (:tnil-boolean forever)
244 (:string button-type)
249 (:boolean go-time)) ; should it wait for ticks to be initialized
251 (defwidget-definition textbox
252 (:specified "TEXTBOX")
257 (:code display) ; We use code here because the original netlogo treats this display like it does code
260 (:boolean transparent))
262 (defun parse-interface (interface-as-strings)
266 ((separate-widgets-as-strings (lines &optional widget-as-strings)
268 (if (string= "" (car lines))
269 (cons widget-as-strings (separate-widgets-as-strings (cdr lines)))
270 (separate-widgets-as-strings (cdr lines) (append widget-as-strings (list (car lines))))))))
271 (separate-widgets-as-strings interface-as-strings))))
275 (lambda (widget-as-strings)
277 ((parser (find-if (lambda (validator) (funcall validator widget-as-strings)) *widget-parsers* :key #'car)))
278 (when parser (funcall (cadr parser) widget-as-strings))))
279 widgets-as-strings))))
281 (defun find-button (name idx)
285 (lambda (widget) (and (button-p widget) (string= (button-display-name widget) name)))
286 *current-interface*)))
288 ; With authoring, idx here needs to be looked at again.
289 (defun execute-button (name &optional (idx 0))
290 "EXECUTE-BUTTON NAME &optional IDX => RESULT
292 ARGUMENTS AND VALUES:
294 NAME: the name of the button
295 IDX: the instance of the button, defaults to 0
300 Executes the code in the button referenced by NAME and IDX.
302 NAME refers to the display name for the button, which is usually
303 set by the model, but sometimes defaults to the code inside.
305 Because NAME is not guaranteed to be unique, IDX is available
306 as a specifier. The index is in the order that the buttons are
307 loaded, and cannot be guaranteed to be stable from run to run."
308 (when *current-callback*
310 ((button (find-button name (round idx))))
312 ((not button) (error "Couldn't find button with name ~A (idx: ~A)" name idx))
313 ((and (button-forever button) (find button *enabled-forever-buttons* :test #'equal))
314 (setf *enabled-forever-buttons* (remove button *enabled-forever-buttons* :test #'equal)))
315 ((button-forever button)
316 (setf *enabled-forever-buttons* (cons button *enabled-forever-buttons*))
317 (sb-thread:make-thread
320 :while (find button *enabled-forever-buttons* :test #'equal)
321 ; The sleep is necessary so that it gives other threads time
324 ((result (funcall *current-callback* (button-code button))))
325 (when (eql :stop result)
326 (setf *enabled-forever-buttons* (remove button *enabled-forever-buttons* :test #'equal)))
328 :name (format nil "Forever button: ~A" (button-display button))))
329 (t (funcall *current-callback* (button-code button)))))))
331 (defun forever-button-on (name &optional (idx 0))
332 "FOREVER-BUTTON-ON NAME &optional IDX => ON
334 ARGUMENTS AND VALUES:
336 NAME: the name of the button
337 IDX: the instance of the button, defaults to 0
342 Returns whether the button identified by NAME and IDX is currently on.
344 NAME refers to the display name for the button, which is usually
345 set by the model, but sometimes defaults to the code inside.
347 Because NAME is not guaranteed to be unique, IDX is available
348 as a specifier. The index is in the order that the buttons are
349 loaded, and cannot be guaranteed to be stable from run to run."
350 (and (find (find-button name (round idx)) *enabled-forever-buttons* :test #'equal) t))
352 ;; INFORMATION ABOUT MODEL
354 (defun world-dimensions (model)
355 "WORLD-DIMENSIONS MODEL => DIMS
357 DIMS: (:xmin XMIN :xmax XMAX :ymin YMIN :ymax YMAX)
359 ARGUMENTS AND VALUES:
361 MODEL: A valid model containing a view
362 XMIN: An integer representing the minimum patch coord in X
363 XMAX: An integer representing the maximum patch coord in X
364 YMIN: An integer representing the minimum patch coord in Y
365 YMAX: An integer representing the maximum patch coord in Y
369 Returns the dimensions of MODEL. MODEL must be a valid model
370 as parsed by CLNL, and have a valid view in it."
372 ((view (find-if #'view-p (model-interface model))))
374 :xmin (view-min-pxcor view)
375 :xmax (view-max-pxcor view)
376 :ymin (view-min-pycor view)
377 :ymax (view-max-pycor view)
378 :patch-size (view-patch-size view))))
380 (defun widget-globals (model)
381 "WIDGET-GLOBALS MODEL => GLOBALS
384 GLOBAL: (NAME DEFAULT)
386 ARGUMENTS AND VALUES:
389 NAME: A symbol interned in the keyworkd package
390 DEFAULT: The widget default value
394 Returns the globals that get declared in the model from widgets.
395 They are interned in the keyword package package set for clnl, so
396 that they can later be used for multiple purposes."
401 (slider (list (intern (string-upcase (slider-varname widget)) :keyword) (slider-default widget)))
402 (switch (list (intern (string-upcase (switch-varname widget)) :keyword) (switch-on widget)))))
403 (model-interface model))))
405 (defun buttons (model)
406 "BUTTONS MODEL => BUTTON-DEFS
408 BUTTON-DEFS: BUTTON-DEF*
409 BUTTON-DEF: (:left LEFT :top TOP :height HEIGHT :width WIDTH :forever FOREVER :display DISPLAY)
411 ARGUMENTS AND VALUES:
414 LEFT: An integer representing the left position
415 TOP: An integer representing the top position
416 HEIGHT: An integer representing height
417 WIDTH: An integer representing width
418 FOREVER: A boolean representing whether this button is a forever button
419 DISPLAY: A string representing display name
423 Returns button definitions that get declared in the buttons of the
424 MODEL. This is used to initialize the interface."
431 :left (button-left widget)
432 :top (button-top widget)
433 :width (- (button-right widget) (button-left widget))
434 :height (- (button-bottom widget) (button-top widget))
435 :forever (button-forever widget)
436 :display (button-display-name widget)))))
437 (model-interface model))))
439 (defun textboxes (model)
440 "TEXTBOXES MODEL => TEXTBOX-DEFS
442 TEXTBOX-DEFS: TEXTBOX-DEF*
443 TEXTBOX-DEF: (:left LEFT :top TOP :height HEIGHT :width WIDTH :display DISPLAY)
445 ARGUMENTS AND VALUES:
448 LEFT: An integer representing the left position
449 TOP: An integer representing the top position
450 HEIGHT: An integer representing height, in characters
451 WIDTH: An integer representing width, in characters
452 DISPLAY: A string representing display name
456 Returns textbox definitions that get declared in the textboxes of the
457 MODEL. This is used to initialize the interface."
464 :left (textbox-left widget)
465 :top (textbox-top widget)
466 :width (truncate (- (textbox-right widget) (textbox-left widget)) clnl-gltk:*font-width*)
467 :height (truncate (- (textbox-bottom widget) (textbox-top widget)) clnl-gltk:*font-height*)
468 :display (textbox-display widget)))))
469 (model-interface model))))
471 (defun switches (model)
472 "SWITCHES MODEL => SWITCH-DEFS
474 SWITCH-DEFS: SWITCH-DEF*
475 SWITCH-DEF: (:left LEFT :top TOP :width WIDTH :var VAR :display DISPLAY :initial-value INITIAL-VALUE)
477 ARGUMENTS AND VALUES:
480 LEFT: An integer representing the left position
481 TOP: An integer representing the top position
482 WIDTH: An integer representing width
483 VAR: A symbole representing variable
484 DISPLAY: A string representing variable name
485 INITIAL-VALUE: The initial value
489 Returns switch definitions that get declared in the switches of the
490 MODEL. This is used to initialize the interface."
497 :left (switch-left widget)
498 :top (switch-top widget)
499 :width (- (switch-right widget) (switch-left widget))
500 :var (intern (string-upcase (switch-varname widget)) :keyword)
501 :display (switch-varname widget)
502 :initial-value (switch-on widget) ))))
503 (model-interface model))))
505 (defun sliders (model)
512 :left (slider-left widget)
513 :top (slider-top widget)
514 :width (- (slider-right widget) (slider-left widget))
515 :var (intern (string-upcase (slider-varname widget)) :keyword)
516 :display (slider-varname widget)
517 :min (slider-min widget)
518 :max (slider-max widget)
519 :step (slider-step widget)
520 :initial-value (slider-default widget)))))
521 (model-interface model))))
524 "VIEW MODEL => VIEW-DEF
526 VIEW-DEF: (:left LEFT :top TOP)
528 ARGUMENTS AND VALUES:
531 LEFT: An integer representing the left position
532 TOP: An integer representing the top position
536 Returns the view definition that get declared in the view of the
537 MODEL. This is used to initialize the interface."
539 ((view (find-if #'view-p (model-interface model))))
540 (list :left (view-left view) :top (view-top view))))
545 ARGUMENTS AND VALUES:
548 CODE: The string representing the netlogo code in this model
552 Returns the code from the model."
555 ; This should get cached eventually, though maybe just cached via a display list is good enough
556 (defun button-display-name (button)
558 (button-display button)
559 (cl-ppcre:regex-replace-all "\\s+" (button-code button) " ")))
561 (defun unescape-code (code)
562 (with-output-to-string (out)
563 (with-input-from-string (in code)
565 :for c := (read-char in nil)
567 :for aux := (when (eql #\\ c)
574 (t (error "Invalid escape sequence"))))
575 :do (write-char (or aux c) out)))))