Prims - Implement with
[clnl] / 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)) :keyword))
64               (switch (intern (string-upcase (switch-varname widget)) :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))))))