Model Parse - Buttons

[clnl] / src / main / model.lisp

diff --git a/src/main/model.lisp b/src/main/model.lisp
index 5d7e9e3eb49b9bf04de7cae19ac65d88559f7114..f054d4c62b0d7f144be7d9e9f07dc5c8866c6052 100644 (file)
--- a/src/main/model.lisp
+++ b/src/main/model.lisp
@@ -2,6 +2,9 @@
 
 (defvar *separator* "@#$#@#$#@")
 
 
 (defvar *separator* "@#$#@#$#@")
 

+(defvar *current-interface* nil)
+(defvar *current-callback* nil)
+

 (defstruct model
  code
  interface
 (defstruct model
  code
  interface


@@ -16,6 +19,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
 


@@ -80,11 +126,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 +145,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 +161,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 +226,24 @@ 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
+

 (defun parse-interface (interface-as-strings)
  (let
   ((widgets-as-strings
 (defun parse-interface (interface-as-strings)
  (let
   ((widgets-as-strings


@@ -216,8 +283,18 @@ 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
+     (nth
+      (round idx)
+      (remove-if-not
+       (lambda (widget) (and (button-p widget) (string= (button-display-name widget) name)))
+       *current-interface*))))
+   (if
+    button
+    (funcall *current-callback* (button-code button))
+    (error "Couldn't find button with name ~A (idx: ~A)" name idx)))))

 
 ;; INFORMATION ABOUT MODEL
 
 
 ;; INFORMATION ABOUT MODEL
 


@@ -284,3 +361,26 @@ 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)))))
+