code.consxy.com Git - clnl/blob - src/main/model.lisp

   1 (in-package #:clnl-model)
   2
   3 (defvar *separator* "@#$#@#$#@")
   4
   5 (defvar *current-interface* nil)
   6 (defvar *current-callback* nil)
   7
   8 ; At this time, this is the only stateful part of the model.  If more get added,
   9 ; a more general concept can be introduced.
  10 (defvar *enabled-forever-buttons* nil)
  11
  12 (defstruct model
  13  code
  14  interface
  15  info
  16  turtle-shapes
  17  version
  18  preview-commands
  19  system-dynamics
  20  behavior-space
  21  hub-net-client
  22  link-shapes
  23  model-settings
  24  delta-tick)
  25
  26 (defun set-callback (callback)
  27  "SET-CALLBACK CALLBACK => RESULT
  28
  29 ARGUMENTS AND VALUES:
  30
  31   CALLBACK: a function that can take netlogo code
  32   RESULT: undefined
  33
  34 DESCRIPTION:
  35
  36   Sets the means by which the interface can call arbitrary netlogo code."
  37  (setf *current-callback* callback))
  38
  39 (defun set-current-interface (interface)
  40  "SET-CURRENT-INTERFACE INTERFACE => RESULT
  41
  42 ARGUMENTS AND VALUES:
  43
  44   INTERFACE: a list of widgets for display
  45   RESULT: undefined
  46
  47 DESCRIPTION:
  48
  49   Sets the currently running model to INTERFACE.
  50
  51   The widgets set here are comprised of the bare necessary
  52   to run the engine with or without an actual visual component."
  53  (setf *current-interface* interface))
  54
  55 (defun interface (model)
  56  "INTERFACE MODEL => INTERFACE
  57
  58 ARGUMENTS AND VALUES:
  59
  60   MODEL: an object representing the model
  61   INTERFACE: a list of widgets for display
  62
  63 DESCRIPTION:
  64
  65   INTERFACE returns the widgets in MODEL, used for display, or
  66   setting with SET-CURRENT-INTERFACE."
  67  (model-interface model))
  68
  69 (defun default-model ()
  70  "DEFAULT-MODEL => MODEL
  71
  72 ARGUMENTS AND VALUES:
  73
  74   MODEL: an object representing the model
  75
  76 DESCRIPTION:
  77
  78   Returns the default startup model."
  79  (make-model
  80   :code ""
  81   :interface (list
  82               (make-view :left 10 :top 10 :min-pxcor -5 :max-pxcor 5 :min-pycor -5 :max-pycor 5 :patch-size 13d0))))
  83
  84 (defun read-from-nlogo (str)
  85  "READ-FROM-NLOGO STR => MODEL
  86
  87 ARGUMENTS AND VALUES:
  88
  89   STR: a readable stream
  90   MODEL: an object representing the model
  91
  92 DESCRIPTION:
  93
  94   Takes a stream STR, reads in a nlogo file, parses it, and then
  95   returns the model object."
  96  (let
  97   ((sections
  98     (labels
  99      ((read-sections (&optional section)
 100        (let
 101         ((line (read-line str nil)))
 102         (when line
 103          (if (string= *separator* line)
 104           (cons section (read-sections))
 105           (read-sections (append section (list line))))))))
 106      (read-sections))))
 107   (make-model
 108    :code (format nil "~{~A~^~%~}" (nth 0 sections))
 109    :interface (parse-interface (nth 1 sections))
 110    :info (nth 2 sections)
 111    :turtle-shapes (nth 3 sections)
 112    :version (nth 4 sections)
 113    :preview-commands (nth 5 sections)
 114    :system-dynamics (nth 6 sections)
 115    :behavior-space (nth 7 sections)
 116    :hub-net-client (nth 8 sections)
 117    :link-shapes (nth 9 sections)
 118    :model-settings (nth 10 sections)
 119    :delta-tick (nth 11 sections))))
 120
 121 ;;; INTERFACE PARSER
 122
 123 (defparameter *widget-parsers* nil)
 124
 125 (defmacro defwidget-definition (type &rest definitions)
 126  (let
 127   ((lines (gensym)))
 128   `(progn
 129     (defstruct ,type
 130      ,@(remove nil
 131         (mapcar
 132          (lambda (def)
 133           (when
 134            (find (car def) (list :int :double :tnil-boolean :inverted-boolean :boolean :choice :string :option :code))
 135            (second def)))
 136          definitions)))
 137     (push
 138      (list
 139       (lambda (,lines) ; Validator
 140        (and
 141         ,@(remove nil
 142            (mapcar
 143             (lambda (def n)
 144              (let
 145               ((line `(nth ,n ,lines)))
 146               (case (car def)
 147                (:specified `(string= ,(second def) ,line))
 148                (:int `(parse-integer ,line :junk-allowed t))
 149                (:double `(ignore-errors (coerce (read-from-string ,line) 'double-float)))
 150                (:boolean `(or (string= "1" ,line) (string= "0" ,line)))
 151                (:inverted-boolean `(or (string= "0" ,line) (string= "1" ,line)))
 152                (:tnil-boolean `(or (string= "T" ,line) (string= "NIL" ,line)))
 153                (:choice `(find ,line ',(mapcar #'car (third def)) :test #'string=)))))
 154             definitions (loop for i to (length definitions) collect i)))))
 155       (lambda (,lines) ; Parser
 156        (,(read-from-string (format nil "make-~A" type))
 157         ,@(apply #'append
 158            (mapcar
 159             (lambda (def n)
 160              (let*
 161               ((line `(nth ,n ,lines))
 162                (val-getter
 163                 (case (car def)
 164                  (:int `(parse-integer ,line))
 165                  (:double `(coerce (read-from-string ,line) 'double-float))
 166                  (:boolean `(string= "1" ,line))
 167                  (:inverted-boolean `(string= "0" ,line))
 168                  (:tnil-boolean `(string/= "NIL" ,line))
 169                  (:choice `(cadr (find ,line ',(third def) :key #'car :test #'string=)))
 170                  (:option `(when (string/= ,line ,(third def)) ,line))
 171                  (:code `(unescape-code ,line))
 172                  (:string line))))
 173               (when val-getter (list (intern (symbol-name (cadr def)) :keyword) val-getter))))
 174             definitions (loop for i to (length definitions) collect i))))))
 175      *widget-parsers*))))
 176
 177 (defwidget-definition view
 178  (:specified "GRAPHICS-WINDOW")
 179  (:int left)
 180  (:int top)
 181  (:int right)
 182  (:int bottom)
 183  (:reserved "-1")
 184  (:reserved "-1")
 185  (:double patch-size)
 186  (:reserved)
 187  (:int font-size)
 188  (:reserved)
 189  (:reserved)
 190  (:reserved)
 191  (:reserved)
 192  (:boolean wrapping-allowed-in-x)
 193  (:boolean wrapping-allowed-in-y)
 194  (:reserved)
 195  (:int min-pxcor)
 196  (:int max-pxcor)
 197  (:int min-pycor)
 198  (:int max-pycor)
 199  (:choice update-mode (("0" :continuous) ("1" :tick-based)))
 200  (:dump update-mode)
 201  (:boolean show-tick-counter)
 202  (:string tick-counter-label)
 203  (:double frame-rate 30))
 204
 205 (defwidget-definition slider
 206  (:specified "SLIDER")
 207  (:int left)
 208  (:int top)
 209  (:int right)
 210  (:int bottom)
 211  (:string display)
 212  (:string varname)
 213  (:string min)
 214  (:string max)
 215  (:double default)
 216  (:string step)
 217  (:reserved)
 218  (:option units "NIL")
 219  (:choice direction (("HORIZONTAL" :horizontal) ("VERTICAL" :vertical))))
 220
 221 (defwidget-definition switch
 222  (:specified "SWITCH")
 223  (:int left)
 224  (:int top)
 225  (:int right)
 226  (:int bottom)
 227  (:string display)
 228  (:string varname)
 229  (:inverted-boolean on)
 230  (:reserved)
 231  (:reserved))
 232
 233 (defwidget-definition button
 234  (:specified "BUTTON")
 235  (:int left)
 236  (:int top)
 237  (:int right)
 238  (:int bottom)
 239  (:option display "NIL")
 240  (:code code)
 241  (:tnil-boolean forever)
 242  (:reserved)
 243  (:reserved)
 244  (:string button-type)
 245  (:reserved)
 246  (:string action-key)
 247  (:reserved)
 248  (:reserved)
 249  (:boolean go-time)) ; should it wait for ticks to be initialized
 250
 251 (defun parse-interface (interface-as-strings)
 252  (let
 253   ((widgets-as-strings
 254     (labels
 255      ((separate-widgets-as-strings (lines &optional widget-as-strings)
 256        (when lines
 257         (if (string= "" (car lines))
 258          (cons widget-as-strings (separate-widgets-as-strings (cdr lines)))
 259          (separate-widgets-as-strings (cdr lines) (append widget-as-strings (list (car lines))))))))
 260      (separate-widgets-as-strings interface-as-strings))))
 261   (remove
 262    nil
 263    (mapcar
 264     (lambda (widget-as-strings)
 265      (let
 266       ((parser (find-if (lambda (validator) (funcall validator widget-as-strings)) *widget-parsers* :key #'car)))
 267       (when parser (funcall (cadr parser) widget-as-strings))))
 268     widgets-as-strings))))
 269
 270 (defun find-button (name idx)
 271  (nth
 272   idx
 273   (remove-if-not
 274    (lambda (widget) (and (button-p widget) (string= (button-display-name widget) name)))
 275    *current-interface*)))
 276
 277 ; With authoring, idx here needs to be looked at again.
 278 (defun execute-button (name &optional (idx 0))
 279  "EXECUTE-BUTTON NAME &optional IDX => RESULT
 280
 281 ARGUMENTS AND VALUES:
 282
 283   NAME: the name of the button
 284   IDX: the instance of the button, defaults to 0
 285   RESULT: undefined
 286
 287 DESCRIPTION:
 288
 289   Executes the code in the button referenced by NAME and IDX.
 290
 291   NAME refers to the display name for the button, which is usually
 292   set by the model, but sometimes defaults to the code inside.
 293
 294   Because NAME is not guaranteed to be unique, IDX is available
 295   as a specifier.  The index is in the order that the buttons are
 296   loaded, and cannot be guaranteed to be stable from run to run."
 297  (when *current-callback*
 298   (let
 299    ((button (find-button name (round idx))))
 300    (cond
 301     ((not button) (error "Couldn't find button with name ~A (idx: ~A)" name idx))
 302     ((and (button-forever button) (find button *enabled-forever-buttons* :test #'equal))
 303      (setf *enabled-forever-buttons* (remove button *enabled-forever-buttons* :test #'equal)))
 304     ((button-forever button)
 305      (setf *enabled-forever-buttons* (cons button *enabled-forever-buttons*))
 306      (sb-thread:make-thread
 307       (lambda ()
 308        (loop
 309         :while (find button *enabled-forever-buttons* :test #'equal)
 310         ; The sleep is necessary so that it gives other threads time
 311         :do (progn (clnl:run-commands (button-code button)) (sleep .001))))
 312       :name (format nil "Forever button: ~A" (button-display button))))
 313     (t (funcall *current-callback* (button-code button)))))))
 314
 315 (defun forever-button-on (name &optional (idx 0))
 316  "FOREVER-BUTTON-ON NAME &optional IDX => ON
 317
 318 ARGUMENTS AND VALUES:
 319
 320   NAME: the name of the button
 321   IDX: the instance of the button, defaults to 0
 322   ON: a boolean
 323
 324 DESCRIPTION:
 325
 326   Returns whether the button identified by NAME and IDX is currently on.
 327
 328   NAME refers to the display name for the button, which is usually
 329   set by the model, but sometimes defaults to the code inside.
 330
 331   Because NAME is not guaranteed to be unique, IDX is available
 332   as a specifier.  The index is in the order that the buttons are
 333   loaded, and cannot be guaranteed to be stable from run to run."
 334  (and (find (find-button name (round idx)) *enabled-forever-buttons* :test #'equal) t))
 335
 336 ;; INFORMATION ABOUT MODEL
 337
 338 (defun world-dimensions (model)
 339  "WORLD-DIMENSIONS MODEL => DIMS
 340
 341   DIMS: (:xmin XMIN :xmax XMAX :ymin YMIN :ymax YMAX)
 342
 343 ARGUMENTS AND VALUES:
 344
 345   MODEL: A valid model containing a view
 346   XMIN: An integer representing the minimum patch coord in X
 347   XMAX: An integer representing the maximum patch coord in X
 348   YMIN: An integer representing the minimum patch coord in Y
 349   YMAX: An integer representing the maximum patch coord in Y
 350
 351 DESCRIPTION:
 352
 353   Returns the dimensions of MODEL.  MODEL must be a valid model
 354   as parsed by CLNL, and have a valid view in it."
 355  (let
 356   ((view (find-if #'view-p (model-interface model))))
 357   (list
 358    :xmin (view-min-pxcor view)
 359    :xmax (view-max-pxcor view)
 360    :ymin (view-min-pycor view)
 361    :ymax (view-max-pycor view)
 362    :patch-size (view-patch-size view))))
 363
 364 (defun widget-globals (model)
 365  "WIDGET-GLOBALS MODEL => GLOBALS
 366
 367   GLOBALS: GLOBAL*
 368   GLOBAL: (NAME DEFAULT)
 369
 370 ARGUMENTS AND VALUES:
 371
 372   MODEL: A valid model
 373   NAME: A symbol interned in the keyworkd package
 374   DEFAULT: The widget default value
 375
 376 DESCRIPTION:
 377
 378   Returns the globals that get declared in the model from widgets.
 379   They are interned in the keyword package package set for clnl, so
 380   that they can later be used for multiple purposes."
 381  (remove nil
 382   (mapcar
 383    (lambda (widget)
 384     (typecase widget
 385      (slider (list (intern (string-upcase (slider-varname widget)) :keyword) (slider-default widget)))
 386      (switch (list (intern (string-upcase (switch-varname widget)) :keyword) (switch-on widget)))))
 387    (model-interface model))))
 388
 389 (defun buttons (model)
 390  "BUTTONS MODEL => BUTTON-DEFS
 391
 392   BUTTON-DEFS: BUTTON-DEF*
 393   BUTTON-DEF: (:left LEFT :top TOP :height HEIGHT :width WIDTH :forever FOREVER :display DISPLAY)
 394
 395 ARGUMENTS AND VALUES:
 396
 397   MODEL: A valid model
 398   LEFT: An integer representing the left position
 399   TOP: An integer representing the top position
 400   HEIGHT: An integer representing height
 401   WIDTH: An integer representing width
 402   FOREVER: A boolean representing whether this button is a forever button
 403   DISPLAY: A string representing display name
 404
 405 DESCRIPTION:
 406
 407   Returns button definitions that get declared in the buttons of the
 408   MODEL.  This is used to initialize the interface."
 409  (remove nil
 410   (mapcar
 411    (lambda (widget)
 412     (typecase widget
 413      (button
 414       (list
 415        :left (button-left widget)
 416        :top (button-top widget)
 417        :width (- (button-right widget) (button-left widget))
 418        :height (- (button-bottom widget) (button-top widget))
 419        :forever (button-forever widget)
 420        :display (button-display-name widget)))))
 421    (model-interface model))))
 422
 423 (defun view (model)
 424  "VIEW MODEL => VIEW-DEF
 425
 426   VIEW-DEF: (:left LEFT :top TOP)
 427
 428 ARGUMENTS AND VALUES:
 429
 430   MODEL: A valid model
 431   LEFT: An integer representing the left position
 432   TOP: An integer representing the top position
 433
 434 DESCRIPTION:
 435
 436   Returns the view definition that get declared in the view of the
 437   MODEL.  This is used to initialize the interface."
 438  (let
 439   ((view (find-if #'view-p (model-interface model))))
 440   (list :left (view-left view) :top (view-top view))))
 441
 442 (defun code (model)
 443  "CODE MODEL => CODE
 444
 445 ARGUMENTS AND VALUES:
 446
 447   MODEL: A valid model
 448   CODE: The string representing the netlogo code in this model
 449
 450 DESCRIPTION:
 451
 452   Returns the code from the model."
 453  (model-code model))
 454
 455 ; This should get cached eventually, though maybe just cached via a display list is good enough
 456 (defun button-display-name (button)
 457  (or
 458   (button-display button)
 459   (cl-ppcre:regex-replace-all "\\s+" (button-code button) " ")))
 460
 461 (defun unescape-code (code)
 462  (with-output-to-string (out)
 463   (with-input-from-string (in code)
 464    (loop
 465     :for c := (read-char in nil)
 466     :while c
 467     :for aux := (when (eql #\\ c)
 468                  (case (read-char in)
 469                   (#\n #\Newline)
 470                   (#\r #\Return)
 471                   (#\t #\Tab)
 472                   (#\\ #\\)
 473                   (#\" #\")
 474                   (t (error "Invalid escape sequence"))))
 475     :do (write-char (or aux c) out)))))
 476