[climacs-cvs] CVS update: climacs/slidemacs-gui.lisp climacs/slidemacs.lisp

[Brian Mastenbrook]

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

Modified Files:
	slidemacs-gui.lisp slidemacs.lisp 
Log Message:
MORE PRESENTATION OBJECTS: urls and reveal buttons

Date: Tue Jun 21 18:51:05 2005
Author: bmastenbrook

Index: climacs/slidemacs-gui.lisp
diff -u climacs/slidemacs-gui.lisp:1.14 climacs/slidemacs-gui.lisp:1.15
--- climacs/slidemacs-gui.lisp:1.14	Mon Jun 20 19:33:11 2005
+++ climacs/slidemacs-gui.lisp	Tue Jun 21 18:51:05 2005
@@ -80,7 +80,7 @@
   (let ((*handle-whitespace* nil))
     (call-next-method)))
 
-(defun undisplay-text-with-wrap-for-pane (text pane)
+(defun display-text-with-wrap-for-pane (text pane)
   (let* ((text (substitute #\space #\newline text))
          (split (remove
                  ""
@@ -295,6 +295,79 @@
           (display-text-with-wrap-for-pane bullet-text pane))
       (terpri pane))))
 
+(define-presentation-type slidemacs-url () :inherit-from 'string)
+
+(define-presentation-method present (object (type slidemacs-url)
+                                            stream (view textual-view)
+                                            &key &allow-other-keys)
+  (display-text-with-wrap-for-pane object stream))
+
+(define-command (com-browse-to-url :name "Browse To URL"
+                                   :command-table global-command-table
+                                   :menu t
+                                   :provide-output-destination-keyword t)
+    ((url 'slidemacs-url :prompt "url"))
+  #+sbcl
+  (sb-ext:run-program "/usr/bin/open" (list url)))
+
+(define-presentation-to-command-translator browse-url-translator
+    (slidemacs-url com-browse-to-url global-command-table
+                   :gesture :select
+                   :documentation "Browse To URL"
+                   :pointer-documentation "Browse To URL")
+    (presentation)
+  (list (presentation-object presentation)))
+
+(defmethod display-parse-tree ((entity url-point) (syntax slidemacs-gui-syntax) pane)
+  (stream-write-string pane " ")
+  (with-text-style (pane `(:sans-serif :roman ,(getf *slidemacs-sizes* :bullet)))
+    (with-slots (url-string) entity
+      (display-parse-tree url-string syntax pane))))
+
+(defmethod display-parse-tree ((entity url-string) (syntax slidemacs-gui-syntax) 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)
+            (present bullet-text 'slidemacs-url :stream pane))
+          (present bullet-text 'slidemacs-url :stream pane))
+      (terpri pane))))
+
+(define-presentation-type reveal-button () :inherit-from t)
+
+(define-presentation-method present (object (type reveal-button)
+                                            stream (view textual-view)
+                                            &key &allow-other-keys)
+  (with-slots (button-label) object
+    (display-text-with-wrap-for-pane (slidemacs-entity-string button-label)
+                                     stream)))
+
+(define-command (com-reveal-text :name "Reveal Text In Window"
+                                   :command-table global-command-table
+                                   :menu t
+                                   :provide-output-destination-keyword t)
+    ((text 'string :prompt "text"))
+  (let ((stream (open-window-stream)))
+    (with-text-style (stream `(:sans-serif :roman ,(getf *slidemacs-sizes* :bullet)))
+      (write-string text stream))))
+
+(define-presentation-to-command-translator reveal-text-translator
+    (reveal-button com-reveal-text global-command-table
+                   :gesture :select
+                   :documentation "Reveal Text In Window"
+                   :pointer-documentation "Reveal Text In Window")
+    (presentation)
+  (with-slots (reveal-text) (presentation-object presentation)
+    (list (slidemacs-entity-string reveal-text))))
+
+(defmethod display-parse-tree ((entity reveal-button-point) (syntax slidemacs-gui-syntax) pane)
+  (write-string " " pane)
+  (with-text-style (pane `(:sans-serif :roman ,(getf *slidemacs-sizes* :bullet)))
+      (present entity 'reveal-button :stream pane))
+  (terpri pane))
+      
 #+(or)
 (defun draw-picture (stream pattern)
   (multiple-value-bind (x y)


Index: climacs/slidemacs.lisp
diff -u climacs/slidemacs.lisp:1.5 climacs/slidemacs.lisp:1.6
--- climacs/slidemacs.lisp:1.5	Sat Jun 18 15:58:49 2005
+++ climacs/slidemacs.lisp	Tue Jun 21 18:51:05 2005
@@ -290,13 +290,20 @@
       nonempty-list-of-bullets block-close)
   (:= slidemacs-slide-keyword "slide")
   (:= slidemacs-slide-name slidemacs-string)
-  (:= nonempty-list-of-bullets (nonempty-list-of slidemacs-bullet-or-picture))
-  (:= slidemacs-bullet-or-picture (or slidemacs-bullet picture-node))
+  (:= nonempty-list-of-bullets (nonempty-list-of slidemacs-bullet-types))
+  (:= slidemacs-bullet-types (or slidemacs-bullet picture-node url-point reveal-button-point))
   (:= slidemacs-bullet bullet talking-point)
   (:= talking-point slidemacs-string)
   (:= picture-node picture-keyword picture-pathname)
   (:= picture-keyword "picture")
-  (:= picture-pathname slidemacs-string))
+  (:= picture-pathname slidemacs-string)
+  (:= url-point url-keyword url-string)
+  (:= url-keyword "url")
+  (:= url-string slidemacs-string)
+  (:= reveal-button-point reveal-keyword button-label reveal-text)
+  (:= reveal-keyword "reveal")
+  (:= button-label slidemacs-string)
+  (:= reveal-text slidemacs-string))
 
 (defmethod display-parse-tree ((entity slidemacs-terminal) (syntax slidemacs-editor-syntax) pane)
   (with-slots (item) entity