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