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)
  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))))