code.consxy.com Git - clnl/blob - src/main/clnl/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 (defwidget-definition textbox
 252  (:specified "TEXTBOX")
 253  (:int left)
 254  (:int top)
 255  (:int right)
 256  (:int bottom)
 257  (:code display) ; We use code here because the original netlogo treats this display like it does code
 258  (:int font-size)
 259  (:double color)
 260  (:boolean transparent))
 261
 262 (defun parse-interface (interface-as-strings)
 263  (let
 264   ((widgets-as-strings
 265     (labels
 266      ((separate-widgets-as-strings (lines &optional widget-as-strings)
 267        (when lines
 268         (if (string= "" (car lines))
 269          (cons widget-as-strings (separate-widgets-as-strings (cdr lines)))
 270          (separate-widgets-as-strings (cdr lines) (append widget-as-strings (list (car lines))))))))
 271      (separate-widgets-as-strings interface-as-strings))))
 272   (remove
 273    nil
 274    (mapcar
 275     (lambda (widget-as-strings)
 276      (let
 277       ((parser (find-if (lambda (validator) (funcall validator widget-as-strings)) *widget-parsers* :key #'car)))
 278       (when parser (funcall (cadr parser) widget-as-strings))))
 279     widgets-as-strings))))
 280
 281 (defun find-button (name idx)
 282  (nth
 283   idx
 284   (remove-if-not
 285    (lambda (widget) (and (button-p widget) (string= (button-display-name widget) name)))
 286    *current-interface*)))
 287
 288 ; With authoring, idx here needs to be looked at again.
 289 (defun execute-button (name &optional (idx 0))
 290  "EXECUTE-BUTTON NAME &optional IDX => RESULT
 291
 292 ARGUMENTS AND VALUES:
 293
 294   NAME: the name of the button
 295   IDX: the instance of the button, defaults to 0
 296   RESULT: undefined
 297
 298 DESCRIPTION:
 299
 300   Executes the code in the button referenced by NAME and IDX.
 301
 302   NAME refers to the display name for the button, which is usually
 303   set by the model, but sometimes defaults to the code inside.
 304
 305   Because NAME is not guaranteed to be unique, IDX is available
 306   as a specifier.  The index is in the order that the buttons are
 307   loaded, and cannot be guaranteed to be stable from run to run."
 308  (when *current-callback*
 309   (let
 310    ((button (find-button name (round idx))))
 311    (cond
 312     ((not button) (error "Couldn't find button with name ~A (idx: ~A)" name idx))
 313     ((and (button-forever button) (find button *enabled-forever-buttons* :test #'equal))
 314      (setf *enabled-forever-buttons* (remove button *enabled-forever-buttons* :test #'equal)))
 315     ((button-forever button)
 316      (setf *enabled-forever-buttons* (cons button *enabled-forever-buttons*))
 317      (sb-thread:make-thread
 318       (lambda ()
 319        (loop
 320         :while (find button *enabled-forever-buttons* :test #'equal)
 321         ; The sleep is necessary so that it gives other threads time
 322         :do
 323         (let
 324          ((result (funcall *current-callback* (button-code button))))
 325          (when (eql :stop result)
 326           (setf *enabled-forever-buttons* (remove button *enabled-forever-buttons* :test #'equal)))
 327          (sleep .001))))
 328       :name (format nil "Forever button: ~A" (button-display button))))
 329     (t (funcall *current-callback* (button-code button)))))))
 330
 331 (defun forever-button-on (name &optional (idx 0))
 332  "FOREVER-BUTTON-ON NAME &optional IDX => ON
 333
 334 ARGUMENTS AND VALUES:
 335
 336   NAME: the name of the button
 337   IDX: the instance of the button, defaults to 0
 338   ON: a boolean
 339
 340 DESCRIPTION:
 341
 342   Returns whether the button identified by NAME and IDX is currently on.
 343
 344   NAME refers to the display name for the button, which is usually
 345   set by the model, but sometimes defaults to the code inside.
 346
 347   Because NAME is not guaranteed to be unique, IDX is available
 348   as a specifier.  The index is in the order that the buttons are
 349   loaded, and cannot be guaranteed to be stable from run to run."
 350  (and (find (find-button name (round idx)) *enabled-forever-buttons* :test #'equal) t))
 351
 352 ;; INFORMATION ABOUT MODEL
 353
 354 (defun world-dimensions (model)
 355  "WORLD-DIMENSIONS MODEL => DIMS
 356
 357   DIMS: (:xmin XMIN :xmax XMAX :ymin YMIN :ymax YMAX)
 358
 359 ARGUMENTS AND VALUES:
 360
 361   MODEL: A valid model containing a view
 362   XMIN: An integer representing the minimum patch coord in X
 363   XMAX: An integer representing the maximum patch coord in X
 364   YMIN: An integer representing the minimum patch coord in Y
 365   YMAX: An integer representing the maximum patch coord in Y
 366
 367 DESCRIPTION:
 368
 369   Returns the dimensions of MODEL.  MODEL must be a valid model
 370   as parsed by CLNL, and have a valid view in it."
 371  (let
 372   ((view (find-if #'view-p (model-interface model))))
 373   (list
 374    :xmin (view-min-pxcor view)
 375    :xmax (view-max-pxcor view)
 376    :ymin (view-min-pycor view)
 377    :ymax (view-max-pycor view)
 378    :patch-size (view-patch-size view))))
 379
 380 (defun widget-globals (model)
 381  "WIDGET-GLOBALS MODEL => GLOBALS
 382
 383   GLOBALS: GLOBAL*
 384   GLOBAL: (NAME DEFAULT)
 385
 386 ARGUMENTS AND VALUES:
 387
 388   MODEL: A valid model
 389   NAME: A symbol interned in the keyworkd package
 390   DEFAULT: The widget default value
 391
 392 DESCRIPTION:
 393
 394   Returns the globals that get declared in the model from widgets.
 395   They are interned in the keyword package package set for clnl, so
 396   that they can later be used for multiple purposes."
 397  (remove nil
 398   (mapcar
 399    (lambda (widget)
 400     (typecase widget
 401      (slider (list (intern (string-upcase (slider-varname widget)) :keyword) (slider-default widget)))
 402      (switch (list (intern (string-upcase (switch-varname widget)) :keyword) (switch-on widget)))))
 403    (model-interface model))))
 404
 405 (defun buttons (model)
 406  "BUTTONS MODEL => BUTTON-DEFS
 407
 408   BUTTON-DEFS: BUTTON-DEF*
 409   BUTTON-DEF: (:left LEFT :top TOP :height HEIGHT :width WIDTH :forever FOREVER :display DISPLAY)
 410
 411 ARGUMENTS AND VALUES:
 412
 413   MODEL: A valid model
 414   LEFT: An integer representing the left position
 415   TOP: An integer representing the top position
 416   HEIGHT: An integer representing height
 417   WIDTH: An integer representing width
 418   FOREVER: A boolean representing whether this button is a forever button
 419   DISPLAY: A string representing display name
 420
 421 DESCRIPTION:
 422
 423   Returns button definitions that get declared in the buttons of the
 424   MODEL.  This is used to initialize the interface."
 425  (remove nil
 426   (mapcar
 427    (lambda (widget)
 428     (typecase widget
 429      (button
 430       (list
 431        :left (button-left widget)
 432        :top (button-top widget)
 433        :width (- (button-right widget) (button-left widget))
 434        :height (- (button-bottom widget) (button-top widget))
 435        :forever (button-forever widget)
 436        :display (button-display-name widget)))))
 437    (model-interface model))))
 438
 439 (defun textboxes (model)
 440  "TEXTBOXES MODEL => TEXTBOX-DEFS
 441
 442   TEXTBOX-DEFS: TEXTBOX-DEF*
 443   TEXTBOX-DEF: (:left LEFT :top TOP :height HEIGHT :width WIDTH :display DISPLAY)
 444
 445 ARGUMENTS AND VALUES:
 446
 447   MODEL: A valid model
 448   LEFT: An integer representing the left position
 449   TOP: An integer representing the top position
 450   HEIGHT: An integer representing height, in characters
 451   WIDTH: An integer representing width, in characters
 452   DISPLAY: A string representing display name
 453
 454 DESCRIPTION:
 455
 456   Returns textbox definitions that get declared in the textboxes of the
 457   MODEL.  This is used to initialize the interface."
 458  (remove nil
 459   (mapcar
 460    (lambda (widget)
 461     (typecase widget
 462      (textbox
 463       (list
 464        :left (textbox-left widget)
 465        :top (textbox-top widget)
 466        :width (truncate (- (textbox-right widget) (textbox-left widget)) clnl-gltk:*font-width*)
 467        :height (truncate (- (textbox-bottom widget) (textbox-top widget)) clnl-gltk:*font-height*)
 468        :display (textbox-display widget)))))
 469    (model-interface model))))
 470
 471 (defun switches (model)
 472  "SWITCHES MODEL => SWITCH-DEFS
 473
 474   SWITCH-DEFS: SWITCH-DEF*
 475   SWITCH-DEF: (:left LEFT :top TOP :width WIDTH :var VAR :display DISPLAY :initial-value INITIAL-VALUE)
 476
 477 ARGUMENTS AND VALUES:
 478
 479   MODEL: A valid model
 480   LEFT: An integer representing the left position
 481   TOP: An integer representing the top position
 482   WIDTH: An integer representing width
 483   VAR: A symbole representing variable
 484   DISPLAY: A string representing variable name
 485   INITIAL-VALUE: The initial value
 486
 487 DESCRIPTION:
 488
 489   Returns switch definitions that get declared in the switches of the
 490   MODEL.  This is used to initialize the interface."
 491  (remove nil
 492   (mapcar
 493    (lambda (widget)
 494     (typecase widget
 495      (switch
 496       (list
 497        :left (switch-left widget)
 498        :top (switch-top widget)
 499        :width (- (switch-right widget) (switch-left widget))
 500        :var (intern (string-upcase (switch-varname widget)) :keyword)
 501        :display (switch-varname widget)
 502        :initial-value (switch-on widget) ))))
 503    (model-interface model))))
 504
 505 (defun sliders (model)
 506  "SLIDERS MODEL => SLIDER-DEFS
 507
 508   SLIDER-DEFS: SLIDER-DEF*
 509   SLIDER-DEF: (:left LEFT :top TOP :width WIDTH :var VAR :display DISPLAY :initial-value INITIAL-VALUE)
 510
 511 ARGUMENTS AND VALUES:
 512
 513   MODEL: A valid model
 514   LEFT: An integer representing the left position
 515   TOP: An integer representing the top position
 516   WIDTH: An integer representing width
 517   VAR: A symbole representing variable
 518   DISPLAY: A string representing variable name
 519   INITIAL-VALUE: The initial value
 520
 521 DESCRIPTION:
 522
 523   Returns slider definitions that get declared in the sliders of the
 524   MODEL.  This is used to initialize the interface."
 525  (remove nil
 526   (mapcar
 527    (lambda (widget)
 528     (typecase widget
 529      (slider
 530       (list
 531        :left (slider-left widget)
 532        :top (slider-top widget)
 533        :width (- (slider-right widget) (slider-left widget))
 534        :var (intern (string-upcase (slider-varname widget)) :keyword)
 535        :display (slider-varname widget)
 536        :min (slider-min widget)
 537        :max (slider-max widget)
 538        :step (slider-step widget)
 539        :initial-value (slider-default widget)))))
 540    (model-interface model))))
 541
 542 (defun view (model)
 543  "VIEW MODEL => VIEW-DEF
 544
 545   VIEW-DEF: (:left LEFT :top TOP)
 546
 547 ARGUMENTS AND VALUES:
 548
 549   MODEL: A valid model
 550   LEFT: An integer representing the left position
 551   TOP: An integer representing the top position
 552
 553 DESCRIPTION:
 554
 555   Returns the view definition that get declared in the view of the
 556   MODEL.  This is used to initialize the interface."
 557  (let
 558   ((view (find-if #'view-p (model-interface model))))
 559   (list :left (view-left view) :top (view-top view))))
 560
 561 (defun code (model)
 562  "CODE MODEL => CODE
 563
 564 ARGUMENTS AND VALUES:
 565
 566   MODEL: A valid model
 567   CODE: The string representing the netlogo code in this model
 568
 569 DESCRIPTION:
 570
 571   Returns the code from the model."
 572  (model-code model))
 573
 574 ; This should get cached eventually, though maybe just cached via a display list is good enough
 575 (defun button-display-name (button)
 576  (or
 577   (button-display button)
 578   (cl-ppcre:regex-replace-all "\\s+" (button-code button) " ")))
 579
 580 (defun unescape-code (code)
 581  (with-output-to-string (out)
 582   (with-input-from-string (in code)
 583    (loop
 584     :for c := (read-char in nil)
 585     :while c
 586     :for aux := (when (eql #\\ c)
 587                  (case (read-char in)
 588                   (#\n #\Newline)
 589                   (#\r #\Return)
 590                   (#\t #\Tab)
 591                   (#\\ #\\)
 592                   (#\" #\")
 593                   (t (error "Invalid escape sequence"))))
 594     :do (write-char (or aux c) out)))))