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 ;; INFORMATION ABOUT MODEL
 200
 201 (defun world-dimensions (model)
 202  "WORLD-DIMENSIONS MODEL => DIMS
 203
 204   DIMS: (:xmin XMIN :xmax XMAX :ymin YMIN :ymax YMAX)
 205
 206 ARGUMENTS AND VALUES:
 207
 208   MODEL: A valid model containing a view
 209   XMIN: An integer representing the minimum patch coord in X
 210   XMAX: An integer representing the maximum patch coord in X
 211   YMIN: An integer representing the minimum patch coord in Y
 212   YMAX: An integer representing the maximum patch coord in Y
 213
 214 DESCRIPTION:
 215
 216   Returns the dimensions of MODEL.  MODEL must be a valid model
 217   as parsed by CLNL, and have a valid view in it."
 218  (let
 219   ((view (find-if #'view-p (model-interface model))))
 220   (list
 221    :xmin (view-min-pxcor view)
 222    :xmax (view-max-pxcor view)
 223    :ymin (view-min-pycor view)
 224    :ymax (view-max-pycor view)
 225    :patch-size (view-patch-size view))))
 226
 227 (defun widget-globals (model)
 228  "WIDGET-GLOBALS MODEL => GLOBALS
 229
 230   GLOBALS: GLOBAL*
 231   GLOBAL: (NAME DEFAULT)
 232
 233 ARGUMENTS AND VALUES:
 234
 235   MODEL: A valid model
 236   NAME: A symbol interned in the keyworkd package
 237   DEFAULT: The widget default value
 238
 239 DESCRIPTION:
 240
 241   Returns the globals that get declared in the model from widgets.
 242   They are interned in the keyword package package set for clnl, so
 243   that they can later be used for multiple purposes."
 244  (remove nil
 245   (mapcar
 246    (lambda (widget)
 247     (typecase widget
 248      (slider (list (intern (string-upcase (slider-varname widget)) :keyword) (slider-default widget)))
 249      (switch (list (intern (string-upcase (switch-varname widget)) :keyword) (switch-on widget)))))
 250    (model-interface model))))
 251
 252 (defun code (model)
 253  "CODE MODEL => CODE
 254
 255 ARGUMENTS AND VALUES:
 256
 257   MODEL: A valid model
 258   CODE: The string representing the netlogo code in this model
 259
 260 DESCRIPTION:
 261
 262   Returns the code from the model."
 263  (model-code model))