From bmastenbrook at common-lisp.net Thu Jun 9 21:14:35 2005 From: bmastenbrook at common-lisp.net (Brian Mastenbrook) Date: Thu, 9 Jun 2005 23:14:35 +0200 (CEST) Subject: [climacs-cvs] CVS update: papers/ilc2005/syntax/climacssyntax.tex Message-ID: <20050609211435.6F9F788030@common-lisp.net> Update of /project/climacs/cvsroot/papers/ilc2005/syntax In directory common-lisp.net:/tmp/cvs-serv2464 Modified Files: climacssyntax.tex Log Message: Final edit to the paper: US Letter; no table as requested by Carl Shaprio Date: Thu Jun 9 23:14:34 2005 Author: bmastenbrook Index: papers/ilc2005/syntax/climacssyntax.tex diff -u papers/ilc2005/syntax/climacssyntax.tex:1.35 papers/ilc2005/syntax/climacssyntax.tex:1.36 --- papers/ilc2005/syntax/climacssyntax.tex:1.35 Tue May 24 23:36:09 2005 +++ papers/ilc2005/syntax/climacssyntax.tex Thu Jun 9 23:14:34 2005 @@ -4,7 +4,7 @@ \newcommand{\TabCode}{\textit{TabCode}} -\usepackage[a4paper,textwidth=6.7in,textheight=8.7in]{geometry} +\usepackage[textwidth=6.7in,textheight=8.7in]{geometry} \usepackage{graphics} \usepackage{url} \usepackage{times} @@ -78,40 +78,10 @@ spawned many variants with many different approaches to buffer management, incremental redisplay, and syntax analysis. Emacs itself traces its lineage to TECO, where Emacs was originally implemented as -a set of TECO macros. A summary comparison of Climacs to a -non-exhaustive set of Emacs variants is presented in table -\ref{table:editorcompare}; more information about text editing in -general, and particulars of some editors we shall not discuss further, -can be found in \cite{FinsethCraft,greenberg,Pike94,woodZ} and -references therein. - -\begin{table} -\begin{center} -{\small -\begin{tabular}{|c|c|c|c|} -\hline - \textbf{Editor} & \textbf{Buffer Implementation} & \textbf{Syntax Analysis} & \textbf{Language} -\\ -\hline TECO & Gap buffer & Unknown & Assembly + TECO Macros -\\ -\hline Zmacs & Probably doubly-linked list of lines & None & MacLisp -\\ -\hline GNU Emacs & Gap buffer & Regular Expressions & C + Emacs Lisp -\\ -\hline Hemlock & Doubly-linked list of lines & None & Common Lisp -\\ -\hline FRED & Gap buffer & None & PPC Assembly + Common Lisp -\\ -\hline Deuce & Doubly-linked lists of lines & Unknown & Dylan -\\ -\hline Climacs & Multiple & Multiple & Common Lisp -\\\hline -\end{tabular} -} -\caption{Implementation strategies of multiple Emacs variants} -\end{center} -\label{table:editorcompare} -\end{table} +a set of TECO macros. More information about text editing in general, +and particulars of some editors we shall not discuss further, can be +found in \cite{FinsethCraft,greenberg,Pike94,woodZ} and references +therein. Climacs' syntax analysis is a flexible protocol which can be implemented with a full language lexer and parser. GNU Emacs, the most From rstrandh at common-lisp.net Mon Jun 13 07:08:24 2005 From: rstrandh at common-lisp.net (Robert Strandh) Date: Mon, 13 Jun 2005 09:08:24 +0200 (CEST) Subject: [climacs-cvs] CVS update: climacs/lisp-syntax.lisp Message-ID: <20050613070824.EF3608816B@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv23765 Modified Files: lisp-syntax.lisp Log Message: Tabs are now handled correctly as far as displaying the cursor is concerned. Introduced a lexer error state in which entire lines are returned as lexemes. This speeds up the parser after a parse error. Date: Mon Jun 13 09:08:24 2005 Author: rstrandh Index: climacs/lisp-syntax.lisp diff -u climacs/lisp-syntax.lisp:1.5 climacs/lisp-syntax.lisp:1.6 --- climacs/lisp-syntax.lisp:1.5 Wed Jun 1 18:42:28 2005 +++ climacs/lisp-syntax.lisp Mon Jun 13 09:08:23 2005 @@ -20,8 +20,6 @@ ;;; Alternative syntax module for analysing Common Lisp -;;; move the package definition to packages.lisp later - (in-package :climacs-lisp-syntax) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -64,6 +62,11 @@ `(defclass ,name (, at superclasses lexer-state) , at body)) +(define-lexer-state lexer-error-state () + () + (:documentation "In this state, the lexer returns error lexemes + consisting of entire lines of text")) + (define-lexer-state lexer-toplevel-state () () (:documentation "In this state, the lexer assumes it can skip @@ -332,6 +335,12 @@ (fo))) (t (fo)))))))) +(defmethod lex ((syntax lisp-syntax) (state lexer-error-state) scan) + (macrolet ((fo () `(forward-object scan))) + (loop until (end-of-line-p scan) + do (fo)) + (make-instance 'error-lexeme))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; nonterminals @@ -408,7 +417,7 @@ size 0)))) result)) -(define-parser-state error-state (lexer-toplevel-state parser-state) ()) +(define-parser-state error-state (lexer-error-state parser-state) ()) (define-parser-state error-reduce-state (lexer-toplevel-state parser-state) ()) (define-lisp-action (error-reduce-state (eql nil)) @@ -899,7 +908,10 @@ (let* ((cursor-line (number-of-lines-in-region top (point pane))) (height (text-style-height (medium-text-style pane) pane)) (cursor-y (+ (* cursor-line (+ height (stream-vertical-spacing pane))))) - (cursor-column (column-number (point pane))) + (cursor-column + (buffer-display-column + (buffer (point pane)) (offset (point pane)) + (round (tab-width pane) (space-width pane)))) (cursor-x (* cursor-column (text-style-width (medium-text-style pane) pane)))) (updating-output (pane :unique-id -1) (draw-rectangle* pane From bmastenbrook at common-lisp.net Tue Jun 14 01:23:00 2005 From: bmastenbrook at common-lisp.net (Brian Mastenbrook) Date: Tue, 14 Jun 2005 03:23:00 +0200 (CEST) Subject: [climacs-cvs] CVS update: climacs/slidemacs-gui.lisp Message-ID: <20050614012300.7D20F884CC@common-lisp.net> 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 From bmastenbrook at common-lisp.net Tue Jun 14 02:00:57 2005 From: bmastenbrook at common-lisp.net (Brian Mastenbrook) Date: Tue, 14 Jun 2005 04:00:57 +0200 (CEST) Subject: [climacs-cvs] CVS update: climacs/slidemacs-gui.lisp Message-ID: <20050614020057.B9D83884CC@common-lisp.net> 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)))))) From bmastenbrook at common-lisp.net Tue Jun 14 02:01:40 2005 From: bmastenbrook at common-lisp.net (Brian Mastenbrook) Date: Tue, 14 Jun 2005 04:01:40 +0200 (CEST) Subject: [climacs-cvs] CVS update: papers/ilc2005/syntax/climacs-slides.slidemacs Message-ID: <20050614020140.5B3C9884CC@common-lisp.net> Update of /project/climacs/cvsroot/papers/ilc2005/syntax In directory common-lisp.net:/tmp/cvs-serv29238 Added Files: climacs-slides.slidemacs Log Message: Might as well put this in CVS for now Date: Tue Jun 14 04:01:39 2005 Author: bmastenbrook From bmastenbrook at common-lisp.net Tue Jun 14 23:12:28 2005 From: bmastenbrook at common-lisp.net (Brian Mastenbrook) Date: Wed, 15 Jun 2005 01:12:28 +0200 (CEST) Subject: [climacs-cvs] CVS update: climacs/slidemacs.lisp Message-ID: <20050614231228.D10BC8802E@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv8886 Modified Files: slidemacs.lisp Log Message: oops, commit the latest version of the slidemacs grammar Date: Wed Jun 15 01:12:26 2005 Author: bmastenbrook Index: climacs/slidemacs.lisp diff -u climacs/slidemacs.lisp:1.1 climacs/slidemacs.lisp:1.2 --- climacs/slidemacs.lisp:1.1 Sun Jun 5 03:59:52 2005 +++ climacs/slidemacs.lisp Wed Jun 15 01:12:26 2005 @@ -235,9 +235,28 @@ (define-parsing-rules (*slidemacs-grammar* slidemacs-entry slidemacs-terminal slidemacs-editor-syntax) (:== slidemacs-slideset slidemacs-slideset-keyword slidemacs-slideset-name block-open - nonempty-list-of-slides block-close) + slideset-info nonempty-list-of-slides block-close) (:= slidemacs-slideset-keyword "slideset") (:= 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-keyword "info") + (:= opt-slide-author (or slide-author empty-slidemacs-terminals)) + (:= slide-author author-keyword author) + (:= author-keyword "author") + (:= author slidemacs-string) + (:= opt-slide-venue (or slide-venue empty-slidemacs-terminals)) + (:= slide-venue slide-venue-keyword venue) + (:= slide-venue-keyword "venue") + (:= venue slidemacs-string) + (:= opt-slide-institution (or slide-institution empty-slidemacs-terminals)) + (:= slide-institution institution-keyword institution) + (:= institution-keyword "institution") + (:= institution slidemacs-string) + (:= opt-slide-date (or slide-date empty-slidemacs-terminals)) + (:= slide-date date-keyword opt-date-string) + (:= opt-date-string (or date-string empty-slidemacs-terminals)) + (:= date-keyword "date") + (:= date-string slidemacs-string) (:= nonempty-list-of-slides (nonempty-list-of slidemacs-slide)) (:= slidemacs-slide slidemacs-slide-keyword slidemacs-slide-name block-open From bmastenbrook at common-lisp.net Tue Jun 14 23:14:19 2005 From: bmastenbrook at common-lisp.net (Brian Mastenbrook) Date: Wed, 15 Jun 2005 01:14:19 +0200 (CEST) Subject: [climacs-cvs] CVS update: climacs/slidemacs-gui.lisp Message-ID: <20050614231419.9C7048802E@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv8935 Modified Files: slidemacs-gui.lisp Log Message: Kill the Set Colors For ... commands; they didn't add much and there's a lot of room for a rethink here Date: Wed Jun 15 01:14:19 2005 Author: bmastenbrook Index: climacs/slidemacs-gui.lisp diff -u climacs/slidemacs-gui.lisp:1.6 climacs/slidemacs-gui.lisp:1.7 --- climacs/slidemacs-gui.lisp:1.6 Tue Jun 14 04:00:56 2005 +++ climacs/slidemacs-gui.lisp Wed Jun 15 01:14:18 2005 @@ -198,12 +198,6 @@ (defparameter *slidemacs-gui-ink* +black+) -(defun set-pane-colors (pane c1 c2) - (setf (medium-background (sheet-medium pane)) c1 - (medium-ink (sheet-medium pane)) c2 - *slidemacs-gui-ink* c2) - (window-refresh pane)) - (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 @@ -264,12 +258,6 @@ (< 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) From bmastenbrook at common-lisp.net Wed Jun 15 01:39:47 2005 From: bmastenbrook at common-lisp.net (Brian Mastenbrook) Date: Wed, 15 Jun 2005 03:39:47 +0200 (CEST) Subject: [climacs-cvs] CVS update: climacs/slidemacs-gui.lisp climacs/slidemacs.lisp Message-ID: <20050615013947.3E3E78802E@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv17742 Modified Files: slidemacs-gui.lisp slidemacs.lisp Log Message: Graph formatting for Slidemacs! Date: Wed Jun 15 03:39:46 2005 Author: bmastenbrook Index: climacs/slidemacs-gui.lisp diff -u climacs/slidemacs-gui.lisp:1.7 climacs/slidemacs-gui.lisp:1.8 --- climacs/slidemacs-gui.lisp:1.7 Wed Jun 15 01:14:18 2005 +++ climacs/slidemacs-gui.lisp Wed Jun 15 03:39:46 2005 @@ -91,12 +91,13 @@ (defparameter *slidemacs-sizes* '(:title 64 :bullet 32 + :graph-node 16 :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 `(:serif :bold ,(getf *slidemacs-sizes* :slideset-title))) + (with-text-style (pane `(:sans-serif :bold ,(getf *slidemacs-sizes* :slideset-title))) (display-text-with-wrap-for-pane *current-slideset* pane) (terpri pane)) @@ -108,19 +109,19 @@ (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-text-style (pane `(:sans-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-text-style (pane `(:sans-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-text-style (pane `(:sans-serif :roman ,(getf *slidemacs-sizes* :slideset-info))) (with-slots (venue) entity (display-text-with-wrap-for-pane (slidemacs-entity-string venue) pane)))) @@ -137,7 +138,7 @@ 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-text-style (pane `(:sans-serif :roman ,(getf *slidemacs-sizes* :slideset-info))) (with-slots (opt-date-string) entity (if (typep (slot-value opt-date-string 'item) 'empty-slidemacs-terminals) @@ -156,15 +157,83 @@ (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))) + +(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*) + (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 + (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 + )))))) + (defmethod display-parse-tree ((entity slidemacs-slide-name) (syntax slidemacs-gui-syntax) pane) - (with-text-style (pane `(:serif :bold ,(getf *slidemacs-sizes* :title))) + (with-text-style (pane `(:sans-serif :bold ,(getf *slidemacs-sizes* :title))) (display-text-with-wrap-for-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) - (with-text-style (pane `(:serif :roman ,(getf *slidemacs-sizes* :bullet))) + (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))) @@ -178,12 +247,15 @@ (stream-increment-cursor-position pane (space-width pane) 0)) (defmethod display-parse-tree ((entity talking-point) (syntax slidemacs-gui-syntax) 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) - (terpri 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) + (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 @@ -219,7 +291,8 @@ (defun talking-point-stop-p (lexeme) (or (typep lexeme 'bullet) (and (typep lexeme 'slidemacs-keyword) - (word-is lexeme "info")))) + (or (word-is lexeme "info") + (word-is lexeme "graph"))))) (climacs-gui::define-named-command com-next-talking-point () (let* ((pane (climacs-gui::current-window)) Index: climacs/slidemacs.lisp diff -u climacs/slidemacs.lisp:1.2 climacs/slidemacs.lisp:1.3 --- climacs/slidemacs.lisp:1.2 Wed Jun 15 01:12:26 2005 +++ climacs/slidemacs.lisp Wed Jun 15 03:39:46 2005 @@ -60,7 +60,7 @@ collect `(defclass ,lexeme (,superclass) ())))) (define-lexemes slidemacs-lexeme start-lexeme slidemacs-keyword - block-open block-close slidemacs-string bullet other-entry) + block-open block-close slidemacs-quoted-string slidemacs-italic-string bullet other-entry) (defclass slidemacs-lexer (incremental-lexer) ()) @@ -89,7 +89,13 @@ do (fo)) (unless (end-of-buffer-p scan) (fo)) ; get the closing #\" - (make-instance 'slidemacs-string)) + (make-instance 'slidemacs-quoted-string)) + (#\/ (loop until (end-of-buffer-p scan) + while (not (eql (object-after scan) #\/)) + do (fo)) + (unless (end-of-buffer-p scan) + (fo)) ; get the closing #\/ + (make-instance 'slidemacs-italic-string)) (#\* bullet) (t (cond ((identifier-char-p object :start t) @@ -237,6 +243,7 @@ (:== slidemacs-slideset slidemacs-slideset-keyword slidemacs-slideset-name block-open slideset-info nonempty-list-of-slides block-close) (:= 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-keyword "info") @@ -258,7 +265,22 @@ (:= date-keyword "date") (:= date-string slidemacs-string) (:= nonempty-list-of-slides - (nonempty-list-of slidemacs-slide)) + (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-keyword "graph") + (:= list-of-roots (list-of graph-root)) + (:= graph-root graph-root-keyword vertex-name) + (:= graph-root-keyword "root") + (:= list-of-edges (list-of graph-edge)) + (:= graph-edge graph-edge-keyword from-keyword from-vertex to-keyword to-vertex) + (:= graph-edge-keyword "edge") + (:= from-keyword "from") + (:= to-keyword "to") + (:= from-vertex vertex-name) + (:= to-vertex vertex-name) + (:= vertex-name slidemacs-string) (:= slidemacs-slide slidemacs-slide-keyword slidemacs-slide-name block-open nonempty-list-of-bullets block-close) (:= slidemacs-slide-keyword "slide") @@ -270,6 +292,10 @@ (defmethod display-parse-tree ((entity slidemacs-terminal) (syntax slidemacs-editor-syntax) pane) (with-slots (item) entity (display-parse-tree item syntax pane))) + +(defmethod display-parse-tree ((entity slidemacs-italic-string) (syntax slidemacs-editor-syntax) pane) + (with-text-face (pane :italic) + (call-next-method))) (defmethod display-parse-tree ((entity slidemacs-entry) (syntax slidemacs-editor-syntax) pane) (flet ((cache-test (t1 t2) From bmastenbrook at common-lisp.net Wed Jun 15 01:40:05 2005 From: bmastenbrook at common-lisp.net (Brian Mastenbrook) Date: Wed, 15 Jun 2005 03:40:05 +0200 (CEST) Subject: [climacs-cvs] CVS update: papers/ilc2005/syntax/climacs-slides.slidemacs Message-ID: <20050615014005.EBB178802E@common-lisp.net> Update of /project/climacs/cvsroot/papers/ilc2005/syntax In directory common-lisp.net:/tmp/cvs-serv17782 Modified Files: climacs-slides.slidemacs Log Message: Current state of the slides Date: Wed Jun 15 03:40:04 2005 Author: bmastenbrook Index: papers/ilc2005/syntax/climacs-slides.slidemacs diff -u papers/ilc2005/syntax/climacs-slides.slidemacs:1.1 papers/ilc2005/syntax/climacs-slides.slidemacs:1.2 --- papers/ilc2005/syntax/climacs-slides.slidemacs:1.1 Tue Jun 14 04:01:39 2005 +++ papers/ilc2005/syntax/climacs-slides.slidemacs Wed Jun 15 03:40:04 2005 @@ -76,4 +76,15 @@ * "Slidemacs syntax (used for slide display)" * "Tabcode editor (used for tablature display)" } +graph "Parser class hierarchy" { +root "parse-tree" +edge from "parse-tree" to "ttcn3-parse-tree" +edge from "ttcn3-parse-tree" to "ttcn3-entry" +edge from "ttcn3-entry" to "ttcn3-lexeme" +edge from "ttcn3-lexeme" to /lexeme classes/ +edge from "ttcn3-entry" to /parser production classes/ +edge from "ttcn3-entry" to "empty-ttcn3-terminals" +edge from "ttcn3-entry" to "ttcn3-nonterminal" +edge from "ttcn3-entry" to "ttcn3-terminal" +} } From rstrandh at common-lisp.net Wed Jun 15 06:00:21 2005 From: rstrandh at common-lisp.net (Robert Strandh) Date: Wed, 15 Jun 2005 08:00:21 +0200 (CEST) Subject: [climacs-cvs] CVS update: climacs/gui.lisp climacs/lisp-syntax.lisp Message-ID: <20050615060021.DEBF98802E@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv1314 Modified Files: gui.lisp lisp-syntax.lisp Log Message: Initial steps toward more Common Lisp awareness. For now, we parse lexemes into symbols whenever possible, and present them as such. For experimentation, two commands com-accept-string and com-accept-symbol exist to verify that the presentation works. The symbols we obtain will be used to compute indentation, which is next on the list of things to do. Date: Wed Jun 15 08:00:13 2005 Author: rstrandh Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.143 climacs/gui.lisp:1.144 --- climacs/gui.lisp:1.143 Mon May 30 11:33:39 2005 +++ climacs/gui.lisp Wed Jun 15 08:00:12 2005 @@ -1412,6 +1412,18 @@ (syntax (syntax (buffer pane)))) (eval-defun point syntax))) +(define-named-command com-package () + (let* ((pane (current-window)) + (syntax (syntax (buffer pane))) + (package (climacs-lisp-syntax::package-of syntax))) + (display-message (format nil "~s" package)))) + +(define-named-command com-accept-string () + (display-message (format nil "~s" (accept 'string)))) + +(define-named-command com-accept-symbol () + (display-message (format nil "~s" (accept 'symbol)))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Global and dead-escape command tables Index: climacs/lisp-syntax.lisp diff -u climacs/lisp-syntax.lisp:1.6 climacs/lisp-syntax.lisp:1.7 --- climacs/lisp-syntax.lisp:1.6 Mon Jun 13 09:08:23 2005 +++ climacs/lisp-syntax.lisp Wed Jun 15 08:00:12 2005 @@ -33,7 +33,8 @@ (current-state) (current-start-mark) (current-size) - (scan)) + (scan) + (package)) (:name "Lisp") (:pathname-types "lisp" "lsp" "cl")) @@ -757,6 +758,30 @@ (defmethod update-syntax-for-display (buffer (syntax lisp-syntax) top bot) nil) +(defun package-of (syntax) + (let ((buffer (buffer syntax))) + (flet ((test (x) + (and (typep x 'list-form) + (not (null (cdr (children x)))) + (buffer-looking-at buffer + (start-offset (cadr (children x))) + "in-package" + :test #'char-equal)))) + (with-slots (stack-top) syntax + (let ((form (find-if #'test (children stack-top)))) + (and form + (not (null (cddr (children form)))) + (let* ((package-form (caddr (children form))) + (package-name (coerce (buffer-sequence + buffer + (start-offset package-form) + (end-offset package-form)) + 'string)) + (package-symbol + (let ((*package* (find-package :common-lisp))) + (read-from-string package-name nil nil)))) + (find-package package-symbol)))))))) + (defmethod update-syntax (buffer (syntax lisp-syntax)) (let* ((low-mark (low-mark buffer)) (high-mark (high-mark buffer))) @@ -775,7 +800,9 @@ (new-state syntax (parser-state stack-top) stack-top))) - (loop do (parse-patch syntax))))))) + (loop do (parse-patch syntax)))))) + (with-slots (package) syntax + (setf package (package-of syntax)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -849,19 +876,24 @@ (medium-ink (sheet-medium pane))) (eq (slot-value t1 'face) (text-style-face (medium-text-style (sheet-medium pane))))))) - (updating-output (pane :unique-id parser-symbol - :id-test #'eq - :cache-value parser-symbol - :cache-test #'cache-test) - (with-slots (ink face) parser-symbol - (setf ink (medium-ink (sheet-medium pane)) - face (text-style-face (medium-text-style (sheet-medium pane)))) - (present (coerce (buffer-sequence (buffer syntax) - (start-offset parser-symbol) - (end-offset parser-symbol)) - 'string) - 'string - :stream pane))))) + (updating-output + (pane :unique-id parser-symbol + :id-test #'eq + :cache-value parser-symbol + :cache-test #'cache-test) + (with-slots (ink face) parser-symbol + (setf ink (medium-ink (sheet-medium pane)) + face (text-style-face (medium-text-style (sheet-medium pane)))) + (let ((string (coerce (buffer-sequence (buffer syntax) + (start-offset parser-symbol) + (end-offset parser-symbol)) + 'string))) + (multiple-value-bind (symbol status) + (token-to-symbol syntax parser-symbol) + (declare (ignore symbol)) + (if (and status (typep parser-symbol 'form)) + (present string 'symbol :stream pane) + (present string 'string :stream pane)))))))) (defmethod display-parse-tree :before ((parse-symbol lisp-lexeme) (syntax lisp-syntax) pane) (handle-whitespace pane (buffer pane) *white-space-start* (start-offset parse-symbol)) @@ -1007,4 +1039,52 @@ (coerce (buffer-sequence (buffer syntax) (start-offset form) (end-offset form)) - 'string))))))) \ No newline at end of file + 'string))))))) + +;;; shamelessly stolen from SWANK + +(defconstant keyword-package (find-package :keyword) + "The KEYWORD package.") + +;; FIXME: deal with #\| etc. hard to do portably. +(defun tokenize-symbol (string) + (let ((package (let ((pos (position #\: string))) + (if pos (subseq string 0 pos) nil))) + (symbol (let ((pos (position #\: string :from-end t))) + (if pos (subseq string (1+ pos)) string))) + (internp (search "::" string))) + (values symbol package internp))) + +;; FIXME: Escape chars are ignored +(defun casify (string) + "Convert string accoring to readtable-case." + (ecase (readtable-case *readtable*) + (:preserve string) + (:upcase (string-upcase string)) + (:downcase (string-downcase string)) + (:invert (multiple-value-bind (lower upper) (determine-case string) + (cond ((and lower upper) string) + (lower (string-upcase string)) + (upper (string-downcase string)) + (t string)))))) + +(defun parse-symbol (string &optional (package *package*)) + "Find the symbol named STRING. +Return the symbol and a flag indicating whether the symbols was found." + (multiple-value-bind (sname pname) (tokenize-symbol string) + (let ((package (cond ((string= pname "") keyword-package) + (pname (find-package (casify pname))) + (t package)))) + (if package + (find-symbol (casify sname) package) + (values nil nil))))) + + +(defun token-to-symbol (syntax token) + (let ((package (or (slot-value syntax 'package) + (find-package :common-lisp))) + (token-string (coerce (buffer-sequence (buffer syntax) + (start-offset token) + (end-offset token)) + 'string))) + (parse-symbol token-string package))) From bmastenbrook at common-lisp.net Fri Jun 17 01:15:11 2005 From: bmastenbrook at common-lisp.net (Brian Mastenbrook) Date: Fri, 17 Jun 2005 03:15:11 +0200 (CEST) Subject: [climacs-cvs] CVS update: papers/ilc2005/syntax/climacs-slides.slidemacs Message-ID: <20050617011511.7635688167@common-lisp.net> Update of /project/climacs/cvsroot/papers/ilc2005/syntax In directory common-lisp.net:/tmp/cvs-serv31292 Modified Files: climacs-slides.slidemacs Log Message: MORE SLIDES Date: Fri Jun 17 03:15:10 2005 Author: bmastenbrook Index: papers/ilc2005/syntax/climacs-slides.slidemacs diff -u papers/ilc2005/syntax/climacs-slides.slidemacs:1.2 papers/ilc2005/syntax/climacs-slides.slidemacs:1.3 --- papers/ilc2005/syntax/climacs-slides.slidemacs:1.2 Wed Jun 15 03:40:04 2005 +++ papers/ilc2005/syntax/climacs-slides.slidemacs Fri Jun 17 03:15:09 2005 @@ -9,6 +9,11 @@ * "A CLIM application" * "Protocols for buffer implementation and syntax analysis" } +slide "CLIM" { +* "The Common Lisp Interface Manager" +* "Standard for user interfaces and graphics in Common Lisp" +* "Free implementation in McCLIM" +} slide "Buffer protocol" { * "Multiple buffer implementations" @@ -76,7 +81,11 @@ * "Slidemacs syntax (used for slide display)" * "Tabcode editor (used for tablature display)" } -graph "Parser class hierarchy" { +slide "Lexer and Parser" { +* "Incremental lexer creates objects for each lexeme" +* "Parser parses lexemes into production classes" +} +graph "Sample parser class hierarchy" { root "parse-tree" edge from "parse-tree" to "ttcn3-parse-tree" edge from "ttcn3-parse-tree" to "ttcn3-entry" @@ -86,5 +95,27 @@ edge from "ttcn3-entry" to "empty-ttcn3-terminals" edge from "ttcn3-entry" to "ttcn3-nonterminal" edge from "ttcn3-entry" to "ttcn3-terminal" +} +slide "Parse tree display" { +* "Application controls display of parse tree" +* "Could be a simple colorised display of text..." +* "... or a specialized display of the parse tree" +} +slide "Future directions" { +* "More improvements to McCLIM (speed, completeness)" +* "Better Lisp mode" +* "TTCN-3 Graphical Representation (GR) editor" +* "Slidemacs GUI-mode editor" +} +slide "Future directions, cont." { +* "Beter resynchronization on parse errors" +* "More syntax modules" +* "Other applications (news readers, mail) using Climacs for editable +buffers" +} +slide "Demos" { +* "Lisp mode and incremental parser" +* "Slidemacs mode" +* "Tabcode editor" } } From bmastenbrook at common-lisp.net Fri Jun 17 01:17:28 2005 From: bmastenbrook at common-lisp.net (Brian Mastenbrook) Date: Fri, 17 Jun 2005 03:17:28 +0200 (CEST) Subject: [climacs-cvs] CVS update: climacs/slidemacs-gui.lisp Message-ID: <20050617011728.7207C88167@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv32186 Modified Files: slidemacs-gui.lisp Log Message: some small font size changes, some source formatting changes Date: Fri Jun 17 03:17:27 2005 Author: bmastenbrook Index: climacs/slidemacs-gui.lisp diff -u climacs/slidemacs-gui.lisp:1.8 climacs/slidemacs-gui.lisp:1.9 --- climacs/slidemacs-gui.lisp:1.8 Wed Jun 15 03:39:46 2005 +++ climacs/slidemacs-gui.lisp Fri Jun 17 03:17:27 2005 @@ -73,7 +73,7 @@ (subseq text start cur) (setf start (1+ cur)))) :test #'equal))) - (present (pop split) 'string :stream pane) + (write-string (pop split) pane) (loop with margin = (stream-text-margin pane) for word in split @@ -82,14 +82,14 @@ margin) (progn (terpri pane) - (present word 'string :stream pane)) + (write-string word pane)) (progn - (present " " 'string :stream pane) - (present word 'string :stream pane)))) + (write-string " " pane) + (write-string word pane)))) (terpri pane))) (defparameter *slidemacs-sizes* - '(:title 64 + '(:title 48 :bullet 32 :graph-node 16 :slideset-title 48 @@ -148,14 +148,14 @@ (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))))) + (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))))) (defun traverse-list-entry (list-entry unit-type function) (when (and @@ -212,8 +212,8 @@ (present node 'string :stream stream)))) (lambda (node) (loop for edge in edges - if (equal (car edge) node) - collect (cdr edge))) + if (equal (car edge) node) + collect (cdr edge))) :orientation :horizontal :generation-separation "xxxxxx" :arc-drawer @@ -270,7 +270,7 @@ (defparameter *slidemacs-gui-ink* +black+) -(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 @@ -328,7 +328,7 @@ (setf *slidemacs-sizes* (loop for thing in *slidemacs-sizes* if (or (not (numberp thing)) - (< thing 16)) + (and (not decrease-p) (< thing 16))) collect thing else collect (if decrease-p (- thing 8) (+ thing 8))))) From bmastenbrook at common-lisp.net Fri Jun 17 01:21:22 2005 From: bmastenbrook at common-lisp.net (Brian Mastenbrook) Date: Fri, 17 Jun 2005 03:21:22 +0200 (CEST) Subject: [climacs-cvs] CVS update: climacs/slidemacs-gui.lisp Message-ID: <20050617012122.0605588167@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv32229 Modified Files: slidemacs-gui.lisp Log Message: Cheap way of working around some possible McCLIM display bugs Date: Fri Jun 17 03:21:22 2005 Author: bmastenbrook Index: climacs/slidemacs-gui.lisp diff -u climacs/slidemacs-gui.lisp:1.9 climacs/slidemacs-gui.lisp:1.10 --- climacs/slidemacs-gui.lisp:1.9 Fri Jun 17 03:17:27 2005 +++ climacs/slidemacs-gui.lisp Fri Jun 17 03:21:22 2005 @@ -34,6 +34,7 @@ (defvar *current-slideset*) (defvar *did-display-a-slide*) +(defvar *last-slide-displayed* nil) (defun slidemacs-entity-string (entity) (coerce (buffer-sequence (buffer entity) @@ -151,6 +152,9 @@ (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 @@ -170,6 +174,9 @@ (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 From dbarlow at common-lisp.net Fri Jun 17 10:42:33 2005 From: dbarlow at common-lisp.net (Dan Barlow) Date: Fri, 17 Jun 2005 12:42:33 +0200 (CEST) Subject: [climacs-cvs] CVS update: climacs/gui.lisp Message-ID: <20050617104233.6346D884CA@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv1346 Modified Files: gui.lisp Log Message: Fix errant apostrophe that was causing COMMAND-TABLE-NOT-FOUND errors at odd times Date: Fri Jun 17 12:42:32 2005 Author: dbarlow Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.144 climacs/gui.lisp:1.145 --- climacs/gui.lisp:1.144 Wed Jun 15 08:00:12 2005 +++ climacs/gui.lisp Fri Jun 17 12:42:32 2005 @@ -315,7 +315,7 @@ (progn (handler-case (with-input-context - ('(command :command-table 'global-climacs-table)) + ('(command :command-table global-climacs-table)) (object) (process-gestures) (t From bmastenbrook at common-lisp.net Sat Jun 18 02:01:58 2005 From: bmastenbrook at common-lisp.net (Brian Mastenbrook) Date: Sat, 18 Jun 2005 04:01:58 +0200 (CEST) Subject: [climacs-cvs] CVS update: climacs/gui.lisp climacs/slidemacs.lisp climacs/slidemacs-gui.lisp Message-ID: <20050618020158.55A11884CA@common-lisp.net> 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 From bmastenbrook at common-lisp.net Sat Jun 18 02:02:10 2005 From: bmastenbrook at common-lisp.net (Brian Mastenbrook) Date: Sat, 18 Jun 2005 04:02:10 +0200 (CEST) Subject: [climacs-cvs] CVS update: papers/ilc2005/syntax/climacs-slides.slidemacs Message-ID: <20050618020210.DE565884CA@common-lisp.net> Update of /project/climacs/cvsroot/papers/ilc2005/syntax In directory common-lisp.net:/tmp/cvs-serv25071 Modified Files: climacs-slides.slidemacs Log Message: Current state of the slides Date: Sat Jun 18 04:02:10 2005 Author: bmastenbrook Index: papers/ilc2005/syntax/climacs-slides.slidemacs diff -u papers/ilc2005/syntax/climacs-slides.slidemacs:1.3 papers/ilc2005/syntax/climacs-slides.slidemacs:1.4 --- papers/ilc2005/syntax/climacs-slides.slidemacs:1.3 Fri Jun 17 03:15:09 2005 +++ papers/ilc2005/syntax/climacs-slides.slidemacs Sat Jun 18 04:02:10 2005 @@ -1,8 +1,19 @@ slideset "Syntax Analysis in the Climacs Text Editor" { -info { author "Brian Mastenbrook" +info { author "Brian Mastenbrook (presenting)" institution "Motorola, Inc." +author "Christophe Rhodes" +institution "Department of Computing, Goldsmiths College" +author "Robert Strandh" +institution "Universit?? Bordeaux 1" venue "International Lisp Conference 2005" date } +slide "Outline" { +* "What is Climacs?" +* "Abstractions for buffer representation" +* "Abstractions for syntax analysis" +* "Future directions" +* "Demos" +} slide "Climacs" { * "An editor in the Emacs tradition" * "A framework for syntax-capable editing" @@ -14,10 +25,24 @@ * "Standard for user interfaces and graphics in Common Lisp" * "Free implementation in McCLIM" } +slide "Comparable editors" { +* "ZMacs - the famous Lisp machine editor" +* "SEdit, the InterLisp structure editor" +* "Hemlock, CMUCL's editor" +* "FRED Resembles Emacs Deliberately" +} +graph "Climacs Overview" { +vertical +root "Buffer abstraction" +edge from "Buffer abstraction" to "Syntax protocol" +edge from "Syntax protocol" to "Syntax-aware applications" +edge from "Syntax-aware applications" to "Climacs application" +edge from "Climacs application" to "CLIM" +} slide "Buffer protocol" { -* "Multiple buffer implementations" * "Protocol for editable sequence of objects" +* "Multiple buffer implementations" * "Mark implementation (left and right-sticky marks)" } slide "Buffer protocol, cont." @@ -28,20 +53,7 @@ } slide "Buffer protocol, cont." { -* "Gap buffer has good performance for localized editing operations" -* "Noticable delay to move gap in some situations" -* "Circular gap buffer improves performance in edge cases" -* "Slow to find line / column of given mark" -} -slide "Buffer protocol, cont." -{ -* "Better implementation could combine hemlock-like doubly-linked lists of lines with gap buffer" -* "Doubly-linked list of gap buffers would act as multiple-gap buffer" -* "LRU scheme to convert lines to compact representation" -} -slide "Buffer protocol, cont." -{ -* "Implementation using functional data structures" +* "Another implementation using functional data structures" * "Efficient undo across multiple undo histories" } slide "Syntax protocol" @@ -84,8 +96,10 @@ slide "Lexer and Parser" { * "Incremental lexer creates objects for each lexeme" * "Parser parses lexemes into production classes" +* "In Earley parser, parsing rules can include any code" } graph "Sample parser class hierarchy" { +horizontal root "parse-tree" edge from "parse-tree" to "ttcn3-parse-tree" edge from "ttcn3-parse-tree" to "ttcn3-entry" @@ -96,6 +110,22 @@ edge from "ttcn3-entry" to "ttcn3-nonterminal" edge from "ttcn3-entry" to "ttcn3-terminal" } +slide "Parser invocation" { +* "Climacs calls update-syntax-for-display or update-syntax" +* "Parser is passed top and bottom marks of out-of-date region" +* "Application can call its own parser or invoke Climacs' Earley parser" +} +slide "Advantages of Earley" { +* "No grammar preprocessing required" +* "Accepts full class of context-free grammars" +} +slide "Incremental parsers" { +* "Earley parser can be slow on some grammars" +* "New Lisp mode uses a LR shift/reduce parser and keeps entire +buffer up-to-date" +* "Slidemacs grammar is acceptably fast on Earley parser, but not all +languages are; worst case complexity is O(n^3)" +} slide "Parse tree display" { * "Application controls display of parse tree" * "Could be a simple colorised display of text..." @@ -108,14 +138,23 @@ * "Slidemacs GUI-mode editor" } slide "Future directions, cont." { -* "Beter resynchronization on parse errors" +* "LALR parser generator" +* "Better resynchronization on parse errors" * "More syntax modules" * "Other applications (news readers, mail) using Climacs for editable buffers" } +slide "Conclusion" { +* "Climacs has an exciting future" +* "Flexible buffer protocol enables more abstract editing operations" +* "Syntax protocol enables rich applications" +} slide "Demos" { * "Lisp mode and incremental parser" * "Slidemacs mode" * "Tabcode editor" +} +slide "Thanks!" { +* /Questions?/ } } From bmastenbrook at common-lisp.net Sat Jun 18 13:58:50 2005 From: bmastenbrook at common-lisp.net (Brian Mastenbrook) Date: Sat, 18 Jun 2005 15:58:50 +0200 (CEST) Subject: [climacs-cvs] CVS update: climacs/slidemacs-gui.lisp climacs/slidemacs.lisp Message-ID: <20050618135850.EA23F88027@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv3112 Modified Files: slidemacs-gui.lisp slidemacs.lisp Log Message: Partial but buggy support for printing slides to postscript Date: Sat Jun 18 15:58:49 2005 Author: bmastenbrook Index: climacs/slidemacs-gui.lisp diff -u climacs/slidemacs-gui.lisp:1.11 climacs/slidemacs-gui.lisp:1.12 --- climacs/slidemacs-gui.lisp:1.11 Sat Jun 18 04:01:56 2005 +++ climacs/slidemacs-gui.lisp Sat Jun 18 15:58:49 2005 @@ -56,8 +56,8 @@ (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))) + (traverse-list-entry (slot-value list-entry 'items) unit-type function) + (funcall function (slot-value list-entry 'item)))) (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 @@ -67,8 +67,10 @@ (display-parse-tree slideset-info syntax stream) (new-page stream) (traverse-list-entry nonempty-list-of-slides - 'slidemacs-slide + 'slidemacs-all-slide-types (lambda (slide) + (format *debug-io* "Displaying slide ~S~%" + slide) (display-parse-tree slide syntax stream) (new-page stream)))))) @@ -80,7 +82,7 @@ (let ((*handle-whitespace* nil)) (call-next-method))) -(defun display-text-with-wrap-for-pane (text pane) +(defmethod display-text-with-wrap-for-pane (text (pane climacs-pane)) (let* ((text (substitute #\space #\newline text)) (split (remove "" @@ -111,6 +113,10 @@ (write-string word pane)))) (terpri pane))) +(defmethod display-text-with-wrap-for-pane (text pane) + (stream-write-string pane text) + (terpri pane)) + (defparameter *slidemacs-sizes* '(:title 48 :bullet 32 @@ -183,11 +189,23 @@ (display-parse-tree slidemacs-slide-name syntax pane) (display-parse-tree nonempty-list-of-bullets syntax pane)))) +(defmacro possibly-capturing-and-flipping-output-twice + (pane conditional &body body) + `(flet ((b () , at body)) + (if ,conditional + (let ((rec (with-new-output-record (,pane) + (b)))) + (with-bounding-rectangle* + (x1 y1 x2 y2) rec + (draw-rectangle* ,pane x1 y1 x2 y2 :ink +flipping-ink+) + (draw-rectangle* ,pane x1 y1 x2 y2 :ink +flipping-ink+))) + (b)))) + (defmethod display-parse-tree ((parse-tree slidemacs-graph-slide) (syntax slidemacs-gui-syntax) pane) (when (or *no-check-point* (with-slots (point) pane - (when (and (mark>= point (start-offset parse-tree)) - (mark<= point (end-offset parse-tree)))))) + (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) @@ -222,37 +240,33 @@ (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+))))))) + (possibly-capturing-and-flipping-output-twice + pane (typep pane 'climacs-pane) + (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" + :stream pane + :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 + :move-cursor nil + )))))) (defmethod display-parse-tree ((entity slidemacs-slide-name) (syntax slidemacs-gui-syntax) pane) (with-text-style (pane `(:sans-serif :bold ,(getf *slidemacs-sizes* :title))) @@ -261,7 +275,7 @@ (terpri pane))) (defmethod display-parse-tree ((entity slidemacs-bullet) (syntax slidemacs-gui-syntax) pane) - (stream-increment-cursor-position pane (space-width pane) 0) + (stream-write-string pane " ") (with-text-style (pane `(:sans-serif :roman ,(getf *slidemacs-sizes* :bullet))) (if (and (not *no-check-point*) (with-slots (point) pane @@ -272,9 +286,9 @@ (call-next-method)))) (defmethod display-parse-tree ((entity bullet) (syntax slidemacs-gui-syntax) pane) - (stream-increment-cursor-position pane (space-width pane) 0) + (stream-write-string pane " ") (present (lexeme-string entity) 'string :stream pane) - (stream-increment-cursor-position pane (space-width pane) 0)) + (stream-write-string pane " ")) (defmethod display-parse-tree ((entity talking-point) (syntax slidemacs-gui-syntax) pane) (with-slots (slidemacs-string) entity Index: climacs/slidemacs.lisp diff -u climacs/slidemacs.lisp:1.4 climacs/slidemacs.lisp:1.5 --- climacs/slidemacs.lisp:1.4 Sat Jun 18 04:01:56 2005 +++ climacs/slidemacs.lisp Sat Jun 18 15:58:49 2005 @@ -394,10 +394,12 @@ (handle-whitespace pane (buffer pane) *white-space-start* (start-offset entity)) (setf *white-space-start* (end-offset entity)))) -(defmethod display-parse-tree :around ((entity slidemacs-parse-tree) syntax pane) - (with-slots (top bot) pane - (when (and (end-offset entity) (mark> (end-offset entity) top)) - (call-next-method)))) +(defmethod display-parse-tree :around ((entity slidemacs-parse-tree) (syntax slidemacs-editor-syntax) pane) + (if (not (typep syntax 'slidemacs-gui-syntax)) + (with-slots (top bot) pane + (when (and (end-offset entity) (mark> (end-offset entity) top)) + (call-next-method))) + (call-next-method))) (defmethod redisplay-pane-with-syntax ((pane climacs-pane) (syntax slidemacs-editor-syntax) current-p) (with-slots (top bot) pane From bmastenbrook at common-lisp.net Sun Jun 19 17:17:35 2005 From: bmastenbrook at common-lisp.net (Brian Mastenbrook) Date: Sun, 19 Jun 2005 19:17:35 +0200 (CEST) Subject: [climacs-cvs] CVS update: climacs/slidemacs-gui.lisp Message-ID: <20050619171735.CDFDC88167@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv5491 Modified Files: slidemacs-gui.lisp Log Message: Postscript export is getting there... Date: Sun Jun 19 19:17:35 2005 Author: bmastenbrook Index: climacs/slidemacs-gui.lisp diff -u climacs/slidemacs-gui.lisp:1.12 climacs/slidemacs-gui.lisp:1.13 --- climacs/slidemacs-gui.lisp:1.12 Sat Jun 18 15:58:49 2005 +++ climacs/slidemacs-gui.lisp Sun Jun 19 19:17:34 2005 @@ -41,7 +41,7 @@ (1- (end-offset entity))) 'string)) -(defparameter *no-check-point* nil) +(defparameter *postscript-display* 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 @@ -63,16 +63,13 @@ (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)) + (*postscript-display* t)) (display-parse-tree slideset-info syntax stream) - (new-page stream) (traverse-list-entry nonempty-list-of-slides 'slidemacs-all-slide-types (lambda (slide) - (format *debug-io* "Displaying slide ~S~%" - slide) - (display-parse-tree slide syntax stream) - (new-page stream)))))) + (new-page stream) + (display-parse-tree slide syntax stream)))))) (defmethod display-parse-tree ((parse-tree slidemacs-slideset-keyword) (syntax slidemacs-gui-syntax) pane) (format *debug-io* "Oops!~%") @@ -82,7 +79,7 @@ (let ((*handle-whitespace* nil)) (call-next-method))) -(defmethod display-text-with-wrap-for-pane (text (pane climacs-pane)) +(defun undisplay-text-with-wrap-for-pane (text pane) (let* ((text (substitute #\space #\newline text)) (split (remove "" @@ -113,10 +110,6 @@ (write-string word pane)))) (terpri pane))) -(defmethod display-text-with-wrap-for-pane (text pane) - (stream-write-string pane text) - (terpri pane)) - (defparameter *slidemacs-sizes* '(:title 48 :bullet 32 @@ -126,6 +119,8 @@ (defmethod display-parse-tree ((parse-tree slideset-info) (syntax slidemacs-gui-syntax) pane) (with-text-style (pane `(:sans-serif :bold ,(getf *slidemacs-sizes* :slideset-title))) + (when *postscript-display* + (loop repeat 2 do (terpri pane))) (display-text-with-wrap-for-pane *current-slideset* pane) (terpri pane)) @@ -178,7 +173,7 @@ (slidemacs-entity-string opt-date-string) pane))))) (defmethod display-parse-tree ((parse-tree slidemacs-slide) (syntax slidemacs-gui-syntax) pane) - (when (or *no-check-point* + (when (or *postscript-display* (with-slots (point) pane (and (mark>= point (start-offset parse-tree)) (mark<= point (end-offset parse-tree))))) @@ -202,7 +197,7 @@ (b)))) (defmethod display-parse-tree ((parse-tree slidemacs-graph-slide) (syntax slidemacs-gui-syntax) pane) - (when (or *no-check-point* + (when (or *postscript-display* (with-slots (point) pane (and (mark>= point (start-offset parse-tree)) (mark<= point (end-offset parse-tree))))) @@ -270,6 +265,8 @@ (defmethod display-parse-tree ((entity slidemacs-slide-name) (syntax slidemacs-gui-syntax) pane) (with-text-style (pane `(:sans-serif :bold ,(getf *slidemacs-sizes* :title))) + (when *postscript-display* + (loop repeat 2 do (terpri pane))) (display-text-with-wrap-for-pane (slidemacs-entity-string entity) pane) (terpri pane))) @@ -277,7 +274,7 @@ (defmethod display-parse-tree ((entity slidemacs-bullet) (syntax slidemacs-gui-syntax) pane) (stream-write-string pane " ") (with-text-style (pane `(:sans-serif :roman ,(getf *slidemacs-sizes* :bullet))) - (if (and (not *no-check-point*) + (if (and (not *postscript-display*) (with-slots (point) pane (and (mark>= point (start-offset entity)) (mark<= point (end-offset entity))))) @@ -318,6 +315,8 @@ (make-hash-table :test #'equal)) (defun load-and-cache-xpm (pathname) + nil + #+nil (let ((hash-key (cons pathname (file-write-date pathname)))) (let ((pattern (gethash hash-key *picture-cache*))) (if pattern pattern @@ -366,8 +365,8 @@ ;;; 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 +(defun postscript-print-pane (pane file) + (with-open-file (file-stream file :direction :output :if-exists :supersede) (with-output-to-postscript-stream (stream file-stream) @@ -467,28 +466,10 @@ (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 +(climacs-gui::define-named-command com-postscript-print-presentation () + (let ((pane (climacs-gui::current-window))) + (if (not (and (typep pane 'climacs-pane) + (typep (syntax (buffer pane)) 'slidemacs-gui-syntax))) + (beep) + (let ((file (accept 'climacs-gui::completable-pathname :prompt "Output to"))) + (postscript-print-pane pane file))))) \ No newline at end of file From bmastenbrook at common-lisp.net Mon Jun 20 17:33:12 2005 From: bmastenbrook at common-lisp.net (Brian Mastenbrook) Date: Mon, 20 Jun 2005 19:33:12 +0200 (CEST) Subject: [climacs-cvs] CVS update: climacs/slidemacs-gui.lisp Message-ID: <20050620173312.653A288167@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv31653 Modified Files: slidemacs-gui.lisp Log Message: Stub out some junk code Date: Mon Jun 20 19:33:11 2005 Author: bmastenbrook Index: climacs/slidemacs-gui.lisp diff -u climacs/slidemacs-gui.lisp:1.13 climacs/slidemacs-gui.lisp:1.14 --- climacs/slidemacs-gui.lisp:1.13 Sun Jun 19 19:17:34 2005 +++ climacs/slidemacs-gui.lisp Mon Jun 20 19:33:11 2005 @@ -64,12 +64,13 @@ (let ((*current-slideset* (slidemacs-entity-string slidemacs-slideset-name)) (*did-display-a-slide* nil) (*postscript-display* t)) - (display-parse-tree slideset-info syntax stream) - (traverse-list-entry nonempty-list-of-slides - 'slidemacs-all-slide-types - (lambda (slide) - (new-page stream) - (display-parse-tree slide syntax stream)))))) + (with-translation (stream 20 70) + (display-parse-tree slideset-info syntax stream) + (traverse-list-entry nonempty-list-of-slides + 'slidemacs-all-slide-types + (lambda (slide) + (new-page stream) + (display-parse-tree slide syntax stream))))))) (defmethod display-parse-tree ((parse-tree slidemacs-slideset-keyword) (syntax slidemacs-gui-syntax) pane) (format *debug-io* "Oops!~%") @@ -118,9 +119,7 @@ :slideset-info 32)) (defmethod display-parse-tree ((parse-tree slideset-info) (syntax slidemacs-gui-syntax) pane) - (with-text-style (pane `(:sans-serif :bold ,(getf *slidemacs-sizes* :slideset-title))) - (when *postscript-display* - (loop repeat 2 do (terpri pane))) + (with-text-style (pane `(:sans-serif :bold ,(getf *slidemacs-sizes* :slideset-title))) (display-text-with-wrap-for-pane *current-slideset* pane) (terpri pane)) @@ -260,13 +259,11 @@ :merge-duplicates t :duplicate-test #'equal :graph-type :tree - :move-cursor nil + :move-cursor t )))))) (defmethod display-parse-tree ((entity slidemacs-slide-name) (syntax slidemacs-gui-syntax) pane) - (with-text-style (pane `(:sans-serif :bold ,(getf *slidemacs-sizes* :title))) - (when *postscript-display* - (loop repeat 2 do (terpri pane))) + (with-text-style (pane `(:sans-serif :bold ,(getf *slidemacs-sizes* :title))) (display-text-with-wrap-for-pane (slidemacs-entity-string entity) pane) (terpri pane))) @@ -298,6 +295,7 @@ (display-text-with-wrap-for-pane bullet-text pane)) (terpri pane)))) +#+(or) (defun draw-picture (stream pattern) (multiple-value-bind (x y) (stream-cursor-position stream) @@ -311,25 +309,27 @@ (make-translation-transformation x y) pattern))))) +#+(or) (defparameter *picture-cache* (make-hash-table :test #'equal)) +#+(or) (defun load-and-cache-xpm (pathname) nil - #+nil (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)))))) +#+(or) (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) + (with-output-recording-options (pane :record nil :draw 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)))))) @@ -369,7 +369,7 @@ (with-open-file (file-stream file :direction :output :if-exists :supersede) (with-output-to-postscript-stream - (stream file-stream) + (stream file-stream :orientation :landscape :device-type :letter) (with-drawing-options (stream :ink *slidemacs-gui-ink*) (with-slots (top bot point) pane (let ((syntax (syntax (buffer pane)))) From bmastenbrook at common-lisp.net Tue Jun 21 16:51:28 2005 From: bmastenbrook at common-lisp.net (Brian Mastenbrook) Date: Tue, 21 Jun 2005 18:51:28 +0200 (CEST) Subject: [climacs-cvs] CVS update: climacs/slidemacs-gui.lisp climacs/slidemacs.lisp Message-ID: <20050621165128.E5B6E88027@common-lisp.net> 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 From bmastenbrook at common-lisp.net Wed Jun 22 17:01:39 2005 From: bmastenbrook at common-lisp.net (Brian Mastenbrook) Date: Wed, 22 Jun 2005 19:01:39 +0200 (CEST) Subject: [climacs-cvs] CVS update: papers/ilc2005/syntax/climacs-slides.slidemacs Message-ID: <20050622170139.A649088167@common-lisp.net> Update of /project/climacs/cvsroot/papers/ilc2005/syntax In directory common-lisp.net:/tmp/cvs-serv10265 Modified Files: climacs-slides.slidemacs Log Message: Add the current version of the slides Date: Wed Jun 22 19:01:38 2005 Author: bmastenbrook Index: papers/ilc2005/syntax/climacs-slides.slidemacs diff -u papers/ilc2005/syntax/climacs-slides.slidemacs:1.4 papers/ilc2005/syntax/climacs-slides.slidemacs:1.5 --- papers/ilc2005/syntax/climacs-slides.slidemacs:1.4 Sat Jun 18 04:02:10 2005 +++ papers/ilc2005/syntax/climacs-slides.slidemacs Wed Jun 22 19:01:38 2005 @@ -8,24 +8,28 @@ venue "International Lisp Conference 2005" date } slide "Outline" { -* "What is Climacs?" -* "Abstractions for buffer representation" -* "Abstractions for syntax analysis" -* "Future directions" +* "What is Climacs? Why Climacs?" +* "How does it work?" +* "What will it do in the future?" * "Demos" } slide "Climacs" { * "An editor in the Emacs tradition" * "A framework for syntax-capable editing" * "A CLIM application" -* "Protocols for buffer implementation and syntax analysis" } slide "CLIM" { * "The Common Lisp Interface Manager" * "Standard for user interfaces and graphics in Common Lisp" * "Free implementation in McCLIM" } -slide "Comparable editors" { +slide "Climacs in CLIM" { +* "Display implemented with arbitrary CLIM methods" +* "Here's a presentation:" +reveal "This is a presentation object" "... and this is something it +can do" +} +slide "Historical editors" { * "ZMacs - the famous Lisp machine editor" * "SEdit, the InterLisp structure editor" * "Hemlock, CMUCL's editor" @@ -62,23 +66,36 @@ * "Support for incremental lexers and parsers" * "BYO or use the included Earley parser" } -slide "Syntax protocol, cont." -{ -* "Two major kinds of syntax modes" -* "Per-window parsing functions" -* "Per-buffer parsing functions" +slide "Lexer and Parser" { +* "Incremental lexer creates objects for each lexeme" +* "Parser parses lexemes into production classes" +* "In Earley parser, parsing rules can include any code" } -slide "Syntax protocol, cont." -{ -* "Per-window parsing keeps parse tree up to date in window area" -* "Useful when parser function is slow" -* "Not suitable when parse tree is used for something else" +graph "Sample parser class hierarchy" { +horizontal +root "parse-tree" +edge from "parse-tree" to "ttcn3-parse-tree" +edge from "ttcn3-parse-tree" to "ttcn3-entry" +edge from "ttcn3-entry" to "ttcn3-lexeme" +edge from "ttcn3-lexeme" to /lexeme classes/ +edge from "ttcn3-entry" to /parser production classes/ +edge from "ttcn3-entry" to "empty-ttcn3-terminals" +edge from "ttcn3-entry" to "ttcn3-nonterminal" +edge from "ttcn3-entry" to "ttcn3-terminal" +} +slide "Parser invocation: update-syntax" { +* "(update-syntax buffer (syntax buffer))" +* "buffer has two slots containing marks: top and bot" +* "top and bot denote the region which is out-of-date" +* "Application can call its own parser or invoke Climacs' Earley +parser" } slide "Syntax protocol, cont." { +* "Specializing update-syntax implements per-buffer parsing" * "Per-buffer parsing keeps whole buffer parse tree up to date" * "Useful when parser function is fast, or" -* "when parse tree is used for another application" +* "when complete parse tree is used for another application" } slide "Per-window parsing" { @@ -87,33 +104,38 @@ * "TTCN-3" * "HTML" } +slide "Parser invocation: update-syntax-for-display" { +* "Pane calls update-syntax-for-display with on-screen region" +* "Application updates syntax in the on-screen region" +* "Parsing is based on already up-to-date off-screen region" +} +slide "Syntax protocol, cont." +{ +* "Specializing update-syntax-for-display implements per-window parsing" +* "Per-window parsing keeps parse tree up to date in window area" +* "Useful when parser function is slow" +* "Not suitable when parse tree is used for something else" +} slide "Per-buffer parsing" { * "New Lisp syntax (parsing is fast)" * "Slidemacs syntax (used for slide display)" * "Tabcode editor (used for tablature display)" } -slide "Lexer and Parser" { -* "Incremental lexer creates objects for each lexeme" -* "Parser parses lexemes into production classes" -* "In Earley parser, parsing rules can include any code" +slide "Display" { +* "Climacs is a good CLIM citizen" +* "This means you can use any presentation type or display in a syntax" } -graph "Sample parser class hierarchy" { -horizontal -root "parse-tree" -edge from "parse-tree" to "ttcn3-parse-tree" -edge from "ttcn3-parse-tree" to "ttcn3-entry" -edge from "ttcn3-entry" to "ttcn3-lexeme" -edge from "ttcn3-lexeme" to /lexeme classes/ -edge from "ttcn3-entry" to /parser production classes/ -edge from "ttcn3-entry" to "empty-ttcn3-terminals" -edge from "ttcn3-entry" to "ttcn3-nonterminal" -edge from "ttcn3-entry" to "ttcn3-terminal" +slide "Parse tree display" { +* "Application controls display of parse tree" +* "Could be a simple colorised display of text..." +* "... or a specialized display of the parse tree" } -slide "Parser invocation" { -* "Climacs calls update-syntax-for-display or update-syntax" -* "Parser is passed top and bottom marks of out-of-date region" -* "Application can call its own parser or invoke Climacs' Earley parser" +slide "Parse tree display, cont." { +* "Or it could be any CLIM presentation:" +url "http://www.common-lisp.net/project/climacs/" +reveal "Another presentation" "Hello, world!" +* "Where's the information for that popup?" } slide "Advantages of Earley" { * "No grammar preprocessing required" @@ -126,11 +148,6 @@ * "Slidemacs grammar is acceptably fast on Earley parser, but not all languages are; worst case complexity is O(n^3)" } -slide "Parse tree display" { -* "Application controls display of parse tree" -* "Could be a simple colorised display of text..." -* "... or a specialized display of the parse tree" -} slide "Future directions" { * "More improvements to McCLIM (speed, completeness)" * "Better Lisp mode" @@ -151,10 +168,12 @@ } slide "Demos" { * "Lisp mode and incremental parser" +* "Prolog mode" * "Slidemacs mode" * "Tabcode editor" } slide "Thanks!" { * /Questions?/ +url "http://www.common-lisp.net/project/climacs/" } } From bmastenbrook at common-lisp.net Wed Jun 22 18:36:00 2005 From: bmastenbrook at common-lisp.net (Brian Mastenbrook) Date: Wed, 22 Jun 2005 20:36:00 +0200 (CEST) Subject: [climacs-cvs] CVS update: climacs/gui.lisp climacs/pane.lisp Message-ID: <20050622183600.5527A88167@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv15864 Modified Files: gui.lisp pane.lisp Log Message: Add an :after method on (setf syntax) for buffers; this updates the top and bottom marks correctly Date: Wed Jun 22 20:35:59 2005 Author: bmastenbrook Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.146 climacs/gui.lisp:1.147 --- climacs/gui.lisp:1.146 Sat Jun 18 04:01:56 2005 +++ climacs/gui.lisp Wed Jun 22 20:35:59 2005 @@ -904,13 +904,6 @@ (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))) @@ -919,9 +912,7 @@ (progn (beep) (display-message "No such syntax") (return-from com-set-syntax nil))) - :buffer (buffer (point pane)))) - (setf (offset (low-mark buffer)) 0 - (offset (high-mark buffer)) (size buffer)))) + :buffer (buffer (point pane)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Index: climacs/pane.lisp diff -u climacs/pane.lisp:1.26 climacs/pane.lisp:1.27 --- climacs/pane.lisp:1.26 Mon May 9 16:47:45 2005 +++ climacs/pane.lisp Wed Jun 22 20:35:59 2005 @@ -210,6 +210,10 @@ 'basic-syntax :buffer (implementation buffer)) point (clone-mark (low-mark buffer) :right)))) +(defmethod (setf syntax) :after (syntax (buffer climacs-buffer)) + (setf (offset (low-mark buffer)) 0 + (offset (high-mark buffer)) (size buffer))) + (defclass climacs-pane (application-pane) ((buffer :initform (make-instance 'climacs-buffer) :accessor buffer) (point :initform nil :initarg :point :accessor point) @@ -250,7 +254,7 @@ (with-slots (buffer top bot scan) pane (setf top (clone-mark (low-mark buffer) :left) bot (clone-mark (high-mark buffer) :right))) - (setf (stream-default-view pane) (make-instance 'climacs-textual-view)) + (setf (stream-default-view pane) (make-instance 'climacs-textual-view)) (with-slots (space-width tab-width) (stream-default-view pane) (let* ((medium (sheet-medium pane)) (style (medium-text-style medium))) From bmastenbrook at common-lisp.net Wed Jun 22 18:36:13 2005 From: bmastenbrook at common-lisp.net (Brian Mastenbrook) Date: Wed, 22 Jun 2005 20:36:13 +0200 (CEST) Subject: [climacs-cvs] CVS update: climacs/slidemacs-gui.lisp Message-ID: <20050622183613.F3A2088167@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv15901 Modified Files: slidemacs-gui.lisp Log Message: MORE RED PRESENTATIONS Date: Wed Jun 22 20:36:13 2005 Author: bmastenbrook Index: climacs/slidemacs-gui.lisp diff -u climacs/slidemacs-gui.lisp:1.15 climacs/slidemacs-gui.lisp:1.16 --- climacs/slidemacs-gui.lisp:1.15 Tue Jun 21 18:51:05 2005 +++ climacs/slidemacs-gui.lisp Wed Jun 22 20:36:13 2005 @@ -300,7 +300,9 @@ (define-presentation-method present (object (type slidemacs-url) stream (view textual-view) &key &allow-other-keys) - (display-text-with-wrap-for-pane object stream)) + (with-drawing-options (stream :ink +blue+) + (surrounding-output-with-border (stream :shape :underline) + (display-text-with-wrap-for-pane object stream)))) (define-command (com-browse-to-url :name "Browse To URL" :command-table global-command-table @@ -341,8 +343,18 @@ 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))) + (let (record) + (with-output-to-output-record (stream 'standard-sequence-output-record rec) + (display-text-with-wrap-for-pane (slidemacs-entity-string button-label) + stream) + (setf record rec)) + (multiple-value-bind (sx sy) (stream-cursor-position stream) + (setf (output-record-position record) (values sx sy)) + (with-bounding-rectangle* (x1 y1 x2 y2) record + (draw-rectangle* stream x1 y1 x2 y2 :filled t :line-thickness 1 :ink (make-rgb-color 1.0 0.7 0.7)) + (stream-add-output-record stream record) + (stream-increment-cursor-position stream (- x2 x1) + (- y2 y1))))))) (define-command (com-reveal-text :name "Reveal Text In Window" :command-table global-command-table @@ -525,11 +537,11 @@ (syntax (syntax buffer))) (typecase syntax (slidemacs-gui-syntax - (climacs-gui::set-syntax (make-instance 'slidemacs-editor-syntax - :buffer buffer))) + (setf (syntax buffer) (make-instance 'slidemacs-editor-syntax + :buffer buffer))) (slidemacs-editor-syntax - (climacs-gui::set-syntax (make-instance 'slidemacs-gui-syntax - :buffer buffer)))))) + (setf (syntax buffer) (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) From rstrandh at common-lisp.net Wed Jun 1 16:42:28 2005 From: rstrandh at common-lisp.net (Robert Strandh) Date: Wed, 1 Jun 2005 18:42:28 +0200 (CEST) Subject: [climacs-cvs] CVS update: climacs/lisp-syntax.lisp Message-ID: <20050601164228.04A97880DC@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv27858 Modified Files: lisp-syntax.lisp Log Message: Order-of-magnitude improvement in the speed of the incremental LR parser. Date: Wed Jun 1 18:42:28 2005 Author: rstrandh Index: climacs/lisp-syntax.lisp diff -u climacs/lisp-syntax.lisp:1.4 climacs/lisp-syntax.lisp:1.5 --- climacs/lisp-syntax.lisp:1.4 Mon May 30 15:47:21 2005 +++ climacs/lisp-syntax.lisp Wed Jun 1 18:42:28 2005 @@ -365,6 +365,15 @@ do (push (pop-one syntax) result) finally (return result))) +(defmacro reduce-fixed-number (symbol nb-children) + `(let ((result (make-instance ',symbol :children (pop-number syntax ,nb-children)))) + (when (zerop ,nb-children) + (with-slots (scan) syntax + (with-slots (start-mark size) result + (setf start-mark (clone-mark scan :right) + size 0)))) + result)) + (defun pop-until-type (syntax type) (with-slots (stack-top) syntax (loop with result = '() @@ -373,6 +382,16 @@ until (typep child type) finally (return result)))) +(defmacro reduce-until-type (symbol type) + `(let ((result (make-instance ',symbol + :children (pop-until-type syntax ',type)))) + (when (null (children result)) + (with-slots (scan) syntax + (with-slots (start-mark size) result + (setf start-mark (clone-mark scan :right) + size 0)))) + result)) + (defun pop-all (syntax) (with-slots (stack-top) syntax (loop with result = '() @@ -380,6 +399,15 @@ do (push (pop-one syntax) result) finally (return result)))) +(defmacro reduce-all (symbol) + `(let ((result (make-instance ',symbol :children (pop-all syntax)))) + (when (null (children result)) + (with-slots (scan) syntax + (with-slots (start-mark size) result + (setf start-mark (clone-mark scan :right) + size 0)))) + result)) + (define-parser-state error-state (lexer-toplevel-state parser-state) ()) (define-parser-state error-reduce-state (lexer-toplevel-state parser-state) ()) @@ -392,7 +420,7 @@ ;;; the action on end-of-buffer is to reduce to the error symbol (define-lisp-action (t (eql nil)) - (make-instance 'error-symbol :children (pop-all syntax))) + (reduce-all error-symbol)) ;;; the default new state is the error state (define-new-lisp-state (t parser-symbol) error-state) @@ -400,8 +428,6 @@ ;;; the new state when an error-state (define-new-lisp-state (t error-symbol) error-reduce-state) -(defmacro reduce-rule (symbol nb-children) - `(make-instance ',symbol :children (pop-number syntax ,nb-children))) ;;;;;;;;;;;;;;;; Top-level @@ -420,7 +446,7 @@ (define-new-lisp-state (|initial-state | form) |initial-state |) (define-lisp-action (|initial-state | (eql nil)) - (make-instance 'form* :children (pop-all syntax))) + (reduce-all form*)) (define-new-lisp-state (|initial-state | form*) |form* | ) @@ -445,8 +471,7 @@ ;;; reduce according to the rule form -> ( form* ) (define-lisp-action (|( form* ) | t) - (make-instance 'list-form - :children (pop-until-type syntax 'left-parenthesis-lexeme))) + (reduce-until-type list-form left-parenthesis-lexeme)) ;;;;;;;;;;;;;;;; String @@ -463,8 +488,7 @@ ;;; reduce according to the rule form -> " word* " (define-lisp-action (|" word* " | t) - (make-instance 'string-form - :children (pop-until-type syntax 'string-start-lexeme))) + (reduce-until-type string-form string-start-lexeme)) ;;;;;;;;;;;;;;;; Line comment @@ -481,8 +505,7 @@ ;;; reduce according to the rule form -> ; word* NL (define-lisp-action (|; word* NL | t) - (make-instance 'line-comment-form - :children (pop-until-type syntax 'line-comment-start-lexeme))) + (reduce-until-type line-comment-form line-comment-start-lexeme)) ;;;;;;;;;;;;;;;; Long comment @@ -503,8 +526,7 @@ ;;; reduce according to the rule form -> #| word* |# (define-lisp-action (|#\| word* \|# | t) - (make-instance 'long-comment-form - :children (pop-until-type syntax 'long-comment-start-lexeme))) + (reduce-until-type long-comment-form long-comment-start-lexeme)) ;;;;;;;;;;;;;;;; Symbol name surrounded with vertical bars @@ -520,8 +542,7 @@ ;;; reduce according to the rule form -> | text* | (define-lisp-action (|\| text* \| | t) - (make-instance 'symbol-form - :children (pop-until-type syntax 'symbol-start-lexeme))) + (reduce-until-type symbol-form symbol-start-lexeme)) ;;;;;;;;;;;;;;;; Quote @@ -536,7 +557,7 @@ ;;; reduce according to the rule form -> ' form (define-lisp-action (|' form | t) - (reduce-rule quote-form 2)) + (reduce-fixed-number quote-form 2)) ;;;;;;;;;;;;;;;; Backquote @@ -551,7 +572,7 @@ ;;; reduce according to the rule form -> ` form (define-lisp-action (|` form | t) - (reduce-rule backquote-form 2)) + (reduce-fixed-number backquote-form 2)) ;;;;;;;;;;;;;;;; Comma @@ -566,7 +587,7 @@ ;;; reduce according to the rule form -> , form (define-lisp-action (|, form | t) - (reduce-rule backquote-form 2)) + (reduce-fixed-number backquote-form 2)) ;;;;;;;;;;;;;;;; Function @@ -581,7 +602,7 @@ ;;; reduce according to the rule form -> #' form (define-lisp-action (|#' form | t) - (reduce-rule function-form 2)) + (reduce-fixed-number function-form 2)) ;;;;;;;;;;;;;;;; Reader conditionals @@ -604,10 +625,10 @@ (define-new-lisp-state (|#- form | form) |#- form form |) (define-lisp-action (|#+ form form | t) - (reduce-rule reader-conditional-positive-form 3)) + (reduce-fixed-number reader-conditional-positive-form 3)) (define-lisp-action (|#- form form | t) - (reduce-rule reader-conditional-negative-form 3)) + (reduce-fixed-number reader-conditional-negative-form 3)) ;;;;;;;;;;;;;;;; uninterned symbol @@ -622,7 +643,7 @@ ;;; reduce according to the rule form -> #: form (define-lisp-action (|#: form | t) - (reduce-rule uninterned-symbol-form 2)) + (reduce-fixed-number uninterned-symbol-form 2)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -640,12 +661,7 @@ (setf parser-state current-state current-state new-state preceding-parse-tree stack-top - stack-top new-parser-symbol))))) - -(defun parse-until-shift (syntax) - (with-slots (stack-top scan) syntax - (loop do (parser-step syntax) - until (typep stack-top 'lexeme)) + stack-top new-parser-symbol))) (setf (offset scan) (end-offset stack-top)))) (defun prev-tree (tree) @@ -691,35 +707,39 @@ finally (return tree))) (t (car parse-trees)))) -(defun find-next-lexeme (parse-tree) - (loop for tree = (next-tree parse-tree) then (next-tree tree) - until (or (null tree) (typep tree 'lexeme)) - finally (return tree))) - (defun parse-tree-equal (tree1 tree2) (and (eq (class-of tree1) (class-of tree2)) (eq (parser-state tree1) (parser-state tree2)) - (= (start-offset tree1) (start-offset tree2)) (= (end-offset tree1) (end-offset tree2)))) +(defmethod print-object ((mark mark) stream) + (print-unreadable-object (mark stream :type t :identity t) + (format stream "~s" (offset mark)))) + (defun parse-patch (syntax) (with-slots (current-state stack-top scan potentially-valid-trees) syntax - (parse-until-shift syntax) + (parser-step syntax) + (finish-output *trace-output*) (cond ((parse-tree-equal stack-top potentially-valid-trees) - (setf (slot-value potentially-valid-trees 'preceding-parse-tree) - (slot-value stack-top 'preceding-parse-tree)) + (unless (or (null (parent potentially-valid-trees)) + (eq potentially-valid-trees + (car (last (children (parent potentially-valid-trees)))))) + (loop for tree = (cadr (member potentially-valid-trees + (children (parent potentially-valid-trees)) + :test #'eq)) + then (car (children tree)) + until (null tree) + do (setf (slot-value tree 'preceding-parse-tree) + stack-top)) + (setf stack-top (prev-tree (parent potentially-valid-trees)))) (setf potentially-valid-trees (parent potentially-valid-trees)) - (setf stack-top potentially-valid-trees) - (loop until (typep stack-top 'lexeme) - do (setf stack-top (prev-tree stack-top))) (setf current-state (new-state syntax (parser-state stack-top) stack-top)) - (setf potentially-valid-trees (find-next-lexeme potentially-valid-trees) - (offset scan) (end-offset stack-top))) + (setf (offset scan) (end-offset stack-top))) (t (loop until (or (null potentially-valid-trees) (>= (start-offset potentially-valid-trees) (end-offset stack-top))) do (setf potentially-valid-trees - (find-next-lexeme potentially-valid-trees))))))) + (next-tree potentially-valid-trees))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; From bmastenbrook at common-lisp.net Sun Jun 5 01:59:53 2005 From: bmastenbrook at common-lisp.net (Brian Mastenbrook) Date: Sun, 5 Jun 2005 03:59:53 +0200 (CEST) Subject: [climacs-cvs] CVS update: climacs/slidemacs-gui.lisp climacs/slidemacs.lisp climacs/climacs.asd Message-ID: <20050605015953.87BF48802E@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv30163 Modified Files: climacs.asd Added Files: slidemacs-gui.lisp slidemacs.lisp Log Message: Add a new syntax: slidemacs is a slideshow textual description and presentation format. Date: Sun Jun 5 03:59:52 2005 Author: bmastenbrook Index: climacs/climacs.asd diff -u climacs/climacs.asd:1.30 climacs/climacs.asd:1.31 --- climacs/climacs.asd:1.30 Mon May 30 09:25:13 2005 +++ climacs/climacs.asd Sun Jun 5 03:59:52 2005 @@ -67,6 +67,8 @@ "ttcn3-syntax" "lisp-syntax" "gui" + "slidemacs" + "slidemacs-gui" ;;---- optional ---- "testing/rt" "buffer-test" From bmastenbrook at common-lisp.net Sun Jun 5 21:11:18 2005 From: bmastenbrook at common-lisp.net (Brian Mastenbrook) Date: Sun, 5 Jun 2005 23:11:18 +0200 (CEST) Subject: [climacs-cvs] CVS update: climacs/slidemacs-gui.lisp Message-ID: <20050605211118.18BDC880DD@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv2043 Modified Files: slidemacs-gui.lisp Log Message: Kill the C-1 and C-2 key shortcuts Date: Sun Jun 5 23:11:18 2005 Author: bmastenbrook Index: climacs/slidemacs-gui.lisp diff -u climacs/slidemacs-gui.lisp:1.1 climacs/slidemacs-gui.lisp:1.2 --- climacs/slidemacs-gui.lisp:1.1 Sun Jun 5 03:59:52 2005 +++ climacs/slidemacs-gui.lisp Sun Jun 5 23:11:18 2005 @@ -54,7 +54,7 @@ (display-parse-tree nonempty-list-of-bullets syntax pane))))) (defmethod display-parse-tree ((entity slidemacs-slide-name) (syntax slidemacs-gui-syntax) pane) - (with-text-style (pane '(:serif :bold :huge)) + (with-text-style (pane '(:serif :bold 64)) (present (coerce (buffer-sequence (buffer syntax) (1+ (start-offset entity)) (1- (end-offset entity))) @@ -64,7 +64,7 @@ (loop repeat 2 do (terpri pane)))) (defmethod display-parse-tree ((entity slidemacs-bullet) (syntax slidemacs-gui-syntax) pane) - (with-text-style (pane '(:serif :roman :very-large)) + (with-text-style (pane '(:serif :roman 48)) (with-slots (point) pane (if (and (mark>= point (start-offset entity)) (mark<= point (end-offset entity))) @@ -156,5 +156,3 @@ (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 '(#\1 :control) 'com-set-colors-for-presentation) -(climacs-gui::global-set-key '(#\2 :control) 'com-set-colors-for-editing) \ No newline at end of file From bmastenbrook at common-lisp.net Sun Jun 5 23:26:19 2005 From: bmastenbrook at common-lisp.net (Brian Mastenbrook) Date: Mon, 6 Jun 2005 01:26:19 +0200 (CEST) Subject: [climacs-cvs] CVS update: climacs/slidemacs-gui.lisp Message-ID: <20050605232619.DDFDA880DD@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv10937 Modified Files: slidemacs-gui.lisp Log Message: Black on white by default Date: Mon Jun 6 01:26:18 2005 Author: bmastenbrook Index: climacs/slidemacs-gui.lisp diff -u climacs/slidemacs-gui.lisp:1.2 climacs/slidemacs-gui.lisp:1.3 --- climacs/slidemacs-gui.lisp:1.2 Sun Jun 5 23:11:18 2005 +++ climacs/slidemacs-gui.lisp Mon Jun 6 01:26:18 2005 @@ -73,6 +73,7 @@ (call-next-method))))) (defmethod display-parse-tree ((entity bullet) (syntax slidemacs-gui-syntax) pane) + (stream-increment-cursor-position pane (space-width pane) 0) (present (lexeme-string entity) 'string :stream pane) (stream-increment-cursor-position pane (space-width pane) 0)) @@ -95,13 +96,16 @@ 'string :stream pane))) +(defparameter *slidemacs-gui-ink* +black+) + (defun set-pane-colors (pane c1 c2) (setf (medium-background (sheet-medium pane)) c1 - (medium-ink (sheet-medium pane)) c2) + (medium-ink (sheet-medium pane)) c2 + *slidemacs-gui-ink* c2) (window-refresh pane)) (defmethod redisplay-pane-with-syntax ((pane climacs-pane) (syntax slidemacs-gui-syntax) current-p) - (with-drawing-options (pane :ink +white+) + (with-drawing-options (pane :ink *slidemacs-gui-ink*) (with-slots (top bot point) pane (with-slots (lexer) syntax ;; display the parse tree if any From bmastenbrook at common-lisp.net Sun Jun 5 23:27:46 2005 From: bmastenbrook at common-lisp.net (Brian Mastenbrook) Date: Mon, 6 Jun 2005 01:27:46 +0200 (CEST) Subject: [climacs-cvs] CVS update: climacs/slidemacs-gui.lisp Message-ID: <20050605232746.5B35B880DD@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv11003 Modified Files: slidemacs-gui.lisp Log Message: Sorry for the very fine-grained commits: I'm trying to synchronize my trees between two machines right now. Add a space before the title to offset it a bit from the exact left side of the buffer Date: Mon Jun 6 01:27:45 2005 Author: bmastenbrook Index: climacs/slidemacs-gui.lisp diff -u climacs/slidemacs-gui.lisp:1.3 climacs/slidemacs-gui.lisp:1.4 --- climacs/slidemacs-gui.lisp:1.3 Mon Jun 6 01:26:18 2005 +++ climacs/slidemacs-gui.lisp Mon Jun 6 01:27:45 2005 @@ -64,6 +64,7 @@ (loop repeat 2 do (terpri 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-slots (point) pane (if (and (mark>= point (start-offset entity)) From bmastenbrook at common-lisp.net Fri Jun 24 14:54:07 2005 From: bmastenbrook at common-lisp.net (Brian Mastenbrook) Date: Fri, 24 Jun 2005 16:54:07 +0200 (CEST) Subject: [climacs-cvs] CVS update: papers/ilc2005/syntax/climacs-slides.slidemacs Message-ID: <20050624145407.2BF6B88027@common-lisp.net> Update of /project/climacs/cvsroot/papers/ilc2005/syntax In directory common-lisp.net:/tmp/cvs-serv22804 Modified Files: climacs-slides.slidemacs Log Message: Commit the slides I actually used Date: Fri Jun 24 16:54:06 2005 Author: bmastenbrook Index: papers/ilc2005/syntax/climacs-slides.slidemacs diff -u papers/ilc2005/syntax/climacs-slides.slidemacs:1.5 papers/ilc2005/syntax/climacs-slides.slidemacs:1.6 --- papers/ilc2005/syntax/climacs-slides.slidemacs:1.5 Wed Jun 22 19:01:38 2005 +++ papers/ilc2005/syntax/climacs-slides.slidemacs Fri Jun 24 16:54:06 2005 @@ -15,8 +15,13 @@ } slide "Climacs" { * "An editor in the Emacs tradition" -* "A framework for syntax-capable editing" * "A CLIM application" +* "A framework for syntax-capable editing" +} +slide "Syntax-capable editing" { +* "What's syntax-capable editing?" +* "Editing with rich information derived from lexical properties" +* "Two quick demos" } slide "CLIM" { * "The Common Lisp Interface Manager" @@ -134,7 +139,7 @@ slide "Parse tree display, cont." { * "Or it could be any CLIM presentation:" url "http://www.common-lisp.net/project/climacs/" -reveal "Another presentation" "Hello, world!" +reveal "Click me!" "Hello, world!" * "Where's the information for that popup?" } slide "Advantages of Earley" { From rstrandh at common-lisp.net Tue Jun 28 05:02:36 2005 From: rstrandh at common-lisp.net (Robert Strandh) Date: Tue, 28 Jun 2005 07:02:36 +0200 (CEST) Subject: [climacs-cvs] CVS update: climacs/gui.lisp climacs/undo.lisp Message-ID: <20050628050236.4589D880E0@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv15953 Modified Files: gui.lisp undo.lisp Log Message: Fixed a few bugs in the calls to undo and redo (thanks to Dirk Gerrits for reporting these) Date: Tue Jun 28 07:02:35 2005 Author: rstrandh Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.147 climacs/gui.lisp:1.148 --- climacs/gui.lisp:1.147 Wed Jun 22 20:35:59 2005 +++ climacs/gui.lisp Tue Jun 28 07:02:34 2005 @@ -1300,11 +1300,13 @@ ;;; Undo/redo (define-named-command com-undo () - (undo (undo-tree (buffer (current-window)))) + (handler-case (undo (undo-tree (buffer (current-window)))) + (no-more-undo () (beep) (display-message "No more undo"))) (full-redisplay (current-window))) (define-named-command com-redo () - (redo (undo-tree (buffer (current-window)))) + (handler-case (redo (undo-tree (buffer (current-window)))) + (no-more-undo () (beep) (display-message "No more redo"))) (full-redisplay (current-window))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Index: climacs/undo.lisp diff -u climacs/undo.lisp:1.1 climacs/undo.lisp:1.2 --- climacs/undo.lisp:1.1 Mon Jan 24 14:12:52 2005 +++ climacs/undo.lisp Tue Jun 28 07:02:34 2005 @@ -65,8 +65,8 @@ (:documentation "Protocol class for all undo trees")) (defclass standard-undo-tree (undo-tree) - ((current-record :initform nil :accessor current-record) - (leaf-record :initform nil :accessor leaf-record) + ((current-record :accessor current-record) + (leaf-record :accessor leaf-record) (redo-path :initform '() :accessor redo-path) (children :initform '() :accessor children) (depth :initform 0 :reader depth)) @@ -74,7 +74,8 @@ (defmethod initialize-instance :after ((tree standard-undo-tree) &rest args) (declare (ignore args)) - (setf (current-record tree) tree)) + (setf (current-record tree) tree + (leaf-record tree) tree)) (defclass undo-record () () (:documentation "The protocol class for all undo records."))