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)) (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                  (:string line))))
 114               (when val-getter (list (intern (symbol-name (cadr def)) :keyword) val-getter))))
 115             definitions
 116             (loop for i to (length definitions) collect i))))))
 117      *widget-parsers*))))
 118
 119 (defwidget-definition view
 120  (:specified "GRAPHICS-WINDOW")
 121  (:int left)
 122  (:int top)
 123  (:int right)
 124  (:int bottom)
 125  (:reserved "-1")
 126  (:reserved "-1")
 127  (:double patch-size)
 128  (:reserved)
 129  (:int font-size)
 130  (:reserved)
 131  (:reserved)
 132  (:reserved)
 133  (:reserved)
 134  (:boolean wrapping-allowed-in-x)
 135  (:boolean wrapping-allowed-in-y)
 136  (:reserved)
 137  (:int min-pxcor)
 138  (:int max-pxcor)
 139  (:int min-pycor)
 140  (:int max-pycor)
 141  (:choice update-mode (("0" :continuous) ("1" :tick-based)))
 142  (:dump update-mode)
 143  (:boolean show-tick-counter)
 144  (:string tick-counter-label)
 145  (:double frame-rate 30))
 146
 147 (defun parse-interface (interface-as-strings)
 148  (let
 149   ((widgets-as-strings
 150     (labels
 151      ((separate-widgets-as-strings (lines &optional widget-as-strings)
 152        (when lines
 153         (if (string= "" (car lines))
 154          (cons widget-as-strings (separate-widgets-as-strings (cdr lines)))
 155          (separate-widgets-as-strings (cdr lines) (append widget-as-strings (list (car lines))))))))
 156      (separate-widgets-as-strings interface-as-strings))))
 157   (remove
 158    nil
 159    (mapcar
 160     (lambda (widget-as-strings)
 161      (let
 162       ((parser (find-if (lambda (validator) (funcall validator widget-as-strings)) *widget-parsers* :key #'car)))
 163       (when parser (funcall (cadr parser) widget-as-strings))))
 164     widgets-as-strings))))
 165
 166 ;; INFORMATION ABOUT MODEL
 167
 168 (defun world-dimensions (model)
 169  "WORLD-DIMENSIONS MODEL => DIMS
 170
 171   DIMS: (:xmin XMIN :xmax XMAX :ymin YMIN :ymax YMAX)
 172
 173 ARGUMENTS AND VALUES:
 174
 175   MODEL: A valid model containing a view
 176   XMIN: An integer representing the minimum patch coord in X
 177   XMAX: An integer representing the maximum patch coord in X
 178   YMIN: An integer representing the minimum patch coord in Y
 179   YMAX: An integer representing the maximum patch coord in Y
 180
 181 DESCRIPTION:
 182
 183   Returns the dimensions of MODEL.  MODEL must be a valid model
 184   as parsed by CLNL, and have a valid view in it."
 185  (let
 186   ((view (find-if #'view-p (model-interface model))))
 187   (list
 188    :xmin (view-min-pxcor view)
 189    :xmax (view-max-pxcor view)
 190    :ymin (view-min-pycor view)
 191    :ymax (view-max-pycor view))))