From: Matt Birkholz Date: Mon, 11 Feb 2013 22:50:11 +0000 (-0700) Subject: gtk-screen: Crude face support using pango-layout-set-markup. X-Git-Tag: mit-scheme-pucked-9.2.12~366^2~59 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=0dd6baab179a47985c326707bebe234ed1da4878;p=mit-scheme.git gtk-screen: Crude face support using pango-layout-set-markup. --- diff --git a/src/gtk-screen/gtk-faces.scm b/src/gtk-screen/gtk-faces.scm new file mode 100644 index 000000000..a41eff18e --- /dev/null +++ b/src/gtk-screen/gtk-faces.scm @@ -0,0 +1,173 @@ +#| -*-Scheme-*- + +Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, + 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, + 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013 Massachusetts + Institute of Technology + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or (at +your option) any later version. + +MIT/GNU Scheme is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +General Public License for more details. + +You should have received a copy of the GNU General Public License +along with MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, +USA. + +|# + +;;;; Support for the FACE text property. +;;; package: (edwin screen gtk-screen) + +(define-command add-text-property + "Adds a text property to the current region." + (lambda () + (let* ((key (prompt-for-expression "Key")) + (val (prompt-for-expression "Value"))) + (list key val (current-region)))) + (lambda (key val region) + (add-text-property (mark-group (region-start region)) + (mark-index (region-start region)) + (mark-index (region-end region)) + key val))) + +(define-structure markup-context + image image-index image-end + column tab-width char-image-strings) + +(define (markup-add-char! context char) + ;; Does NOT increment column. + (let ((image-index (markup-context-image-index context)) + (image-end (markup-context-image-end context))) + (if (fix:< image-index image-end) + (let ((image (markup-context-image context))) + (string-set! image image-index char) + (set-markup-context-image-index! context (fix:1+ image-index)))))) + +(define (markup-add-string! context string) + ;; Does NOT increment column. + (let ((image-index (markup-context-image-index context)) + (image-end (markup-context-image-end context))) + (if (fix:< image-index image-end) + (let ((image (markup-context-image context)) + (nchars (fix:min (string-length string) + (fix:- image-end image-index)))) + (substring-move! string 0 nchars image image-index) + (set-markup-context-image-index! context + (fix:+ image-index nchars)))))) + +(define (markup-image-char! context char) + ;; DOES increment column and escape CHAR. + (let ((escape (case char + ((#\<) "<") + ((#\&) "&") + (else #f)))) + (if escape + (markup-add-string! context escape) + (markup-add-char! context char))) + (set-markup-context-column! context (fix:1+ (markup-context-column context)))) + +(define (markup-image-string! context string) + ;; DOES increment column and escape characters. + (let ((end (string-length string))) + (let loop ((i 0)) + (if (fix:< i end) + (begin + (markup-image-char! context (string-ref string i)) + (loop (fix:1+ i))))))) + +(define (gtk-group-line-image! group start end + image image-start image-end + tab-width column-offset char-image-strings + receiver) + ;; Like GROUP-LINE-IMAGE!, but includes Pango markup. RECEIVER will + ;; be called with the start of the next line or END, and the number + ;; of characters of markup generated. + (let* ((context (make-markup-context image image-start image-end + column-offset + tab-width char-image-strings)) + (index (markup-line! group start end context))) + (receiver index (markup-context-image-index context)))) + +(define (markup-line! group start end context) + + (define-syntax define-integrable-operator + (rsc-macro-transformer + (lambda (form environment) + (declare (ignore environment)) + (if (syntax-match? '((IDENTIFIER . MIT-BVL) + FORM) (cdr form)) + `(BEGIN + (DECLARE (INTEGRATE-OPERATOR ,(caadr form))) + (DEFINE ,@(cdr form))) + (ill-formed-syntax form))))) + + (define-integrable-operator (start-face! face) + (if face (markup-add-string! context (face-markup face)))) + + (define-integrable-operator (stop-face! face) + (if face (markup-add-string! context ""))) + + (define-integrable-operator (image-char! char) + (let ((char-image (vector-ref (markup-context-char-image-strings context) + (char->integer char)))) + (if char-image + (markup-image-string! context char-image) + (markup-image-char! context char)))) + + (define-integrable (image-tab!) + (let ((tab-width (markup-context-tab-width context)) + (column (markup-context-column context))) + (let ((n (fix:- tab-width (fix:remainder column tab-width)))) + (let tab-loop ((i 0)) + (if (fix:< i n) + (begin + (markup-image-char! context #\space) + (tab-loop (fix:1+ i)))))))) + + (define-integrable (overflow?) + (not (fix:< (markup-context-image-index context) + (markup-context-image-end context)))) + + (let loop ((index start) (face #f)) + (cond ((overflow?) + index) + ((fix:= index end) + (stop-face! face) + end) + ((get-text-property group index 'INVISIBLE #f) + (let ((next (next-specific-property-change group index end + 'INVISIBLE))) + (if next + (loop next face) + (begin + (stop-face! face) + end)))) + (else + (let ((char (group-right-char group index))) + (cond ((char=? char #\newline) + (stop-face! face) + (fix:1+ index)) + ((char=? char #\tab) + (image-tab!) + (loop (fix:1+ index) face)) + (else + (let ((face* (get-text-property group index 'FACE #f))) + (if (not (eq? face* face)) + (begin + (stop-face! face) + (start-face! face*))) + (image-char! char) + (loop (fix:1+ index) face*))))))))) + +(define (face-markup face) + (if (string? face) + (string-append "") + "")) \ No newline at end of file diff --git a/src/gtk-screen/gtk-screen.pkg b/src/gtk-screen/gtk-screen.pkg index 40b392957..5553ca097 100644 --- a/src/gtk-screen/gtk-screen.pkg +++ b/src/gtk-screen/gtk-screen.pkg @@ -29,7 +29,7 @@ USA. (global-definitions "../edwin/edwin") (define-package (edwin screen gtk-screen) - (files "gtk-screen") + (files "gtk-screen" "gtk-faces") (parent (edwin screen)) (export () set-gtk-screen-hooks!) @@ -148,6 +148,7 @@ USA. pango-layout-get-pixel-extents pango-layout-index-to-pos pango-layout-set-text + pango-layout-set-markup pango-context-get-metrics pango-context-spacing diff --git a/src/gtk-screen/gtk-screen.scm b/src/gtk-screen/gtk-screen.scm index edd9224f1..d958a19c2 100644 --- a/src/gtk-screen/gtk-screen.scm +++ b/src/gtk-screen/gtk-screen.scm @@ -2139,7 +2139,7 @@ USA. (max-image-size (fix:-1+ image-buffer-size))) ;; Image the whole paragraph into a max-sized image-buffer. (set-string-length! image-buffer image-buffer-size) - (group-line-image! + (gtk-group-line-image! group (line-ink-start-index line) (group-display-end-index group) image-buffer 0 max-image-size (buffer-drawing-tab-width drawing) @@ -2151,8 +2151,11 @@ USA. (set-mark-index! (line-ink-end line) text-index) ;; Run Pango on buffer. - (set-string-length! image-buffer image-index) - (pango-layout-set-text pango-layout image-buffer))))) + (if (fix:> image-index 0) + (begin + (set-string-length! image-buffer image-index) + (pango-layout-set-markup pango-layout image-buffer)) + (pango-layout-set-text pango-layout "")))))) (define (final-newline? group) (let ((index (group-display-end-index group)))