Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv25038

Modified Files: gui.lisp slidemacs.lisp slidemacs-gui.lisp Log Message: Current state of slidemacs

Date: Sat Jun 18 04:01:56 2005 Author: bmastenbrook

Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.145 climacs/gui.lisp:1.146 --- climacs/gui.lisp:1.145 Fri Jun 17 12:42:32 2005 +++ climacs/gui.lisp Sat Jun 18 04:01:56 2005 @@ -904,6 +904,13 @@ (psetf (offset (mark pane)) (offset (point pane)) (offset (point pane)) (offset (mark pane)))))

+(defun set-syntax (syntax) + (let* ((pane (current-window)) + (buffer (buffer pane))) + (setf (syntax buffer) syntax) + (setf (offset (low-mark buffer)) 0 + (offset (high-mark buffer)) (size buffer)))) + (define-named-command com-set-syntax () (let* ((pane (current-window)) (buffer (buffer pane)))

Index: climacs/slidemacs.lisp diff -u climacs/slidemacs.lisp:1.3 climacs/slidemacs.lisp:1.4 --- climacs/slidemacs.lisp:1.3 Wed Jun 15 03:39:46 2005 +++ climacs/slidemacs.lisp Sat Jun 18 04:01:56 2005 @@ -245,7 +245,9 @@ (:= 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 slideset-info-keyword block-open author-institution-pairs opt-slide-venue opt-slide-date block-close) + (:= author-institution-pairs (list-of author-institution-pair)) + (:= author-institution-pair slide-author slide-institution) (:= slideset-info-keyword "info") (:= opt-slide-author (or slide-author empty-slidemacs-terminals)) (:= slide-author author-keyword author) @@ -268,7 +270,10 @@ (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 slidemacs-graph-slide-keyword slidemacs-slide-name block-open orientation list-of-roots list-of-edges block-close) + (:= orientation (or horizontal-keyword vertical-keyword)) + (:= horizontal-keyword "horizontal") + (:= vertical-keyword "vertical") (:= slidemacs-graph-slide-keyword "graph") (:= list-of-roots (list-of graph-root)) (:= graph-root graph-root-keyword vertex-name) @@ -285,9 +290,13 @@ nonempty-list-of-bullets block-close) (:= slidemacs-slide-keyword "slide") (:= slidemacs-slide-name slidemacs-string) - (:= nonempty-list-of-bullets (nonempty-list-of slidemacs-bullet)) + (:= nonempty-list-of-bullets (nonempty-list-of slidemacs-bullet-or-picture)) + (:= slidemacs-bullet-or-picture (or slidemacs-bullet picture-node)) (:= slidemacs-bullet bullet talking-point) - (:= talking-point slidemacs-string)) + (:= talking-point slidemacs-string) + (:= picture-node picture-keyword picture-pathname) + (:= picture-keyword "picture") + (:= picture-pathname slidemacs-string))

