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