X-Git-Url: https://code.consxy.com/gitweb/gitweb.cgi?p=clnl;a=blobdiff_plain;f=src%2Fmain%2Fmodel.lisp;h=3942110d860b4c13e15bb45fc2b66007f013a61d;hp=5d7e9e3eb49b9bf04de7cae19ac65d88559f7114;hb=89cb3482de1fefc2d8e5f67e1e04a0790e8cd243;hpb=5a407301f8b9d2826b23630d8df65096374d5079 diff --git a/src/main/model.lisp b/src/main/model.lisp index 5d7e9e3..3942110 100644 --- a/src/main/model.lisp +++ b/src/main/model.lisp @@ -2,6 +2,13 @@ (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 @@ -16,6 +23,49 @@ 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 @@ -29,7 +79,7 @@ DESCRIPTION: (make-model :code "" :interface (list - (make-view :min-pxcor -5 :max-pxcor 5 :min-pycor -5 :max-pycor 5 :patch-size 13d0)))) + (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 @@ -80,11 +130,13 @@ DESCRIPTION: ,@(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 @@ -97,10 +149,10 @@ DESCRIPTION: (: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 @@ -113,12 +165,13 @@ DESCRIPTION: (: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 @@ -177,6 +230,35 @@ DESCRIPTION: (: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 @@ -196,6 +278,13 @@ DESCRIPTION: (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 @@ -216,8 +305,49 @@ DESCRIPTION: 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." - (declare (ignore name idx)) - nil) + (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 @@ -272,6 +402,143 @@ DESCRIPTION: (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 @@ -284,3 +551,25 @@ DESCRIPTION: 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)))))