Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv17742
Modified Files: slidemacs-gui.lisp slidemacs.lisp Log Message: Graph formatting for Slidemacs!
Date: Wed Jun 15 03:39:46 2005 Author: bmastenbrook
Index: climacs/slidemacs-gui.lisp diff -u climacs/slidemacs-gui.lisp:1.7 climacs/slidemacs-gui.lisp:1.8 --- climacs/slidemacs-gui.lisp:1.7 Wed Jun 15 01:14:18 2005 +++ climacs/slidemacs-gui.lisp Wed Jun 15 03:39:46 2005 @@ -91,12 +91,13 @@ (defparameter *slidemacs-sizes* '(:title 64 :bullet 32 + :graph-node 16 :slideset-title 48 :slideset-info 32))
(defmethod display-parse-tree ((parse-tree slideset-info) (syntax slidemacs-gui-syntax) pane) (with-slots (point) pane - (with-text-style (pane `(:serif :bold ,(getf *slidemacs-sizes* :slideset-title))) + (with-text-style (pane `(:sans-serif :bold ,(getf *slidemacs-sizes* :slideset-title))) (display-text-with-wrap-for-pane *current-slideset* pane) (terpri pane)) @@ -108,19 +109,19 @@ (display-parse-tree opt-slide-date syntax pane))))
(defmethod display-parse-tree ((entity slide-author) (syntax slidemacs-gui-syntax) pane) - (with-text-style (pane `(:serif :roman ,(getf *slidemacs-sizes* :slideset-info))) + (with-text-style (pane `(:sans-serif :roman ,(getf *slidemacs-sizes* :slideset-info))) (with-slots (author) entity (display-text-with-wrap-for-pane (slidemacs-entity-string author) pane))))
(defmethod display-parse-tree ((entity slide-institution) (syntax slidemacs-gui-syntax) pane) - (with-text-style (pane `(:serif :roman ,(getf *slidemacs-sizes* :slideset-info))) + (with-text-style (pane `(:sans-serif :roman ,(getf *slidemacs-sizes* :slideset-info))) (with-slots (institution) entity (display-text-with-wrap-for-pane (slidemacs-entity-string institution) pane))))
(defmethod display-parse-tree ((entity slide-venue) (syntax slidemacs-gui-syntax) pane) - (with-text-style (pane `(:serif :roman ,(getf *slidemacs-sizes* :slideset-info))) + (with-text-style (pane `(:sans-serif :roman ,(getf *slidemacs-sizes* :slideset-info))) (with-slots (venue) entity (display-text-with-wrap-for-pane (slidemacs-entity-string venue) pane)))) @@ -137,7 +138,7 @@ year)))
(defmethod display-parse-tree ((entity slide-date) (syntax slidemacs-gui-syntax) pane) - (with-text-style (pane `(:serif :roman ,(getf *slidemacs-sizes* :slideset-info))) + (with-text-style (pane `(:sans-serif :roman ,(getf *slidemacs-sizes* :slideset-info))) (with-slots (opt-date-string) entity (if (typep (slot-value opt-date-string 'item) 'empty-slidemacs-terminals) @@ -156,15 +157,83 @@ (display-parse-tree slidemacs-slide-name syntax pane) (display-parse-tree nonempty-list-of-bullets syntax pane)))))
+(defun traverse-list-entry (list-entry unit-type function) + (when (and + (slot-exists-p list-entry 'items) + (slot-exists-p list-entry 'item) + (typep (slot-value list-entry 'item) unit-type)) + (funcall function (slot-value list-entry 'item)) + (traverse-list-entry (slot-value list-entry 'items) unit-type function))) + +(defmethod display-parse-tree ((parse-tree slidemacs-graph-slide) (syntax slidemacs-gui-syntax) pane) + (with-slots (point) pane + (when (and (mark>= point (start-offset parse-tree)) + (mark<= point (end-offset parse-tree))) + (when (boundp '*did-display-a-slide*) + (setf *did-display-a-slide* t)) + (with-slots (slidemacs-slide-name list-of-roots list-of-edges) + parse-tree + (display-parse-tree slidemacs-slide-name syntax pane) + (let (roots edges italic) + (traverse-list-entry + list-of-roots 'graph-root + (lambda (entry) + (with-slots (vertex-name) entry + (with-slots (slidemacs-string) vertex-name + (with-slots (item) slidemacs-string + (when (typep item 'slidemacs-italic-string) + (pushnew (slidemacs-entity-string vertex-name) italic :test #'equal)))) + (pushnew (slidemacs-entity-string vertex-name) roots + :test #'equal)))) + (traverse-list-entry + list-of-edges 'graph-edge + (flet ((push-if-italic (thing) + (with-slots (vertex-name) thing + (with-slots (slidemacs-string) vertex-name + (with-slots (item) slidemacs-string + (when (typep item 'slidemacs-italic-string) + (pushnew (slidemacs-entity-string vertex-name) italic :test #'equal))))))) + (lambda (entry) + (with-slots (from-vertex to-vertex) entry + (let ((from (slidemacs-entity-string from-vertex)) + (to (slidemacs-entity-string to-vertex))) + (push-if-italic from-vertex) + (push-if-italic to-vertex) + (pushnew (cons from to) + edges :test #'equal)))))) + (format-graph-from-roots + roots + (lambda (node stream) + (with-text-style (pane `(:sans-serif + ,(if (find node italic :test #'equal) + :italic :roman) + ,(getf *slidemacs-sizes* :graph-node))) + (surrounding-output-with-border (pane :shape :drop-shadow) + (present node 'string :stream stream)))) + (lambda (node) + (loop for edge in edges + if (equal (car edge) node) + collect (cdr edge))) + :orientation :horizontal + :generation-separation "xxxxxx" + :arc-drawer + (lambda (stream obj1 obj2 x1 y1 x2 y2) + (declare (ignore obj1 obj2)) + (draw-arrow* stream x1 y1 x2 y2 :line-thickness 1 :head-length 8 :head-width 4)) + :merge-duplicates t + :duplicate-test #'equal + :graph-type :tree + )))))) + (defmethod display-parse-tree ((entity slidemacs-slide-name) (syntax slidemacs-gui-syntax) pane) - (with-text-style (pane `(:serif :bold ,(getf *slidemacs-sizes* :title))) + (with-text-style (pane `(:sans-serif :bold ,(getf *slidemacs-sizes* :title))) (display-text-with-wrap-for-pane (slidemacs-entity-string entity) pane) (terpri pane)))
(defmethod display-parse-tree ((entity slidemacs-bullet) (syntax slidemacs-gui-syntax) pane) (stream-increment-cursor-position pane (space-width pane) 0) - (with-text-style (pane `(:serif :roman ,(getf *slidemacs-sizes* :bullet))) + (with-text-style (pane `(:sans-serif :roman ,(getf *slidemacs-sizes* :bullet))) (with-slots (point) pane (if (and (mark>= point (start-offset entity)) (mark<= point (end-offset entity))) @@ -178,12 +247,15 @@ (stream-increment-cursor-position pane (space-width pane) 0))
(defmethod display-parse-tree ((entity talking-point) (syntax slidemacs-gui-syntax) pane) - (let* ((bullet-text (coerce (buffer-sequence (buffer syntax) - (1+ (start-offset entity)) - (1- (end-offset entity))) - 'string))) - (display-text-with-wrap-for-pane bullet-text pane) - (terpri pane))) + (with-slots (slidemacs-string) entity + (let ((is-italic (typep (slot-value slidemacs-string 'item) + 'slidemacs-italic-string)) + (bullet-text (slidemacs-entity-string entity))) + (if is-italic + (with-text-face (pane :italic) + (display-text-with-wrap-for-pane bullet-text pane)) + (display-text-with-wrap-for-pane bullet-text pane)) + (terpri pane))))
(defmethod display-parse-tree ((entity slidemacs-entry) (syntax slidemacs-gui-syntax) pane) (with-slots (ink face) entity @@ -219,7 +291,8 @@ (defun talking-point-stop-p (lexeme) (or (typep lexeme 'bullet) (and (typep lexeme 'slidemacs-keyword) - (word-is lexeme "info")))) + (or (word-is lexeme "info") + (word-is lexeme "graph")))))
(climacs-gui::define-named-command com-next-talking-point () (let* ((pane (climacs-gui::current-window))
Index: climacs/slidemacs.lisp diff -u climacs/slidemacs.lisp:1.2 climacs/slidemacs.lisp:1.3 --- climacs/slidemacs.lisp:1.2 Wed Jun 15 01:12:26 2005 +++ climacs/slidemacs.lisp Wed Jun 15 03:39:46 2005 @@ -60,7 +60,7 @@ collect `(defclass ,lexeme (,superclass) ()))))
(define-lexemes slidemacs-lexeme start-lexeme slidemacs-keyword - block-open block-close slidemacs-string bullet other-entry) + block-open block-close slidemacs-quoted-string slidemacs-italic-string bullet other-entry)
(defclass slidemacs-lexer (incremental-lexer) ())
@@ -89,7 +89,13 @@ do (fo)) (unless (end-of-buffer-p scan) (fo)) ; get the closing #" - (make-instance 'slidemacs-string)) + (make-instance 'slidemacs-quoted-string)) + (#/ (loop until (end-of-buffer-p scan) + while (not (eql (object-after scan) #/)) + do (fo)) + (unless (end-of-buffer-p scan) + (fo)) ; get the closing #/ + (make-instance 'slidemacs-italic-string)) (#* bullet) (t (cond ((identifier-char-p object :start t) @@ -237,6 +243,7 @@ (:== slidemacs-slideset slidemacs-slideset-keyword slidemacs-slideset-name block-open slideset-info nonempty-list-of-slides block-close) (:= slidemacs-slideset-keyword "slideset") + (:= slidemacs-string (or slidemacs-quoted-string slidemacs-italic-string)) (:= slidemacs-slideset-name slidemacs-string) (:= slideset-info slideset-info-keyword block-open opt-slide-author opt-slide-institution opt-slide-venue opt-slide-date block-close) (:= slideset-info-keyword "info") @@ -258,7 +265,22 @@ (:= date-keyword "date") (:= date-string slidemacs-string) (:= nonempty-list-of-slides - (nonempty-list-of slidemacs-slide)) + (nonempty-list-of slidemacs-all-slide-types)) + (:= slidemacs-all-slide-types + (or slidemacs-slide slidemacs-graph-slide)) + (:= slidemacs-graph-slide slidemacs-graph-slide-keyword slidemacs-slide-name block-open list-of-roots list-of-edges block-close) + (:= slidemacs-graph-slide-keyword "graph") + (:= list-of-roots (list-of graph-root)) + (:= graph-root graph-root-keyword vertex-name) + (:= graph-root-keyword "root") + (:= list-of-edges (list-of graph-edge)) + (:= graph-edge graph-edge-keyword from-keyword from-vertex to-keyword to-vertex) + (:= graph-edge-keyword "edge") + (:= from-keyword "from") + (:= to-keyword "to") + (:= from-vertex vertex-name) + (:= to-vertex vertex-name) + (:= vertex-name slidemacs-string) (:= slidemacs-slide slidemacs-slide-keyword slidemacs-slide-name block-open nonempty-list-of-bullets block-close) (:= slidemacs-slide-keyword "slide") @@ -270,6 +292,10 @@ (defmethod display-parse-tree ((entity slidemacs-terminal) (syntax slidemacs-editor-syntax) pane) (with-slots (item) entity (display-parse-tree item syntax pane))) + +(defmethod display-parse-tree ((entity slidemacs-italic-string) (syntax slidemacs-editor-syntax) pane) + (with-text-face (pane :italic) + (call-next-method)))
(defmethod display-parse-tree ((entity slidemacs-entry) (syntax slidemacs-editor-syntax) pane) (flet ((cache-test (t1 t2)