+++ /dev/null
-(in-package #:clnl-model)
-
-(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
- info
- turtle-shapes
- version
- preview-commands
- system-dynamics
- behavior-space
- hub-net-client
- link-shapes
- 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
-
-ARGUMENTS AND VALUES:
-
- STR: a readable stream
- MODEL: an object representing the model
-
-DESCRIPTION:
-
- Takes a stream STR, reads in a nlogo file, parses it, and then
- returns the model object."
- (let
- ((sections
- (labels
- ((read-sections (&optional section)
- (let
- ((line (read-line str nil)))
- (when line
- (if (string= *separator* line)
- (cons section (read-sections))
- (read-sections (append section (list line))))))))
- (read-sections))))
- (make-model
- :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)
- :preview-commands (nth 5 sections)
- :system-dynamics (nth 6 sections)
- :behavior-space (nth 7 sections)
- :hub-net-client (nth 8 sections)
- :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)))))
projects / clnl / blobdiff