X-Git-Url: https://code.consxy.com/gitweb/gitweb.cgi?p=clnl;a=blobdiff_plain;f=src%2Fmain%2Fmodel.lisp;h=3942110d860b4c13e15bb45fc2b66007f013a61d;hp=5af89f24b2e929bfd701252811d2f722ba76f4f6;hb=89cb3482de1fefc2d8e5f67e1e04a0790e8cd243;hpb=c49ca54ae5a11563aeca0cf01b4fb0b6e181befa

diff --git a/src/main/model.lisp b/src/main/model.lisp
index 5af89f2..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,64 @@
  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
+
+ARGUMENTS AND VALUES:
+
+  MODEL: an object representing the model
+
+DESCRIPTION:
+
+  Returns the default startup model."
+ (make-model
+  :code ""
+  :interface (list
+              (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
 
@@ -40,8 +105,8 @@ DESCRIPTION:
           (read-sections (append section (list line))))))))
      (read-sections))))
   (make-model
-   :code (nth 0 sections)
-   :interface (nth 1 sections)
+   :code (format nil "~{~A~^~%~}" (nth 0 sections))
+   :interface (parse-interface (nth 1 sections))
    :info (nth 2 sections)
    :turtle-shapes (nth 3 sections)
    :version (nth 4 sections)
@@ -52,3 +117,459 @@ DESCRIPTION:
    :link-shapes (nth 9 sections)
    :model-settings (nth 10 sections)
    :delta-tick (nth 11 sections))))
+
+;;; INTERFACE PARSER
+
+(defparameter *widget-parsers* nil)
+
+(defmacro defwidget-definition (type &rest definitions)
+ (let
+  ((lines (gensym)))
+  `(progn
+    (defstruct ,type
+     ,@(remove nil
+        (mapcar
+         (lambda (def)
+          (when
+           (find (car def) (list :int :double :tnil-boolean :inverted-boolean :boolean :choice :string :option :code))
+           (second def)))
+         definitions)))
+    (push
+     (list
+      (lambda (,lines) ; Validator
+       (and
+        ,@(remove nil
+           (mapcar
+            (lambda (def n)
+             (let
+              ((line `(nth ,n ,lines)))
+              (case (car def)
+               (:specified `(string= ,(second def) ,line))
+               (:int `(parse-integer ,line :junk-allowed t))
+               (: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) ; Parser
+       (,(read-from-string (format nil "make-~A" type))
+        ,@(apply #'append
+           (mapcar
+            (lambda (def n)
+             (let*
+              ((line `(nth ,n ,lines))
+               (val-getter
+                (case (car def)
+                 (:int `(parse-integer ,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))
+                 (: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))))))
+     *widget-parsers*))))
+
+(defwidget-definition view
+ (:specified "GRAPHICS-WINDOW")
+ (:int left)
+ (:int top)
+ (:int right)
+ (:int bottom)
+ (:reserved "-1")
+ (:reserved "-1")
+ (:double patch-size)
+ (:reserved)
+ (:int font-size)
+ (:reserved)
+ (:reserved)
+ (:reserved)
+ (:reserved)
+ (:boolean wrapping-allowed-in-x)
+ (:boolean wrapping-allowed-in-y)
+ (:reserved)
+ (:int min-pxcor)
+ (:int max-pxcor)
+ (:int min-pycor)
+ (:int max-pycor)
+ (:choice update-mode (("0" :continuous) ("1" :tick-based)))
+ (:dump update-mode)
+ (:boolean show-tick-counter)
+ (:string tick-counter-label)
+ (:double frame-rate 30))
+
+(defwidget-definition slider
+ (:specified "SLIDER")
+ (:int left)
+ (:int top)
+ (:int right)
+ (:int bottom)
+ (:string display)
+ (:string varname)
+ (:string min)
+ (:string max)
+ (:double default)
+ (:string step)
+ (:reserved)
+ (:option units "NIL")
+ (:choice direction (("HORIZONTAL" :horizontal) ("VERTICAL" :vertical))))
+
+(defwidget-definition switch
+ (:specified "SWITCH")
+ (:int left)
+ (:int top)
+ (:int right)
+ (:int bottom)
+ (:string display)
+ (:string varname)
+ (:inverted-boolean on)
+ (: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
+    (labels
+     ((separate-widgets-as-strings (lines &optional widget-as-strings)
+       (when lines
+        (if (string= "" (car lines))
+         (cons widget-as-strings (separate-widgets-as-strings (cdr lines)))
+         (separate-widgets-as-strings (cdr lines) (append widget-as-strings (list (car lines))))))))
+     (separate-widgets-as-strings interface-as-strings))))
+  (remove
+   nil
+   (mapcar
+    (lambda (widget-as-strings)
+     (let
+      ((parser (find-if (lambda (validator) (funcall validator widget-as-strings)) *widget-parsers* :key #'car)))
+      (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)
+ "WORLD-DIMENSIONS MODEL => DIMS
+
+  DIMS: (:xmin XMIN :xmax XMAX :ymin YMIN :ymax YMAX)
+
+ARGUMENTS AND VALUES:
+
+  MODEL: A valid model containing a view
+  XMIN: An integer representing the minimum patch coord in X
+  XMAX: An integer representing the maximum patch coord in X
+  YMIN: An integer representing the minimum patch coord in Y
+  YMAX: An integer representing the maximum patch coord in Y
+
+DESCRIPTION:
+
+  Returns the dimensions of MODEL.  MODEL must be a valid model
+  as parsed by CLNL, and have a valid view in it."
+ (let
+  ((view (find-if #'view-p (model-interface model))))
+  (list
+   :xmin (view-min-pxcor view)
+   :xmax (view-max-pxcor view)
+   :ymin (view-min-pycor view)
+   :ymax (view-max-pycor view)
+   :patch-size (view-patch-size view))))
+
+(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
+  CODE: The string representing the netlogo code in this model
+
+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)))))