Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv29104
Modified Files: slidemacs-gui.lisp Log Message: Add display for the slideset information
Date: Tue Jun 14 04:00:57 2005 Author: bmastenbrook
Index: climacs/slidemacs-gui.lisp diff -u climacs/slidemacs-gui.lisp:1.5 climacs/slidemacs-gui.lisp:1.6 --- climacs/slidemacs-gui.lisp:1.5 Tue Jun 14 03:22:59 2005 +++ climacs/slidemacs-gui.lisp Tue Jun 14 04:00:56 2005 @@ -33,12 +33,21 @@ (defvar *slidemacs-display* nil)
(defvar *current-slideset*) +(defvar *did-display-a-slide*) + +(defun slidemacs-entity-string (entity) + (coerce (buffer-sequence (buffer entity) + (1+ (start-offset entity)) + (1- (end-offset entity))) + 'string))
(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* (lexeme-string slidemacs-slideset-name))) - (display-parse-tree slideset-info syntax pane) - (display-parse-tree nonempty-list-of-slides syntax pane)))) + (let ((*current-slideset* (slidemacs-entity-string slidemacs-slideset-name)) + (*did-display-a-slide* nil)) + (display-parse-tree nonempty-list-of-slides syntax pane) + (unless *did-display-a-slide* + (display-parse-tree slideset-info syntax pane)))))
(defmethod display-parse-tree ((parse-tree slidemacs-slideset-keyword) (syntax slidemacs-gui-syntax) pane) (format *debug-io* "Oops!~%") @@ -77,39 +86,81 @@ (progn (present " " 'string :stream pane) (present word 'string :stream pane)))) - (loop repeat 2 do (terpri pane)))) + (terpri pane))) + +(defparameter *slidemacs-sizes* + '(:title 64 + :bullet 32 + :slideset-title 48 + :slideset-info 32))
(defmethod display-parse-tree ((parse-tree slideset-info) (syntax slidemacs-gui-syntax) pane) - ;; do nothing yet - #+nil (with-slots (point) pane - (when (and (mark>= point (start-offset parse-tree)) - (mark<= point (end-offset parse-tree))) - (with-slots (opt-slide-author opt-slide-institution opt-slide-venue opt-slide-date) - parse-tree - (display-parse-tree slidemacs-slide-name syntax pane) - (display-parse-tree nonempty-list-of-bullets syntax pane))))) + (with-text-style (pane `(: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)))) + +(defmethod display-parse-tree ((entity slide-author) (syntax slidemacs-gui-syntax) pane) + (with-text-style (pane `(: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-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-slots (venue) entity + (display-text-with-wrap-for-pane + (slidemacs-entity-string venue) pane)))) + +(defun today-string () + (multiple-value-bind (second minute hour date month year day) + (get-decoded-time) + (declare (ignore second minute hour day)) + (format nil "~A ~A ~A" + date + (elt + '("Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" "Sep" "Oct" "Nov" "Dec") + (1- month)) + 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-slots (opt-date-string) entity + (if (typep (slot-value opt-date-string 'item) + 'empty-slidemacs-terminals) + (display-text-with-wrap-for-pane (today-string) pane) + (display-text-with-wrap-for-pane + (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*) + (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)))))
-(defparameter *slidemacs-sizes* - '(:title 64 - :bullet 32)) ;; must all be powers of 2 - (defmethod display-parse-tree ((entity slidemacs-slide-name) (syntax slidemacs-gui-syntax) pane) (with-text-style (pane `(:serif :bold ,(getf *slidemacs-sizes* :title))) (display-text-with-wrap-for-pane - (coerce (buffer-sequence (buffer syntax) - (1+ (start-offset entity)) - (1- (end-offset entity))) - 'string) 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) @@ -131,7 +182,8 @@ (1+ (start-offset entity)) (1- (end-offset entity))) 'string))) - (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 @@ -170,6 +222,11 @@ ;;; 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) + (word-is lexeme "info")))) + (climacs-gui::define-named-command com-next-talking-point () (let* ((pane (climacs-gui::current-window)) (buffer (buffer pane)) @@ -180,7 +237,7 @@ (loop for token from 0 below (nb-lexemes lexer) for lexeme = (lexeme lexer token) do - (when (and (typep lexeme 'bullet) + (when (and (talking-point-stop-p lexeme) (> (start-offset lexeme) point-pos)) (return (setf (offset point) (start-offset lexeme))))) (full-redisplay pane)))))) @@ -195,7 +252,7 @@ (loop for token from (1- (nb-lexemes lexer)) downto 0 for lexeme = (lexeme lexer token) do - (when (and (typep lexeme 'bullet) + (when (and (talking-point-stop-p lexeme) (< (start-offset lexeme) point-pos)) (return (setf (offset point) (start-offset lexeme))))) (full-redisplay pane))))))