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

   1 (in-package #:clnl-model)
   2
   3 (defvar *separator* "@#$#@#$#@")
   4
   5 (defstruct model
   6  code
   7  interface
   8  info
   9  turtle-shapes
  10  version
  11  preview-commands
  12  system-dynamics
  13  behavior-space
  14  hub-net-client
  15  link-shapes
  16  model-settings
  17  delta-tick)
  18
  19 (defun read-from-nlogo (str)
  20  "READ-FROM-NLOGO STR => MODEL
  21
  22 ARGUMENTS AND VALUES:
  23
  24   STR: a readable stream
  25   MODEL: an object representing the model
  26
  27 DESCRIPTION:
  28
  29   Takes a stream STR, reads in a nlogo file, parses it, and then
  30   returns the model object."
  31  (let
  32   ((sections
  33     (labels
  34      ((read-sections (&optional section)
  35        (let
  36         ((line (read-line str nil)))
  37         (when line
  38          (if (string= *separator* line)
  39           (cons section (read-sections))
  40           (read-sections (append section (list line))))))))
  41      (read-sections))))
  42   (make-model
  43    :code (nth 0 sections)
  44    :interface (parse-interface (nth 1 sections))
  45    :info (nth 2 sections)
  46    :turtle-shapes (nth 3 sections)
  47    :version (nth 4 sections)
  48    :preview-commands (nth 5 sections)
  49    :system-dynamics (nth 6 sections)
  50    :behavior-space (nth 7 sections)
  51    :hub-net-client (nth 8 sections)
  52    :link-shapes (nth 9 sections)
  53    :model-settings (nth 10 sections)
  54    :delta-tick (nth 11 sections))))
  55
  56 ;;; INTERFACE PARSER
  57
  58 (defparameter *widget-parsers* nil)
  59
  60 (defmacro defwidget-definition (type &rest definitions)
  61  (let
  62   ((lines (gensym)))
  63   `(progn
  64     (defstruct ,type
  65      ,@(remove nil
  66         (mapcar
  67          (lambda (def) (when (find (car def) (list :int :double :boolean :choice :string)) (second def)))
  68          definitions)))
  69     (push
  70      (list
  71       (lambda (,lines)
  72        (and
  73         ,@(remove nil
  74            (mapcar
  75             (lambda (def n)
  76              (let
  77               ((line `(nth ,n ,lines)))
  78               (case (car def)
  79                (:specified `(string= ,(second def) ,line))
  80                (:int `(parse-integer ,line :junk-allowed t))
  81                (:double `(ignore-errors (coerce (read-from-string ,line) 'double-float)))
  82                (:boolean `(or (string= "1" ,line) (string= "0" ,line)))
  83                (:choice `(find ,line ',(mapcar #'car (third def)) :test #'string=)))))
  84             definitions
  85             (loop for i to (length definitions) collect i)))))
  86       (lambda (,lines)
  87        (,(read-from-string (format nil "make-~A" type))
  88         ,@(apply #'append
  89            (mapcar
  90             (lambda (def n)
  91              (let*
  92               ((line `(nth ,n ,lines))
  93                (val-getter
  94                 (case (car def)
  95                  (:int `(parse-integer ,line))
  96                  (:double `(coerce (read-from-string ,line) 'double-float))
  97                  (:boolean `(string= "1" ,line))
  98                  (:choice `(cadr (find ,line ',(third def) :key #'car :test #'string=)))
  99                  (:string line))))
 100               (when val-getter (list (intern (symbol-name (cadr def)) :keyword) val-getter))))
 101             definitions
 102             (loop for i to (length definitions) collect i))))))
 103      *widget-parsers*))))
 104
 105 (defwidget-definition view
 106  (:specified "GRAPHICS-WINDOW")
 107  (:int left)
 108  (:int top)
 109  (:int right)
 110  (:int bottom)
 111  (:reserved "-1")
 112  (:reserved "-1")
 113  (:double patch-size)
 114  (:reserved)
 115  (:int font-size)
 116  (:reserved)
 117  (:reserved)
 118  (:reserved)
 119  (:reserved)
 120  (:boolean wrapping-allowed-in-x)
 121  (:boolean wrapping-allowed-in-y)
 122  (:reserved)
 123  (:int min-pxcor)
 124  (:int max-pxcor)
 125  (:int min-pycor)
 126  (:int max-pycor)
 127  (:choice update-mode (("0" :continuous) ("1" :tick-based)))
 128  (:dump update-mode)
 129  (:boolean show-tick-counter)
 130  (:string tick-counter-label)
 131  (:double frame-rate 30))
 132
 133 (defun parse-interface (interface-as-strings)
 134  (let
 135   ((widgets-as-strings
 136     (labels
 137      ((separate-widgets-as-strings (lines &optional widget-as-strings)
 138        (when lines
 139         (if (string= "" (car lines))
 140          (cons widget-as-strings (separate-widgets-as-strings (cdr lines)))
 141          (separate-widgets-as-strings (cdr lines) (append widget-as-strings (list (car lines))))))))
 142      (separate-widgets-as-strings interface-as-strings))))
 143   (remove
 144    nil
 145    (mapcar
 146     (lambda (widget-as-strings)
 147      (let
 148       ((parser (find-if (lambda (validator) (funcall validator widget-as-strings)) *widget-parsers* :key #'car)))
 149       (when parser (funcall (cadr parser) widget-as-strings))))
 150     widgets-as-strings))))