(defmethod display-parse-tree ((entity slidemacs-terminal) (syntax slidemacs-editor-syntax) pane) (with-slots (item) entity

Index: climacs/slidemacs-gui.lisp diff -u climacs/slidemacs-gui.lisp:1.10 climacs/slidemacs-gui.lisp:1.11 --- climacs/slidemacs-gui.lisp:1.10 Fri Jun 17 03:21:22 2005 +++ climacs/slidemacs-gui.lisp Sat Jun 18 04:01:56 2005 @@ -34,7 +34,6 @@

(defvar *current-slideset*) (defvar *did-display-a-slide*) -(defvar *last-slide-displayed* nil)

(defun slidemacs-entity-string (entity) (coerce (buffer-sequence (buffer entity) @@ -42,6 +41,8 @@ (1- (end-offset entity))) 'string))

+(defparameter *no-check-point* nil) + (defmethod display-parse-tree ((parse-tree slidemacs-slideset) (syntax slidemacs-gui-syntax) pane) (with-slots (slideset-info nonempty-list-of-slides slidemacs-slideset-name) parse-tree (let ((*current-slideset* (slidemacs-entity-string slidemacs-slideset-name)) @@ -50,6 +51,27 @@ (unless *did-display-a-slide* (display-parse-tree slideset-info 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-for-postscript ((parse-tree slidemacs-slideset) (syntax slidemacs-gui-syntax) stream) + (with-slots (slideset-info nonempty-list-of-slides slidemacs-slideset-name) parse-tree + (let ((*current-slideset* (slidemacs-entity-string slidemacs-slideset-name)) + (*did-display-a-slide* nil) + (*no-check-point* t)) + (display-parse-tree slideset-info syntax stream) + (new-page stream) + (traverse-list-entry nonempty-list-of-slides + 'slidemacs-slide + (lambda (slide) + (display-parse-tree slide syntax stream) + (new-page stream)))))) + (defmethod display-parse-tree ((parse-tree slidemacs-slideset-keyword) (syntax slidemacs-gui-syntax) pane) (format *debug-io* "Oops!~%") (call-next-method)) @@ -92,22 +114,20 @@ (defparameter *slidemacs-sizes* '(:title 48 :bullet 32 - :graph-node 16 + :graph-node 14 :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 `(:sans-serif :bold ,(getf *slidemacs-sizes* :slideset-title))) - (display-text-with-wrap-for-pane - *current-slideset* pane) - (terpri pane)) - (with-slots (opt-slide-author opt-slide-institution opt-slide-venue opt-slide-date) - parse-tree - (display-parse-tree opt-slide-author syntax pane) - (display-parse-tree opt-slide-institution syntax pane) - (display-parse-tree opt-slide-venue syntax pane) - (display-parse-tree opt-slide-date syntax pane)))) + (with-text-style (pane `(:sans-serif :bold ,(getf *slidemacs-sizes* :slideset-title))) + (display-text-with-wrap-for-pane + *current-slideset* pane) + (terpri pane)) + (with-slots (author-institution-pairs opt-slide-venue opt-slide-date) + parse-tree + (display-parse-tree author-institution-pairs syntax pane) + (display-parse-tree opt-slide-venue syntax pane) + (display-parse-tree opt-slide-date syntax pane)))

(defmethod display-parse-tree ((entity slide-author) (syntax slidemacs-gui-syntax) pane) (with-text-style (pane `(:sans-serif :roman ,(getf *slidemacs-sizes* :slideset-info))) @@ -121,6 +141,10 @@ (display-text-with-wrap-for-pane (slidemacs-entity-string institution) pane))))

+(defmethod display-parse-tree ((entity author-institution-pair) (syntax slidemacs-gui-syntax) pane) + (call-next-method) + (terpri pane)) + (defmethod display-parse-tree ((entity slide-venue) (syntax slidemacs-gui-syntax) pane) (with-text-style (pane `(:sans-serif :roman ,(getf *slidemacs-sizes* :slideset-info))) (with-slots (venue) entity @@ -148,89 +172,87 @@ (slidemacs-entity-string opt-date-string) pane)))))

(defmethod display-parse-tree ((parse-tree slidemacs-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*) - (when (not (eq *last-slide-displayed* parse-tree)) - (setf *last-slide-displayed* parse-tree) - (window-erase-viewport pane)) - (setf *did-display-a-slide* t)) - (with-slots (slidemacs-slide-name nonempty-list-of-bullets) - parse-tree - (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))) + (when (or *no-check-point* + (with-slots (point) pane + (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 nonempty-list-of-bullets) + parse-tree + (display-parse-tree slidemacs-slide-name syntax pane) + (display-parse-tree nonempty-list-of-bullets syntax pane))))

(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*) - (when (not (eq *last-slide-displayed* parse-tree)) - (setf *last-slide-displayed* parse-tree) - (window-erase-viewport pane)) - (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 + (when (or *no-check-point* + (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 orientation list-of-roots list-of-edges) + parse-tree + (display-parse-tree slidemacs-slide-name syntax pane) + (let (roots edges italic (orientation-val :horizontal)) + (when (typep (slot-value orientation 'item) 'vertical-keyword) + (setf orientation-val :vertical)) + (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 (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 - )))))) + (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)))))) + (let (record) + (with-new-output-record (pane 'standard-sequence-output-record rec) + (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 orientation-val + ;;: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 + ) + (setf record rec)) + ;; Isn't this a hack? + (with-bounding-rectangle* + (x1 y1 x2 y2) record + (draw-rectangle* pane x1 y1 x2 y2 :ink +flipping-ink+) + (draw-rectangle* pane x1 y1 x2 y2 :ink +flipping-ink+)))))))

(defmethod display-parse-tree ((entity slidemacs-slide-name) (syntax slidemacs-gui-syntax) pane) (with-text-style (pane `(:sans-serif :bold ,(getf *slidemacs-sizes* :title))) @@ -241,12 +263,13 @@ (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 `(:sans-serif :roman ,(getf *slidemacs-sizes* :bullet))) - (with-slots (point) pane - (if (and (mark>= point (start-offset entity)) - (mark<= point (end-offset entity))) - (with-text-face (pane :bold) - (call-next-method)) - (call-next-method))))) + (if (and (not *no-check-point*) + (with-slots (point) pane + (and (mark>= point (start-offset entity)) + (mark<= point (end-offset entity))))) + (with-text-face (pane :bold) + (call-next-method)) + (call-next-method))))

(defmethod display-parse-tree ((entity bullet) (syntax slidemacs-gui-syntax) pane) (stream-increment-cursor-position pane (space-width pane) 0) @@ -264,6 +287,40 @@ (display-text-with-wrap-for-pane bullet-text pane)) (terpri pane))))

