construct-implicit-arcs.lisp

(defun make-net/1/construct-implicit-arcs (net)
  (with-accessors+ (objects places transitions arcs next-guid)
      net
    (maphash (lambda (name transition)
               ;; initial value of in-arcs is a LIST of NAMES of places that this transition will be fed from
               (let (arc-names)
                 (dolist (in-arc (in-arcs transition))
                   (if (symbolp in-arc)
                       ;; if the in-arc form is a single symbol, then it names the place to be connected to, anonymous arc, single token
                       (let* ((from-place-name in-arc)
                              (id (incf next-guid))
                              (arc (make-instance 'arc :input from-place-name :output name :tokens 1 :name id)))
                         (insert-new arcs id arc)
                         (insert-new objects id arc)
                         (push id arc-names))
                       (destructuring-bind (from-place-name &optional tokens arc-name)
                           in-arc
                         (let* ((name (or arc-name (incf next-guid)))
                                (arc (make-instance 'arc :input from-place-name :output name :tokens tokens :name name)))
                           (insert-new arcs name arc)
                           (insert-new objects name arc)
                           (push name arc-names))))
                   (setf (in-arcs transition) (nreverse arc-names))))
               (let (arc-names)
                 (dolist (out-arc (out-arcs transition))
                   (if (symbolp out-arc)
                       ;; if the in-arc form is a single symbol, then it names the place to be connected to, anonymous arc, single token
                       (let* ((to-place-name out-arc)
                              (id (incf next-guid))
                              (arc (make-instance 'arc :input name :output to-place-name :tokens 1 :name id)))
                         (insert-new arcs id arc)
                         (insert-new objects id arc)
                         (push id arc-names))
                       (destructuring-bind (to-place-name &optional tokens arc-name)
                           out-arc
                         (let* ((name (or arc-name (incf next-guid)))
                                (arc (make-instance 'arc :input name :output to-place-name :tokens tokens :name name)))
                           (insert-new arcs name arc)
                           (insert-new objects name arc)
                           (push name arc-names))))
                   (setf (out-arcs transition) (nreverse arc-names))))) transitions)
    net))