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