[climacs-cvs] CVS update: climacs/slidemacs-gui.lisp
Brian Mastenbrook
bmastenbrook at common-lisp.net
Tue Jun 14 01:23:00 UTC 2005
Update of /project/climacs/cvsroot/climacs
In directory common-lisp.net:/tmp/cvs-serv26508
Modified Files:
slidemacs-gui.lisp
Log Message:
Significantly enhanced display with word wrap
Date: Tue Jun 14 03:22:59 2005
Author: bmastenbrook
Index: climacs/slidemacs-gui.lisp
diff -u climacs/slidemacs-gui.lisp:1.4 climacs/slidemacs-gui.lisp:1.5
--- climacs/slidemacs-gui.lisp:1.4 Mon Jun 6 01:27:45 2005
+++ climacs/slidemacs-gui.lisp Tue Jun 14 03:22:59 2005
@@ -32,9 +32,13 @@
(defvar *slidemacs-display* nil)
+(defvar *current-slideset*)
+
(defmethod display-parse-tree ((parse-tree slidemacs-slideset) (syntax slidemacs-gui-syntax) pane)
- (with-slots (nonempty-list-of-slides slidemacs-slideset-name) parse-tree
- (display-parse-tree nonempty-list-of-slides 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))))
(defmethod display-parse-tree ((parse-tree slidemacs-slideset-keyword) (syntax slidemacs-gui-syntax) pane)
(format *debug-io* "Oops!~%")
@@ -44,6 +48,48 @@
(let ((*handle-whitespace* nil))
(call-next-method)))
+(defun display-text-with-wrap-for-pane (text pane)
+ (let* ((text (substitute #\space #\newline text))
+ (split (remove
+ ""
+ (loop with start = 0
+ with length = (length text)
+ for cur from 0 upto length
+ for is-space =
+ (or (eql cur length)
+ (eql (elt text cur) #\space))
+ when is-space
+ collect
+ (prog1
+ (subseq text start cur)
+ (setf start (1+ cur))))
+ :test #'equal)))
+ (present (pop split) 'string :stream pane)
+ (loop
+ with margin = (stream-text-margin pane)
+ for word in split
+ do (if (> (+ (stream-cursor-position pane)
+ (stream-string-width pane word))
+ margin)
+ (progn
+ (terpri pane)
+ (present word 'string :stream pane))
+ (progn
+ (present " " 'string :stream pane)
+ (present word 'string :stream pane))))
+ (loop repeat 2 do (terpri pane))))
+
+(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)))))
+
(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))
@@ -53,19 +99,21 @@
(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 64))
- (present (coerce (buffer-sequence (buffer syntax)
- (1+ (start-offset entity))
- (1- (end-offset entity)))
- 'string)
- 'string
- :stream pane)
- (loop repeat 2 do (terpri 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)))
(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 48))
+ (with-text-style (pane `(:serif :roman ,(getf *slidemacs-sizes* :bullet)))
(with-slots (point) pane
(if (and (mark>= point (start-offset entity))
(mark<= point (end-offset entity)))
@@ -79,12 +127,11 @@
(stream-increment-cursor-position pane (space-width pane) 0))
(defmethod display-parse-tree ((entity talking-point) (syntax slidemacs-gui-syntax) pane)
- (present (coerce (buffer-sequence (buffer syntax)
- (1+ (start-offset entity))
- (1- (end-offset entity)))
- 'string)
- 'string :stream pane)
- (loop repeat 2 do (terpri 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)))
(defmethod display-parse-tree ((entity slidemacs-entry) (syntax slidemacs-gui-syntax) pane)
(with-slots (ink face) entity
@@ -105,7 +152,7 @@
*slidemacs-gui-ink* c2)
(window-refresh pane))
-(defmethod redisplay-pane-with-syntax ((pane climacs-pane) (syntax slidemacs-gui-syntax) current-p)
+(defmethod redisplay-pane-with-syntax ((pane climacs-pane) (syntax slidemacs-gui-syntax) current-p)
(with-drawing-options (pane :ink *slidemacs-gui-ink*)
(with-slots (top bot point) pane
(with-slots (lexer) syntax
@@ -153,11 +200,29 @@
(return (setf (offset point) (start-offset lexeme)))))
(full-redisplay pane))))))
+(defun adjust-font-sizes (decrease-p)
+ (setf *slidemacs-sizes*
+ (loop for thing in *slidemacs-sizes*
+ if (or (not (numberp thing))
+ (< thing 16))
+ collect thing
+ else collect (if decrease-p (- thing 8) (+ thing 8)))))
+
(climacs-gui::define-named-command com-set-colors-for-presentation ()
(set-pane-colors (climacs-gui::current-window) +blue+ +white+))
(climacs-gui::define-named-command com-set-colors-for-editing ()
(set-pane-colors (climacs-gui::current-window) +white+ +black+))
+(climacs-gui::define-named-command com-decrease-presentation-font-sizes ()
+ (adjust-font-sizes t)
+ (full-redisplay (climacs-gui::current-window)))
+
+(climacs-gui::define-named-command com-increase-presentation-font-sizes ()
+ (adjust-font-sizes nil)
+ (full-redisplay (climacs-gui::current-window)))
+
(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
More information about the Climacs-cvs
mailing list