+(defun draw-picture (stream pattern) + (multiple-value-bind (x y) + (stream-cursor-position stream) + #+nil + (draw-pattern* stream pattern x y) + (let ((width (pattern-width pattern)) + (height (pattern-height pattern))) + (draw-rectangle* stream x y (+ x width) (+ y height) + :filled t + :ink (transform-region + (make-translation-transformation x y) + pattern))))) + +(defparameter *picture-cache* + (make-hash-table :test #'equal)) + +(defun load-and-cache-xpm (pathname) + (let ((hash-key (cons pathname (file-write-date pathname)))) + (let ((pattern (gethash hash-key *picture-cache*))) + (if pattern pattern + (setf (gethash hash-key *picture-cache*) + (climi::xpm-parse-file pathname)))))) + +(defmethod display-parse-tree ((entity picture-node) (syntax slidemacs-gui-syntax) pane) + (with-slots (picture-pathname) entity + (let ((real-pathname (slidemacs-entity-string picture-pathname))) + (if (probe-file real-pathname) + (let ((pattern (load-and-cache-xpm real-pathname))) + (format *debug-io* "Loaded ~S!~%" real-pathname) + (with-output-recording-options (pane nil t) + (draw-picture pane pattern))) + (with-text-style (pane `(:sans-serif :roman ,(getf *slidemacs-sizes* :bullet))) + (display-text-with-wrap-for-pane (format nil "Missing picture ~S" real-pathname) pane)))))) + (defmethod display-parse-tree ((entity slidemacs-entry) (syntax slidemacs-gui-syntax) pane) (with-slots (ink face) entity (setf ink (medium-ink (sheet-medium pane)) @@ -287,7 +344,7 @@ (parse-state-empty-p (slot-value (lexeme lexer token) 'state))) do (decf token)) (if (not (parse-state-empty-p (slot-value (lexeme lexer token) 'state))) - (display-parse-state + (display-parse-state (slot-value (lexeme lexer token) 'state) syntax pane) (format *debug-io* "Empty parse state.~%"))) ;; DON'T display the lexemes @@ -295,6 +352,28 @@ ;;; It's not necessary to draw the cursor, and in fact quite confusing )))

+(defun postscript-print-pane (pane) + (with-open-file (file-stream "slides.ps" :direction :output + :if-exists :supersede) + (with-output-to-postscript-stream + (stream file-stream) + (with-drawing-options (stream :ink *slidemacs-gui-ink*) + (with-slots (top bot point) pane + (let ((syntax (syntax (buffer pane)))) + (with-slots (lexer) syntax + ;; display the parse tree if any + (let ((token (1- (nb-lexemes lexer)))) + (loop while (and (>= token 0) + (parse-state-empty-p (slot-value (lexeme lexer token) 'state))) + do (decf token)) + (if (not (parse-state-empty-p (slot-value (lexeme lexer token) 'state))) + (display-parse-tree-for-postscript (slot-value (slot-value (target-parse-tree (slot-value (lexeme lexer token) 'state)) 'item) 'item) syntax stream) + (format *debug-io* "Empty parse state.~%"))) + ;; DON'T display the lexemes + )) +;;; It's not necessary to draw the cursor, and in fact quite confusing + ))))) + (defun talking-point-stop-p (lexeme) (or (typep lexeme 'bullet) (and (typep lexeme 'slidemacs-keyword) @@ -335,7 +414,7 @@ (setf *slidemacs-sizes* (loop for thing in *slidemacs-sizes* if (or (not (numberp thing)) - (and (not decrease-p) (< thing 16))) + (and decrease-p (< thing 16))) collect thing else collect (if decrease-p (- thing 8) (+ thing 8)))))

@@ -347,7 +426,55 @@ (adjust-font-sizes nil) (full-redisplay (climacs-gui::current-window)))

+(climacs-gui::define-named-command com-first-talking-point () + (climacs-gui::com-beginning-of-buffer) + (com-next-talking-point)) + +(climacs-gui::define-named-command com-last-talking-point () + (climacs-gui::com-end-of-buffer) + (com-previous-talking-point)) + +(climacs-gui::define-named-command com-flip-slidemacs-syntax () + (let* ((buffer (buffer (climacs-gui::current-window))) + (syntax (syntax buffer))) + (typecase syntax + (slidemacs-gui-syntax + (climacs-gui::set-syntax (make-instance 'slidemacs-editor-syntax + :buffer buffer))) + (slidemacs-editor-syntax + (climacs-gui::set-syntax (make-instance 'slidemacs-gui-syntax + :buffer buffer)))))) + (climacs-gui::global-set-key '(#= :control) 'com-next-talking-point) (climacs-gui::global-set-key '(#- :control) 'com-previous-talking-point) (climacs-gui::global-set-key '(#= :meta) 'com-increase-presentation-font-sizes) -(climacs-gui::global-set-key '(#- :meta) 'com-decrease-presentation-font-sizes) \ No newline at end of file +(climacs-gui::global-set-key '(#- :meta) 'com-decrease-presentation-font-sizes) +(climacs-gui::global-set-key '(#= :control :meta) 'com-last-talking-point) +(climacs-gui::global-set-key '(#- :control :meta) 'com-first-talking-point) +(climacs-gui::global-set-key '(#\s :control :meta) 'com-flip-slidemacs-syntax) + +(defun next-text-size (size) + (if (symbolp size) 16 ;obviously + (+ size 4))) + +(defun prev-text-size (size) + (if (symbolp size) 12 ;obviously + (if (> size 4) + (- size 4) + size))) + +(climacs-gui::define-named-command com-increase-text-size () + (symbol-macrolet ((style (medium-text-style (sheet-medium (climacs-gui::current-window))))) + (format *debug-io* "Size is ~S~%" (text-style-size style)) + (setf style (make-text-style (text-style-family style) + (text-style-face style) + (next-text-size (text-style-size style)))) + (format *debug-io* "Size is now ~S~%" (text-style-size style))) + (full-redisplay (climacs-gui::current-window))) + +(climacs-gui::define-named-command com-decrease-text-size () + (symbol-macrolet ((style (medium-text-style (sheet-medium (climacs-gui::current-window))))) + (setf style (make-text-style (text-style-family style) + (text-style-face style) + (prev-text-size (text-style-size style))))) + (full-redisplay (climacs-gui::current-window))) \ No newline at end of file