(defvar *separator* "@#$#@#$#@")
+(defvar *current-interface* nil)
+(defvar *current-callback* nil)
+
+; At this time, this is the only stateful part of the model. If more get added,
+; a more general concept can be introduced.
+(defvar *enabled-forever-buttons* nil)
+
(defstruct model
code
interface
model-settings
delta-tick)
+(defun set-callback (callback)
+ "SET-CALLBACK CALLBACK => RESULT
+
+ARGUMENTS AND VALUES:
+
+ CALLBACK: a function that can take netlogo code
+ RESULT: undefined
+
+DESCRIPTION:
+
+ Sets the means by which the interface can call arbitrary netlogo code."
+ (setf *current-callback* callback))
+
+(defun set-current-interface (interface)
+ "SET-CURRENT-INTERFACE INTERFACE => RESULT
+
+ARGUMENTS AND VALUES:
+
+ INTERFACE: a list of widgets for display
+ RESULT: undefined
+
+DESCRIPTION:
+
+ Sets the currently running model to INTERFACE.
+
+ The widgets set here are comprised of the bare necessary
+ to run the engine with or without an actual visual component."
+ (setf *current-interface* interface))
+
+(defun interface (model)
+ "INTERFACE MODEL => INTERFACE
+
+ARGUMENTS AND VALUES:
+
+ MODEL: an object representing the model
+ INTERFACE: a list of widgets for display
+
+DESCRIPTION:
+
+ INTERFACE returns the widgets in MODEL, used for display, or
+ setting with SET-CURRENT-INTERFACE."
+ (model-interface model))
+
(defun default-model ()
"DEFAULT-MODEL => MODEL
Returns the default startup model."
(make-model
+ :code ""
:interface (list
- (make-view :min-pxcor -5 :max-pxcor 5 :min-pycor -5 :max-pycor 5))))
+ (make-view :left 10 :top 10 :min-pxcor -5 :max-pxcor 5 :min-pycor -5 :max-pycor 5 :patch-size 13d0))))
(defun read-from-nlogo (str)
"READ-FROM-NLOGO STR => MODEL
(read-sections (append section (list line))))))))
(read-sections))))
(make-model
- :code (clnl-code-parser:parse (clnl-lexer:lex (format nil "~{~A~^~%~}" (nth 0 sections))))
+ :code (format nil "~{~A~^~%~}" (nth 0 sections))
:interface (parse-interface (nth 1 sections))
:info (nth 2 sections)
:turtle-shapes (nth 3 sections)
,@(remove nil
(mapcar
(lambda (def)
- (when (find (car def) (list :int :double :inverted-boolean :boolean :choice :string :option)) (second def)))
+ (when
+ (find (car def) (list :int :double :tnil-boolean :inverted-boolean :boolean :choice :string :option :code))
+ (second def)))
definitions)))
(push
(list
- (lambda (,lines)
+ (lambda (,lines) ; Validator
(and
,@(remove nil
(mapcar
(:double `(ignore-errors (coerce (read-from-string ,line) 'double-float)))
(:boolean `(or (string= "1" ,line) (string= "0" ,line)))
(:inverted-boolean `(or (string= "0" ,line) (string= "1" ,line)))
+ (:tnil-boolean `(or (string= "T" ,line) (string= "NIL" ,line)))
(:choice `(find ,line ',(mapcar #'car (third def)) :test #'string=)))))
- definitions
- (loop for i to (length definitions) collect i)))))
- (lambda (,lines)
+ definitions (loop for i to (length definitions) collect i)))))
+ (lambda (,lines) ; Parser
(,(read-from-string (format nil "make-~A" type))
,@(apply #'append
(mapcar
(:double `(coerce (read-from-string ,line) 'double-float))
(:boolean `(string= "1" ,line))
(:inverted-boolean `(string= "0" ,line))
+ (:tnil-boolean `(string/= "NIL" ,line))
(:choice `(cadr (find ,line ',(third def) :key #'car :test #'string=)))
(:option `(when (string/= ,line ,(third def)) ,line))
+ (:code `(unescape-code ,line))
(:string line))))
(when val-getter (list (intern (symbol-name (cadr def)) :keyword) val-getter))))
- definitions
- (loop for i to (length definitions) collect i))))))
+ definitions (loop for i to (length definitions) collect i))))))
*widget-parsers*))))
(defwidget-definition view
(:reserved)
(:reserved))
+(defwidget-definition button
+ (:specified "BUTTON")
+ (:int left)
+ (:int top)
+ (:int right)
+ (:int bottom)
+ (:option display "NIL")
+ (:code code)
+ (:tnil-boolean forever)
+ (:reserved)
+ (:reserved)
+ (:string button-type)
+ (:reserved)
+ (:string action-key)
+ (:reserved)
+ (:reserved)
+ (:boolean go-time)) ; should it wait for ticks to be initialized
+
+(defwidget-definition textbox
+ (:specified "TEXTBOX")
+ (:int left)
+ (:int top)
+ (:int right)
+ (:int bottom)
+ (:code display) ; We use code here because the original netlogo treats this display like it does code
+ (:int font-size)
+ (:double color)
+ (:boolean transparent))
+
(defun parse-interface (interface-as-strings)
(let
((widgets-as-strings
(when parser (funcall (cadr parser) widget-as-strings))))
widgets-as-strings))))
+(defun find-button (name idx)
+ (nth
+ idx
+ (remove-if-not
+ (lambda (widget) (and (button-p widget) (string= (button-display-name widget) name)))
+ *current-interface*)))
+
+; With authoring, idx here needs to be looked at again.
+(defun execute-button (name &optional (idx 0))
+ "EXECUTE-BUTTON NAME &optional IDX => RESULT
+
+ARGUMENTS AND VALUES:
+
+ NAME: the name of the button
+ IDX: the instance of the button, defaults to 0
+ RESULT: undefined
+
+DESCRIPTION:
+
+ Executes the code in the button referenced by NAME and IDX.
+
+ NAME refers to the display name for the button, which is usually
+ set by the model, but sometimes defaults to the code inside.
+
+ Because NAME is not guaranteed to be unique, IDX is available
+ as a specifier. The index is in the order that the buttons are
+ loaded, and cannot be guaranteed to be stable from run to run."
+ (when *current-callback*
+ (let
+ ((button (find-button name (round idx))))
+ (cond
+ ((not button) (error "Couldn't find button with name ~A (idx: ~A)" name idx))
+ ((and (button-forever button) (find button *enabled-forever-buttons* :test #'equal))
+ (setf *enabled-forever-buttons* (remove button *enabled-forever-buttons* :test #'equal)))
+ ((button-forever button)
+ (setf *enabled-forever-buttons* (cons button *enabled-forever-buttons*))
+ (sb-thread:make-thread
+ (lambda ()
+ (loop
+ :while (find button *enabled-forever-buttons* :test #'equal)
+ ; The sleep is necessary so that it gives other threads time
+ :do
+ (let
+ ((result (funcall *current-callback* (button-code button))))
+ (when (eql :stop result)
+ (setf *enabled-forever-buttons* (remove button *enabled-forever-buttons* :test #'equal)))
+ (sleep .001))))
+ :name (format nil "Forever button: ~A" (button-display button))))
+ (t (funcall *current-callback* (button-code button)))))))
+
+(defun forever-button-on (name &optional (idx 0))
+ "FOREVER-BUTTON-ON NAME &optional IDX => ON
+
+ARGUMENTS AND VALUES:
+
+ NAME: the name of the button
+ IDX: the instance of the button, defaults to 0
+ ON: a boolean
+
+DESCRIPTION:
+
+ Returns whether the button identified by NAME and IDX is currently on.
+
+ NAME refers to the display name for the button, which is usually
+ set by the model, but sometimes defaults to the code inside.
+
+ Because NAME is not guaranteed to be unique, IDX is available
+ as a specifier. The index is in the order that the buttons are
+ loaded, and cannot be guaranteed to be stable from run to run."
+ (and (find (find-button name (round idx)) *enabled-forever-buttons* :test #'equal) t))
+
;; INFORMATION ABOUT MODEL
(defun world-dimensions (model)
:xmin (view-min-pxcor view)
:xmax (view-max-pxcor view)
:ymin (view-min-pycor view)
- :ymax (view-max-pycor view))))
+ :ymax (view-max-pycor view)
+ :patch-size (view-patch-size view))))
-; For now, we keep the code hidden in this package
-(defun globals (model)
- "GLOBALS MODEL => GLOBALS
+(defun widget-globals (model)
+ "WIDGET-GLOBALS MODEL => GLOBALS
GLOBALS: GLOBAL*
+ GLOBAL: (NAME DEFAULT)
+
+ARGUMENTS AND VALUES:
+
+ MODEL: A valid model
+ NAME: A symbol interned in the keyworkd package
+ DEFAULT: The widget default value
+
+DESCRIPTION:
+
+ Returns the globals that get declared in the model from widgets.
+ They are interned in the keyword package package set for clnl, so
+ that they can later be used for multiple purposes."
+ (remove nil
+ (mapcar
+ (lambda (widget)
+ (typecase widget
+ (slider (list (intern (string-upcase (slider-varname widget)) :keyword) (slider-default widget)))
+ (switch (list (intern (string-upcase (switch-varname widget)) :keyword) (switch-on widget)))))
+ (model-interface model))))
+
+(defun buttons (model)
+ "BUTTONS MODEL => BUTTON-DEFS
+
+ BUTTON-DEFS: BUTTON-DEF*
+ BUTTON-DEF: (:left LEFT :top TOP :height HEIGHT :width WIDTH :forever FOREVER :display DISPLAY)
+
+ARGUMENTS AND VALUES:
+
+ MODEL: A valid model
+ LEFT: An integer representing the left position
+ TOP: An integer representing the top position
+ HEIGHT: An integer representing height
+ WIDTH: An integer representing width
+ FOREVER: A boolean representing whether this button is a forever button
+ DISPLAY: A string representing display name
+
+DESCRIPTION:
+
+ Returns button definitions that get declared in the buttons of the
+ MODEL. This is used to initialize the interface."
+ (remove nil
+ (mapcar
+ (lambda (widget)
+ (typecase widget
+ (button
+ (list
+ :left (button-left widget)
+ :top (button-top widget)
+ :width (- (button-right widget) (button-left widget))
+ :height (- (button-bottom widget) (button-top widget))
+ :forever (button-forever widget)
+ :display (button-display-name widget)))))
+ (model-interface model))))
+
+(defun textboxes (model)
+ "TEXTBOXES MODEL => TEXTBOX-DEFS
+
+ TEXTBOX-DEFS: TEXTBOX-DEF*
+ TEXTBOX-DEF: (:left LEFT :top TOP :height HEIGHT :width WIDTH :display DISPLAY)
+
+ARGUMENTS AND VALUES:
+
+ MODEL: A valid model
+ LEFT: An integer representing the left position
+ TOP: An integer representing the top position
+ HEIGHT: An integer representing height, in characters
+ WIDTH: An integer representing width, in characters
+ DISPLAY: A string representing display name
+
+DESCRIPTION:
+
+ Returns textbox definitions that get declared in the textboxes of the
+ MODEL. This is used to initialize the interface."
+ (remove nil
+ (mapcar
+ (lambda (widget)
+ (typecase widget
+ (textbox
+ (list
+ :left (textbox-left widget)
+ :top (textbox-top widget)
+ :width (truncate (- (textbox-right widget) (textbox-left widget)) clnl-gltk:*font-width*)
+ :height (truncate (- (textbox-bottom widget) (textbox-top widget)) clnl-gltk:*font-height*)
+ :display (textbox-display widget)))))
+ (model-interface model))))
+
+(defun switches (model)
+ "SWITCHES MODEL => SWITCH-DEFS
+
+ SWITCH-DEFS: SWITCH-DEF*
+ SWITCH-DEF: (:left LEFT :top TOP :width WIDTH :var VAR :display DISPLAY :initial-value INITIAL-VALUE)
+
+ARGUMENTS AND VALUES:
+
+ MODEL: A valid model
+ LEFT: An integer representing the left position
+ TOP: An integer representing the top position
+ WIDTH: An integer representing width
+ VAR: A symbole representing variable
+ DISPLAY: A string representing variable name
+ INITIAL-VALUE: The initial value
+
+DESCRIPTION:
+
+ Returns switch definitions that get declared in the switches of the
+ MODEL. This is used to initialize the interface."
+ (remove nil
+ (mapcar
+ (lambda (widget)
+ (typecase widget
+ (switch
+ (list
+ :left (switch-left widget)
+ :top (switch-top widget)
+ :width (- (switch-right widget) (switch-left widget))
+ :var (intern (string-upcase (switch-varname widget)) :keyword)
+ :display (switch-varname widget)
+ :initial-value (switch-on widget) ))))
+ (model-interface model))))
+
+(defun sliders (model)
+ (remove nil
+ (mapcar
+ (lambda (widget)
+ (typecase widget
+ (slider
+ (list
+ :left (slider-left widget)
+ :top (slider-top widget)
+ :width (- (slider-right widget) (slider-left widget))
+ :var (intern (string-upcase (slider-varname widget)) :keyword)
+ :display (slider-varname widget)
+ :min (slider-min widget)
+ :max (slider-max widget)
+ :step (slider-step widget)
+ :initial-value (slider-default widget)))))
+ (model-interface model))))
+
+(defun view (model)
+ "VIEW MODEL => VIEW-DEF
+
+ VIEW-DEF: (:left LEFT :top TOP)
+
+ARGUMENTS AND VALUES:
+
+ MODEL: A valid model
+ LEFT: An integer representing the left position
+ TOP: An integer representing the top position
+
+DESCRIPTION:
+
+ Returns the view definition that get declared in the view of the
+ MODEL. This is used to initialize the interface."
+ (let
+ ((view (find-if #'view-p (model-interface model))))
+ (list :left (view-left view) :top (view-top view))))
+
+(defun code (model)
+ "CODE MODEL => CODE
ARGUMENTS AND VALUES:
MODEL: A valid model
- GLOBAL: A symbol interned in clnl:*model-package*
+ CODE: The string representing the netlogo code in this model
DESCRIPTION:
- Returns the globals that get declared in the model, from widgets or
- from code. They are interned in the package set for clnl, so
- that they can later be used by functions in that package."
- (mapcar
- (lambda (pair)
- (list
- (intern (string-upcase (car pair)) clnl:*model-package*)
- (cadr pair)))
- (append
- (clnl-code-parser:globals (model-code model))
- (remove nil
- (mapcar
- (lambda (widget)
- (typecase widget
- (slider (list (slider-varname widget) (slider-default widget)))
- (switch (list (switch-varname widget) (switch-on widget)))))
- (model-interface model))))))
+ Returns the code from the model."
+ (model-code model))
+
+; This should get cached eventually, though maybe just cached via a display list is good enough
+(defun button-display-name (button)
+ (or
+ (button-display button)
+ (cl-ppcre:regex-replace-all "\\s+" (button-code button) " ")))
+
+(defun unescape-code (code)
+ (with-output-to-string (out)
+ (with-input-from-string (in code)
+ (loop
+ :for c := (read-char in nil)
+ :while c
+ :for aux := (when (eql #\\ c)
+ (case (read-char in)
+ (#\n #\Newline)
+ (#\r #\Return)
+ (#\t #\Tab)
+ (#\\ #\\)
+ (#\" #\")
+ (t (error "Invalid escape sequence"))))
+ :do (write-char (or aux c) out)))))
projects / clnl / blobdiff