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

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