3812ac24cedd5bb9da35ab3d5d9eb4aae118a09f
[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 (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))))