code.consxy.com Git - clnl/blob - src/main/model.lisp

   1 (in-package #:clnl-model)
   2
   3 (defvar *separator* "@#$#@#$#@")
   4
   5 (defstruct model
   6  code
   7  interface
   8  info
   9  turtle-shapes
  10  version
  11  preview-commands
  12  system-dynamics
  13  behavior-space
  14  hub-net-client
  15  link-shapes
  16  model-settings
  17  delta-tick)
  18
  19 (defun default-model ()
  20  "DEFAULT-MODEL => MODEL
  21
  22 ARGUMENTS AND VALUES:
  23
  24   MODEL: an object representing the model
  25
  26 DESCRIPTION:
  27
  28   Returns the default startup model."
  29  (make-model
  30   :code ""
  31   :interface (list
  32               (make-view :min-pxcor -5 :max-pxcor 5 :min-pycor -5 :max-pycor 5 :patch-size 13d0))))
  33
  34 (defun read-from-nlogo (str)
  35  "READ-FROM-NLOGO STR => MODEL
  36
  37 ARGUMENTS AND VALUES:
  38
  39   STR: a readable stream
  40   MODEL: an object representing the model
  41
  42 DESCRIPTION:
  43
  44   Takes a stream STR, reads in a nlogo file, parses it, and then
  45   returns the model object."
  46  (let
  47   ((sections
  48     (labels
  49      ((read-sections (&optional section)
  50        (let
  51         ((line (read-line str nil)))
  52         (when line
  53          (if (string= *separator* line)
  54           (cons section (read-sections))
  55           (read-sections (append section (list line))))))))
  56      (read-sections))))
  57   (make-model
  58    :code (format nil "~{~A~^~%~}" (nth 0 sections))
  59    :interface (parse-interface (nth 1 sections))
  60    :info (nth 2 sections)
  61    :turtle-shapes (nth 3 sections)
  62    :version (nth 4 sections)
  63    :preview-commands (nth 5 sections)
  64    :system-dynamics (nth 6 sections)
  65    :behavior-space (nth 7 sections)
  66    :hub-net-client (nth 8 sections)
  67    :link-shapes (nth 9 sections)
  68    :model-settings (nth 10 sections)
  69    :delta-tick (nth 11 sections))))
  70
  71 ;;; INTERFACE PARSER
  72
  73 (defparameter *widget-parsers* nil)
  74
  75 (defmacro defwidget-definition (type &rest definitions)
  76  (let
  77   ((lines (gensym)))
  78   `(progn
  79     (defstruct ,type
  80      ,@(remove nil
  81         (mapcar
  82          (lambda (def)
  83           (when (find (car def) (list :int :double :inverted-boolean :boolean :choice :string :option)) (second def)))
  84          definitions)))
  85     (push
  86      (list
  87       (lambda (,lines)
  88        (and
  89         ,@(remove nil
  90            (mapcar
  91             (lambda (def n)
  92              (let
  93               ((line `(nth ,n ,lines)))
  94               (case (car def)
  95                (:specified `(string= ,(second def) ,line))
  96                (:int `(parse-integer ,line :junk-allowed t))
  97                (:double `(ignore-errors (coerce (read-from-string ,line) 'double-float)))
  98                (:boolean `(or (string= "1" ,line) (string= "0" ,line)))
  99                (:inverted-boolean `(or (string= "0" ,line) (string= "1" ,line)))
 100                (:choice `(find ,line ',(mapcar #'car (third def)) :test #'string=)))))
 101             definitions
 102             (loop for i to (length definitions) collect i)))))
 103       (lambda (,lines)
 104        (,(read-from-string (format nil "make-~A" type))
 105         ,@(apply #'append
 106            (mapcar
 107             (lambda (def n)
 108              (let*
 109               ((line `(nth ,n ,lines))
 110                (val-getter
 111                 (case (car def)
 112                  (:int `(parse-integer ,line))
 113                  (:double `(coerce (read-from-string ,line) 'double-float))
 114                  (:boolean `(string= "1" ,line))
 115                  (:inverted-boolean `(string= "0" ,line))
 116                  (:choice `(cadr (find ,line ',(third def) :key #'car :test #'string=)))
 117                  (:option `(when (string/= ,line ,(third def)) ,line))
 118                  (:string line))))
 119               (when val-getter (list (intern (symbol-name (cadr def)) :keyword) val-getter))))
 120             definitions
 121             (loop for i to (length definitions) collect i))))))
 122      *widget-parsers*))))
 123
 124 (defwidget-definition view
 125  (:specified "GRAPHICS-WINDOW")
 126  (:int left)
 127  (:int top)
 128  (:int right)
 129  (:int bottom)
 130  (:reserved "-1")
 131  (:reserved "-1")
 132  (:double patch-size)
 133  (:reserved)
 134  (:int font-size)
 135  (:reserved)
 136  (:reserved)
 137  (:reserved)
 138  (:reserved)
 139  (:boolean wrapping-allowed-in-x)
 140  (:boolean wrapping-allowed-in-y)
 141  (:reserved)
 142  (:int min-pxcor)
 143  (:int max-pxcor)
 144  (:int min-pycor)
 145  (:int max-pycor)
 146  (:choice update-mode (("0" :continuous) ("1" :tick-based)))
 147  (:dump update-mode)
 148  (:boolean show-tick-counter)
 149  (:string tick-counter-label)
 150  (:double frame-rate 30))
 151
 152 (defwidget-definition slider
 153  (:specified "SLIDER")
 154  (:int left)
 155  (:int top)
 156  (:int right)
 157  (:int bottom)
 158  (:string display)
 159  (:string varname)
 160  (:string min)
 161  (:string max)
 162  (:double default)
 163  (:string step)
 164  (:reserved)
 165  (:option units "NIL")
 166  (:choice direction (("HORIZONTAL" :horizontal) ("VERTICAL" :vertical))))
 167
 168 (defwidget-definition switch
 169  (:specified "SWITCH")
 170  (:int left)
 171  (:int top)
 172  (:int right)
 173  (:int bottom)
 174  (:string display)
 175  (:string varname)
 176  (:inverted-boolean on)
 177  (:reserved)
 178  (:reserved))
 179
 180 (defun parse-interface (interface-as-strings)
 181  (let
 182   ((widgets-as-strings
 183     (labels
 184      ((separate-widgets-as-strings (lines &optional widget-as-strings)
 185        (when lines
 186         (if (string= "" (car lines))
 187          (cons widget-as-strings (separate-widgets-as-strings (cdr lines)))
 188          (separate-widgets-as-strings (cdr lines) (append widget-as-strings (list (car lines))))))))
 189      (separate-widgets-as-strings interface-as-strings))))
 190   (remove
 191    nil
 192    (mapcar
 193     (lambda (widget-as-strings)
 194      (let
 195       ((parser (find-if (lambda (validator) (funcall validator widget-as-strings)) *widget-parsers* :key #'car)))
 196       (when parser (funcall (cadr parser) widget-as-strings))))
 197     widgets-as-strings))))
 198
 199 ; With authoring, idx here needs to be looked at again.
 200 (defun execute-button (name &optional (idx 0))
 201  "EXECUTE-BUTTON NAME &optional IDX => RESULT
 202
 203 ARGUMENTS AND VALUES:
 204
 205   NAME: the name of the button
 206   IDX: the instance of the button, defaults to 0
 207   RESULT: undefined
 208
 209 DESCRIPTION:
 210
 211   Executes the code in the button referenced by NAME and IDX.
 212
 213   NAME refers to the display name for the button, which is usually
 214   set by the model, but sometimes defaults to the code inside.
 215
 216   Because NAME is not guaranteed to be unique, IDX is available
 217   as a specifier.  The index is in the order that the buttons are
 218   loaded, and cannot be guaranteed to be stable from run to run."
 219  (declare (ignore name idx))
 220  nil)
 221
 222 ;; INFORMATION ABOUT MODEL
 223
 224 (defun world-dimensions (model)
 225  "WORLD-DIMENSIONS MODEL => DIMS
 226
 227   DIMS: (:xmin XMIN :xmax XMAX :ymin YMIN :ymax YMAX)
 228
 229 ARGUMENTS AND VALUES:
 230
 231   MODEL: A valid model containing a view
 232   XMIN: An integer representing the minimum patch coord in X
 233   XMAX: An integer representing the maximum patch coord in X
 234   YMIN: An integer representing the minimum patch coord in Y
 235   YMAX: An integer representing the maximum patch coord in Y
 236
 237 DESCRIPTION:
 238
 239   Returns the dimensions of MODEL.  MODEL must be a valid model
 240   as parsed by CLNL, and have a valid view in it."
 241  (let
 242   ((view (find-if #'view-p (model-interface model))))
 243   (list
 244    :xmin (view-min-pxcor view)
 245    :xmax (view-max-pxcor view)
 246    :ymin (view-min-pycor view)
 247    :ymax (view-max-pycor view)
 248    :patch-size (view-patch-size view))))
 249
 250 (defun widget-globals (model)
 251  "WIDGET-GLOBALS MODEL => GLOBALS
 252
 253   GLOBALS: GLOBAL*
 254   GLOBAL: (NAME DEFAULT)
 255
 256 ARGUMENTS AND VALUES:
 257
 258   MODEL: A valid model
 259   NAME: A symbol interned in the keyworkd package
 260   DEFAULT: The widget default value
 261
 262 DESCRIPTION:
 263
 264   Returns the globals that get declared in the model from widgets.
 265   They are interned in the keyword package package set for clnl, so
 266   that they can later be used for multiple purposes."
 267  (remove nil
 268   (mapcar
 269    (lambda (widget)
 270     (typecase widget
 271      (slider (list (intern (string-upcase (slider-varname widget)) :keyword) (slider-default widget)))
 272      (switch (list (intern (string-upcase (switch-varname widget)) :keyword) (switch-on widget)))))
 273    (model-interface model))))
 274
 275 (defun code (model)
 276  "CODE MODEL => CODE
 277
 278 ARGUMENTS AND VALUES:
 279
 280   MODEL: A valid model
 281   CODE: The string representing the netlogo code in this model
 282
 283 DESCRIPTION:
 284
 285   Returns the code from the model."
 286  (model-code model))