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
 312         (let
 313          ((result (funcall *current-callback* (button-code button))))
 314          (when (eql :stop result)
 315           (setf *enabled-forever-buttons* (remove button *enabled-forever-buttons* :test #'equal)))
 316          (sleep .001))))
 317       :name (format nil "Forever button: ~A" (button-display button))))
 318     (t (funcall *current-callback* (button-code button)))))))
 319
 320 (defun forever-button-on (name &optional (idx 0))
 321  "FOREVER-BUTTON-ON NAME &optional IDX => ON
 322
 323 ARGUMENTS AND VALUES:
 324
 325   NAME: the name of the button
 326   IDX: the instance of the button, defaults to 0
 327   ON: a boolean
 328
 329 DESCRIPTION:
 330
 331   Returns whether the button identified by NAME and IDX is currently on.
 332
 333   NAME refers to the display name for the button, which is usually
 334   set by the model, but sometimes defaults to the code inside.
 335
 336   Because NAME is not guaranteed to be unique, IDX is available
 337   as a specifier.  The index is in the order that the buttons are
 338   loaded, and cannot be guaranteed to be stable from run to run."
 339  (and (find (find-button name (round idx)) *enabled-forever-buttons* :test #'equal) t))
 340
 341 ;; INFORMATION ABOUT MODEL
 342
 343 (defun world-dimensions (model)
 344  "WORLD-DIMENSIONS MODEL => DIMS
 345
 346   DIMS: (:xmin XMIN :xmax XMAX :ymin YMIN :ymax YMAX)
 347
 348 ARGUMENTS AND VALUES:
 349
 350   MODEL: A valid model containing a view
 351   XMIN: An integer representing the minimum patch coord in X
 352   XMAX: An integer representing the maximum patch coord in X
 353   YMIN: An integer representing the minimum patch coord in Y
 354   YMAX: An integer representing the maximum patch coord in Y
 355
 356 DESCRIPTION:
 357
 358   Returns the dimensions of MODEL.  MODEL must be a valid model
 359   as parsed by CLNL, and have a valid view in it."
 360  (let
 361   ((view (find-if #'view-p (model-interface model))))
 362   (list
 363    :xmin (view-min-pxcor view)
 364    :xmax (view-max-pxcor view)
 365    :ymin (view-min-pycor view)
 366    :ymax (view-max-pycor view)
 367    :patch-size (view-patch-size view))))
 368
 369 (defun widget-globals (model)
 370  "WIDGET-GLOBALS MODEL => GLOBALS
 371
 372   GLOBALS: GLOBAL*
 373   GLOBAL: (NAME DEFAULT)
 374
 375 ARGUMENTS AND VALUES:
 376
 377   MODEL: A valid model
 378   NAME: A symbol interned in the keyworkd package
 379   DEFAULT: The widget default value
 380
 381 DESCRIPTION:
 382
 383   Returns the globals that get declared in the model from widgets.
 384   They are interned in the keyword package package set for clnl, so
 385   that they can later be used for multiple purposes."
 386  (remove nil
 387   (mapcar
 388    (lambda (widget)
 389     (typecase widget
 390      (slider (list (intern (string-upcase (slider-varname widget)) :keyword) (slider-default widget)))
 391      (switch (list (intern (string-upcase (switch-varname widget)) :keyword) (switch-on widget)))))
 392    (model-interface model))))
 393
 394 (defun buttons (model)
 395  "BUTTONS MODEL => BUTTON-DEFS
 396
 397   BUTTON-DEFS: BUTTON-DEF*
 398   BUTTON-DEF: (:left LEFT :top TOP :height HEIGHT :width WIDTH :forever FOREVER :display DISPLAY)
 399
 400 ARGUMENTS AND VALUES:
 401
 402   MODEL: A valid model
 403   LEFT: An integer representing the left position
 404   TOP: An integer representing the top position
 405   HEIGHT: An integer representing height
 406   WIDTH: An integer representing width
 407   FOREVER: A boolean representing whether this button is a forever button
 408   DISPLAY: A string representing display name
 409
 410 DESCRIPTION:
 411
 412   Returns button definitions that get declared in the buttons of the
 413   MODEL.  This is used to initialize the interface."
 414  (remove nil
 415   (mapcar
 416    (lambda (widget)
 417     (typecase widget
 418      (button
 419       (list
 420        :left (button-left widget)
 421        :top (button-top widget)
 422        :width (- (button-right widget) (button-left widget))
 423        :height (- (button-bottom widget) (button-top widget))
 424        :forever (button-forever widget)
 425        :display (button-display-name widget)))))
 426    (model-interface model))))
 427
 428 (defun switches (model)
 429  "SWITCHES MODEL => SWITCH-DEFS
 430
 431   SWITCH-DEFS: SWITCH-DEF*
 432   SWITCH-DEF: (:left LEFT :top TOP :width WIDTH :var VAR :display DISPLAY :initial-value INITIAL-VALUE)
 433
 434 ARGUMENTS AND VALUES:
 435
 436   MODEL: A valid model
 437   LEFT: An integer representing the left position
 438   TOP: An integer representing the top position
 439   WIDTH: An integer representing width
 440   VAR: A symbole representing variable
 441   DISPLAY: A string representing variable name
 442   INITIAL-VALUE: The initial value
 443
 444 DESCRIPTION:
 445
 446   Returns switch definitions that get declared in the switches of the
 447   MODEL.  This is used to initialize the interface."
 448  (remove nil
 449   (mapcar
 450    (lambda (widget)
 451     (typecase widget
 452      (switch
 453       (list
 454        :left (switch-left widget)
 455        :top (switch-top widget)
 456        :width (- (switch-right widget) (switch-left widget))
 457        :var (intern (string-upcase (switch-varname widget)) :keyword)
 458        :display (switch-varname widget)
 459        :initial-value (switch-on widget) ))))
 460    (model-interface model))))
 461
 462 (defun view (model)
 463  "VIEW MODEL => VIEW-DEF
 464
 465   VIEW-DEF: (:left LEFT :top TOP)
 466
 467 ARGUMENTS AND VALUES:
 468
 469   MODEL: A valid model
 470   LEFT: An integer representing the left position
 471   TOP: An integer representing the top position
 472
 473 DESCRIPTION:
 474
 475   Returns the view definition that get declared in the view of the
 476   MODEL.  This is used to initialize the interface."
 477  (let
 478   ((view (find-if #'view-p (model-interface model))))
 479   (list :left (view-left view) :top (view-top view))))
 480
 481 (defun code (model)
 482  "CODE MODEL => CODE
 483
 484 ARGUMENTS AND VALUES:
 485
 486   MODEL: A valid model
 487   CODE: The string representing the netlogo code in this model
 488
 489 DESCRIPTION:
 490
 491   Returns the code from the model."
 492  (model-code model))
 493
 494 ; This should get cached eventually, though maybe just cached via a display list is good enough
 495 (defun button-display-name (button)
 496  (or
 497   (button-display button)
 498   (cl-ppcre:regex-replace-all "\\s+" (button-code button) " ")))
 499
 500 (defun unescape-code (code)
 501  (with-output-to-string (out)
 502   (with-input-from-string (in code)
 503    (loop
 504     :for c := (read-char in nil)
 505     :while c
 506     :for aux := (when (eql #\\ c)
 507                  (case (read-char in)
 508                   (#\n #\Newline)
 509                   (#\r #\Return)
 510                   (#\t #\Tab)
 511                   (#\\ #\\)
 512                   (#\" #\")
 513                   (t (error "Invalid escape sequence"))))
 514     :do (write-char (or aux c) out)))))
 515