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 (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) (when (find (car def) (list :int :double :boolean :choice :string :option)) (second def)))
  82          definitions)))
  83     (push
  84      (list
  85       (lambda (,lines)
  86        (and
  87         ,@(remove nil
  88            (mapcar
  89             (lambda (def n)
  90              (let
  91               ((line `(nth ,n ,lines)))
  92               (case (car def)
  93                (:specified `(string= ,(second def) ,line))
  94                (:int `(parse-integer ,line :junk-allowed t))
  95                (:double `(ignore-errors (coerce (read-from-string ,line) 'double-float)))
  96                (:boolean `(or (string= "1" ,line) (string= "0" ,line)))
  97                (:choice `(find ,line ',(mapcar #'car (third def)) :test #'string=)))))
  98             definitions
  99             (loop for i to (length definitions) collect i)))))
 100       (lambda (,lines)
 101        (,(read-from-string (format nil "make-~A" type))
 102         ,@(apply #'append
 103            (mapcar
 104             (lambda (def n)
 105              (let*
 106               ((line `(nth ,n ,lines))
 107                (val-getter
 108                 (case (car def)
 109                  (:int `(parse-integer ,line))
 110                  (:double `(coerce (read-from-string ,line) 'double-float))
 111                  (:boolean `(string= "1" ,line))
 112                  (:choice `(cadr (find ,line ',(third def) :key #'car :test #'string=)))
 113                  (:option `(when (string/= ,line ,(third def)) ,line))
 114                  (:string line))))
 115               (when val-getter (list (intern (symbol-name (cadr def)) :keyword) val-getter))))
 116             definitions
 117             (loop for i to (length definitions) collect i))))))
 118      *widget-parsers*))))
 119
 120 (defwidget-definition view
 121  (:specified "GRAPHICS-WINDOW")
 122  (:int left)
 123  (:int top)
 124  (:int right)
 125  (:int bottom)
 126  (:reserved "-1")
 127  (:reserved "-1")
 128  (:double patch-size)
 129  (:reserved)
 130  (:int font-size)
 131  (:reserved)
 132  (:reserved)
 133  (:reserved)
 134  (:reserved)
 135  (:boolean wrapping-allowed-in-x)
 136  (:boolean wrapping-allowed-in-y)
 137  (:reserved)
 138  (:int min-pxcor)
 139  (:int max-pxcor)
 140  (:int min-pycor)
 141  (:int max-pycor)
 142  (:choice update-mode (("0" :continuous) ("1" :tick-based)))
 143  (:dump update-mode)
 144  (:boolean show-tick-counter)
 145  (:string tick-counter-label)
 146  (:double frame-rate 30))
 147
 148 (defwidget-definition slider
 149  (:specified "SLIDER")
 150  (:int left)
 151  (:int top)
 152  (:int right)
 153  (:int bottom)
 154  (:string display)
 155  (:string varname)
 156  (:string min)
 157  (:string max)
 158  (:double default)
 159  (:string step)
 160  (:reserved)
 161  (:option units "NIL")
 162  (:choice direction (("HORIZONTAL" :horizontal) ("VERTICAL" :vertical))))
 163
 164 (defun parse-interface (interface-as-strings)
 165  (let
 166   ((widgets-as-strings
 167     (labels
 168      ((separate-widgets-as-strings (lines &optional widget-as-strings)
 169        (when lines
 170         (if (string= "" (car lines))
 171          (cons widget-as-strings (separate-widgets-as-strings (cdr lines)))
 172          (separate-widgets-as-strings (cdr lines) (append widget-as-strings (list (car lines))))))))
 173      (separate-widgets-as-strings interface-as-strings))))
 174   (remove
 175    nil
 176    (mapcar
 177     (lambda (widget-as-strings)
 178      (let
 179       ((parser (find-if (lambda (validator) (funcall validator widget-as-strings)) *widget-parsers* :key #'car)))
 180       (when parser (funcall (cadr parser) widget-as-strings))))
 181     widgets-as-strings))))
 182
 183 ;; INFORMATION ABOUT MODEL
 184
 185 (defun world-dimensions (model)
 186  "WORLD-DIMENSIONS MODEL => DIMS
 187
 188   DIMS: (:xmin XMIN :xmax XMAX :ymin YMIN :ymax YMAX)
 189
 190 ARGUMENTS AND VALUES:
 191
 192   MODEL: A valid model containing a view
 193   XMIN: An integer representing the minimum patch coord in X
 194   XMAX: An integer representing the maximum patch coord in X
 195   YMIN: An integer representing the minimum patch coord in Y
 196   YMAX: An integer representing the maximum patch coord in Y
 197
 198 DESCRIPTION:
 199
 200   Returns the dimensions of MODEL.  MODEL must be a valid model
 201   as parsed by CLNL, and have a valid view in it."
 202  (let
 203   ((view (find-if #'view-p (model-interface model))))
 204   (list
 205    :xmin (view-min-pxcor view)
 206    :xmax (view-max-pxcor view)
 207    :ymin (view-min-pycor view)
 208    :ymax (view-max-pycor view))))