[climacs-cvs] CVS update: climacs/gui.lisp climacs/slidemacs.lisp climacs/slidemacs-gui.lisp
Brian Mastenbrook
bmastenbrook at common-lisp.net
Sat Jun 18 02:01:58 UTC 2005
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
More information about the Climacs-cvs
mailing list