s-expression-syntax diagram example

diagram.lisp

(cl:defpackage #:s-expression-syntax.examples.diagram
  (:use
   #:cl))

(cl:in-package #:s-expression-syntax.examples.diagram)

;;; We parse a given expression and format it as a tree. As you can
;;; see, we need three helper functions: 1) draw a given node 2)
;;; compute the children of a given node 3) draw a relation as an edge
;;; between a parent node and a child node.
(defun parse-and-format-result-tree (expression stream &key (syntax t)
                                                            recursive)
  (clim:with-room-for-graphics (stream :first-quadrant nil)
    (let* ((builder      'list)
           (tree         (s-expression-syntax:parse builder syntax expression))
           (*print-case* :downcase)
           (record       (clim:format-graph-from-root
                          (list nil tree :compound nil) ; (RELATION NODE EVALUATION HIGHLIGHTP)
                          (node-printer builder) (child-generator builder recursive)
                          :arc-drawer #'draw-relation-edge
                          :graph-type :directed-graph :merge-duplicates t :orientation :vertical
                          :stream stream)))
      (clim:with-bounding-rectangle* (:y1 y1 :x2 x2) record
        (setf (clim:stream-cursor-position stream) (values (+ x2 20) y1))
        (format-legend stream)))))

(defun parsed-p (node)
  (typep node '(cons (not (eql :unparsed))))) ; HACK for recognizing (un)parsed expressions


(defun format-result-tree (builder tree stream &key recursive)
  (clim:with-room-for-graphics (stream :first-quadrant nil)
    (let* ((*print-case* :downcase)
           (record       (clim:format-graph-from-root
                          (list nil tree :compound nil) ; (RELATION NODE EVALUATION HIGHLIGHTP)
                          (node-printer builder) (child-generator builder recursive)
                          :arc-drawer #'draw-relation-edge
                          :graph-type :directed-graph :merge-duplicates t :orientation :vertical
                          :stream stream)))
      (clim:with-bounding-rectangle* (:y1 y1 :x2 x2) record
        (setf (clim:stream-cursor-position stream) (values (+ x2 20) y1))
        (format-legend stream)))))

(defun node-printer (builder)
  ;; This prints a single result node either as a node kind with a
  ;; tablular display of its initargs if the node is parsed or as a
  ;; "raw" expression if the node is not parsed. Due to the way the
  ;; CLIM graph formatter works, the node is represented as a list
  ;; (RELATION NODE EVALUATION HIGHLIGHT) but this function only
  ;; considers the NODE.
  (lambda (node* stream)
    (destructuring-bind (relation node evaluation highlightp) node*
      (declare (ignore relation))
      (clim:surrounding-output-with-border
          (stream :shape          :rectangle
                  :ink            clim:+gray50+
                  :line-thickness 2
                  :line-dashes    (case evaluation
                                    ((t)       nil)
                                    ((nil)     '(8 8))
                                    (:compound '(2 2))
                                    (t         '(8 8)))
                  :background     (if highlightp
                                      clim:+beige+
                                      clim:+white+))
        (flet ((draw ()
                 (let ((kind     (architecture.builder-protocol:node-kind
                                  builder node))
                       (initargs (architecture.builder-protocol:node-initargs
                                  builder node)))
                   (clim:with-drawing-options (stream :text-face :bold)
                     (princ kind stream))
                   (unless (null initargs)
                     (terpri stream)
                     (clim:indenting-output (stream '(1 :character))
                       (clim:with-drawing-options (stream :text-size :small)
                         (clim:formatting-table (stream)
                           (loop :for (key value) :on initargs :by #'cddr
                                 :do (clim:formatting-row (stream)
                                       (clim:formatting-cell (stream :align-y :top)
                                         (princ key stream))
                                       (clim:formatting-cell (stream)
                                         (clim:with-drawing-options (stream :ink         clim:+steel-blue+
                                                                            :text-family :fix)
                                           (prin1 value stream))))))))))))
          (cond ((not (parsed-p node))
                 ;; NODE is an unparsed part of the original EXPRESSION.
                 (clim:with-drawing-options (stream :ink         clim:+forest-green+
                                                    :text-family :fix
                                                    :text-size   :small)
                   (draw)
                                        ; (prin1 node stream)
                   ))
                ((not (member evaluation '(t nil :compound))) ; bindings etc.
                 (clim:with-drawing-options (stream :ink clim:+firebrick+)
                   (draw)))
                (t
                 (draw))))))))

(defun child-generator (builder recursive)
  ;; Compute the children of a given node by iterating through all
  ;; relations of that node and collecting all nodes at the "other
  ;; end" of those relations. In order to allow the relation edge
  ;; drawer to label edges with the relation name, we collect children
  ;; in the form (RELATION CHILD EVALUATION HIGHLIGHT).
  (lambda (node*)
    (destructuring-bind (relation node evaluation highlightp) node*
      (declare (ignore relation evaluation highlightp))
      (loop :for relation* :in (architecture.builder-protocol:node-relations
                                builder node)
            :for (relation . cardinality) = relation*
            :for (node-or-nodes relation-arg-or-args)
               = (multiple-value-list
                  (architecture.builder-protocol:node-relation
                   builder relation* node))
            :for (nodes relation-args)
               = (ecase cardinality
                   (1 (list (list node-or-nodes) (list relation-arg-or-args)))
                   (* (list node-or-nodes (or relation-arg-or-args
                                              (make-list (length node-or-nodes))))))
            :append (mapcar (lambda (node args)
                              (let* ((evaluation (getf args :evaluation ; TODO :semantics
                                                       ))
                                     (evaluated? (eq evaluation t)))
                                (list relation
                                      (if (and recursive evaluated?)
                                          (progn
                                            ; (break "~S" node)
                                            (assert (eq (architecture.builder-protocol:node-kind builder node) :unparsed))
                                            (s-expression-syntax:parse builder t (getf (architecture.builder-protocol:node-initargs builder node) :expression))
                                            #+old (s-expression-syntax:parse builder t (getf node :expression)))
                                          node)
                                      evaluation
                                      (and recursive evaluated?))))
                            nodes relation-args)))))

(defun draw-relation-edge (stream from-node to-node x1 y1 x2 y2)
  (declare (ignore from-node))
  (destructuring-bind (relation node evaluation highlightp)
      (clim:graph-node-object to-node)
    (declare (ignore node evaluation highlightp))
    (clim:draw-arrow* stream x1 y1 x2 y2
                      :ink clim:+dark-orange+ :head-filled t)
    (clim:draw-text* stream (string-downcase relation)
                     (/ (+ x1 x2) 2) (/ (+ y1 y2) 2)
                     :align-x (if (< x2 x1) :right :left)
                     :ink clim:+dark-orange+ :text-size :smaller)))


(defun format-legend (stream)
  (clim:formatting-table (stream)
    (flet ((entry (dashes ink evaluated parsed)
             (clim:formatting-row (stream)
               (clim:formatting-cell (stream :align-y :center)
                 (clim:surrounding-output-with-border (stream :shape          :rectangle
                                                              :ink            clim:+gray50+
                                                              :line-thickness 2
                                                              :line-dashes    dashes)
                   (clim:with-drawing-options (stream :ink ink)
                     (write-string "x" stream))))
               (clim:formatting-cell (stream :align-x :center :align-y :center)
                 (write-string evaluated stream))
               (clim:formatting-cell (stream :align-x :center :align-y :center)
                 (write-string parsed stream)))))
      (entry nil    clim:+foreground-ink+ "evaluated"   "parsed")
      (entry '(8 8) clim:+foreground-ink+ "unevaluated" "parsed")
      (entry '(2 2) clim:+foreground-ink+ "mixed"       "parsed")
      (entry nil    clim:+forest-green+   "evaluated"   "unparsed")
      (entry '(8 8) clim:+forest-green+   "unevaluated" "unparsed")
      (entry '(2 2) clim:+forest-green+   "mixed"       "unparsed")
      (entry '(8 8) clim:+firebrick+      "binding"     ""))))