UI/Model Parse - Sliders - WIP

[clnl] / src / main / model.lisp

diff --git a/src/main/model.lisp b/src/main/model.lisp
index 5d7e9e3eb49b9bf04de7cae19ac65d88559f7114..3942110d860b4c13e15bb45fc2b66007f013a61d 100644 (file)
--- a/src/main/model.lisp
+++ b/src/main/model.lisp
@@ -2,6 +2,13 @@
 
 (defvar *separator* "@#$#@#$#@")
 
 
 (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
 (defstruct model
  code
  interface


@@ -16,6 +23,49 @@
  model-settings
  delta-tick)
 
  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
 
 (defun default-model ()
  "DEFAULT-MODEL => MODEL
 


@@ -29,7 +79,7 @@ DESCRIPTION:
  (make-model
   :code ""
   :interface (list
  (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
 
 (defun read-from-nlogo (str)
  "READ-FROM-NLOGO STR => MODEL


@@ -80,11 +130,13 @@ DESCRIPTION:
      ,@(remove nil
         (mapcar
          (lambda (def)
      ,@(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
          definitions)))
     (push
      (list

-      (lambda (,lines)
+      (lambda (,lines) ; Validator

        (and
         ,@(remove nil
            (mapcar
        (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)))
                (: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=)))))
                (: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
        (,(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))
                  (: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))
                  (: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))))
                  (: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
      *widget-parsers*))))
 
 (defwidget-definition view


@@ -177,6 +230,35 @@ DESCRIPTION:
  (:reserved)
  (:reserved))
 
  (: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
 (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))))
 
       (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
 ; 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."
   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
 
 
 ;; INFORMATION ABOUT MODEL
 


@@ -272,6 +402,143 @@ DESCRIPTION:
      (switch (list (intern (string-upcase (switch-varname widget)) :keyword) (switch-on widget)))))
    (model-interface model))))
 
      (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
 
 (defun code (model)
  "CODE MODEL => CODE
 


@@ -284,3 +551,25 @@ DESCRIPTION:
 
   Returns the code from the model."
  (model-code 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)))))