PreviousUpNext

15.4.1372  src/lib/x-kit/widget/fancy/graphviz/text/text-canvas.pkg

# text-canvas.pkg
#
# NOTE: one optimization might be to exploit
# the situation in which a pen uses the
# default background.  This can be done
# when redrawing text, and when filling
# the background.

# Compiled by:
#     src/lib/x-kit/widget/xkit-widget.sublib

stipulate
    #
    package xg =  xgeometry;                    # xgeometry     is from   src/lib/std/2d/xgeometry.pkg
    package xc =  xclient;                      # xclient       is from   src/lib/x-kit/xclient/xclient.pkg
    #
    package tw =  text_widget;                  # text_widget   is from   src/lib/x-kit/widget/text/text-widget.pkg
herein

    package text_canvas: (weak) Text_Canvas {   # Text_Canvas   is from   src/lib/x-kit/widget/fancy/graphviz/text/text-canvas.api

        /* +DEBUG */
        tracing = logger::make_logtree_leaf { parent => xlogger::widgets_logging, name => "text_canvas::tracing", default => FALSE };
        fun pr s = logger::log_if tracing 0 .{ s; };
        fun prf (fmt, items) = logger::log_if tracing 0 .{ sfprintf::sprintf' fmt items; };
        /* -DEBUG */

        # A text canvas is a proto-widget
        # for drawing text:
        #
        Text_Canvas
            =
            TEXT_CANVAS
              {
                window:      xc::Window,        # The window.
                drawable:    xc::Drawable,      # The drawable surface.
                font:        xc::Font,          # The default font.
                foreground:  xc::Rgb,           # The default foreground color.
                background:  xc::Rgb,           # The default background color.
                default_pen: xc::Pen            # The default pen.
              };

        fun make_text_canvas
            { window,
              size,
              font:              xc::Font,
              foreground,
              background
            }
            =
            {   screen = xc::screen_of_window  window;

                fun default_color (NULL, color) =>  color;
                    default_color (THE c, _)    =>  xc::get_color  c;
                end;

                foreground = default_color (foreground, xc::black);
                background = default_color (background, xc::white);

                xc::change_window_attributes  window
                  [
                    xc::a::BACKGROUND_COLOR  background,
                    xc::a::BIT_GRAVITY       xc::NORTHWEST_GRAVITY
                  ];

                TEXT_CANVAS
                  {
                    window,
                    font,
                    drawable =>  xc::drawable_of_window  window,
                    #
                    foreground,
                    background,
                    default_pen
                        =>
                        xc::make_pen
                          [
                            xc::p::FOREGROUND (xc::rgb8_from_rgb  foreground),
                            xc::p::BACKGROUND (xc::rgb8_from_rgb  background)
                          ]
                  };
            };

        # Clear a canvas to its
        # background color: 
        #
        fun clear (TEXT_CANVAS { drawable, ... } )
            =
            xc::clear_drawable  drawable;

        # Specifies canvas, font, color, etc.
        # for writing text:
        #
        Typeball
            =
            TYPEBALL
              {
                drawable:  xc::Drawable,                        # The text display that this
                                                                # typeball is  associated with. 
                foreground_color:  xc::Color_Spec,              # 
                background_color:  xc::Color_Spec,              # 

                fore:           xc::Pen,                        # Pen to draw foreground.
                back:           xc::Pen,                        # Pen to draw background.
                under: Null_Or( xc::Pen ),                      # Pen to draw underline; if enabled 

                font:           xc::Font,                       # Font used.
                line_high:      Int,                            # The height the line.
                ascent:         Int
              };

        Typeball_Val
          #
          = TBV_FONT        xc::Font            # Font.
          | TBV_LINEHEIGHT  Int                 # Total height of line.
          | TBV_ASCENT      Int                 # Height of line above baseline.
          | TBV_UNDERLINE   Bool                # Underline mode.
          | TBV_FOREGROUND  xc::Color_Spec      # Forground (text) color.
          | TBV_BACKGROUND  xc::Color_Spec      # Background color.

          | TBV_UNDERGRND   xc::Color_Spec      # Color of underline.
          ;

        # Create a new typeball:
        #
        fun make_typeball
              ( TEXT_CANVAS { window, drawable, font, foreground, background, ... },
                vl
              )
            =
            {   font       = REF font;

                foreground_color = REF (xc::CMS_NAME "black");
                background_color = REF (xc::CMS_NAME "white");

                fore = REF foreground;
                back = REF background;

                line_high = REF NULL;
                ascent  = REF NULL;

                underline = REF FALSE;
                under     = REF foreground;

                color_of = xc::get_color;

                fun do_val (TBV_FONT       f) =>  font      := f;
                    do_val (TBV_LINEHEIGHT n) =>  line_high   := THE n;
                    do_val (TBV_ASCENT     n) =>  ascent    := THE n;
                    do_val (TBV_UNDERLINE  b) =>  underline := b;
                    do_val (TBV_FOREGROUND c) => { foreground_color := c;  fore := color_of c;  };
                    do_val (TBV_BACKGROUND c) => { background_color := c;  back := color_of c;  };
                    do_val (TBV_UNDERGRND  c) =>   under := color_of c;
                end;

                apply  do_val  vl;

                fun make_pen (f, b)
                    =
                    xc::make_pen
                      [
                        xc::p::FUNCTION    xc::OP_COPY,
                        xc::p::FOREGROUND (xc::rgb8_from_rgb  *f),
                        xc::p::BACKGROUND (xc::rgb8_from_rgb  *b)
                      ];

                fore_pen = make_pen (fore, back);

                under_pen
                    =
                    if *underline
                        #
                        if (xc::same_rgb(*fore, *under))   THE fore_pen;
                        else                               THE (make_pen (under, back));
                        fi;
                    else
                        NULL;
                    fi;

                my (font_ht, font_ascent)
                    =
                    {   my { ascent, descent }
                            =
                            xc::font_high  *font;

                        (ascent+descent, ascent);
                    };

                fun max (NULL,  x:  Int) =>  x;
                    max (THE x, y:  Int) =>  (x > y) ??  x :: y;
                end;

                TYPEBALL
                  {
                    drawable,

                    foreground_color => *foreground_color,
                    background_color => *background_color,

                    fore =>  fore_pen,
                    back =>  make_pen (back, fore),

                    under   =>  under_pen,
                    font    => *font,

                    line_high =>  max(*line_high, font_ht),
                    ascent  =>  max(*ascent, font_ascent)
                  };
            };

        # Return the default typeball
        # for the canvas:
        #
        fun default_typeball txt_canvas
            =
            make_typeball (txt_canvas, []);

        # Copy a typeball, updating
        # some attributes 
        #
        fun copy_typeball (TYPEBALL { ... }, vl)
            =
            raise exception  FAIL "unimplemented";

        Text_Elem
          #
          = TEXT { tb:  Typeball, text:  String }
          | FILL { tb:  Typeball, chr_wid:  Int, pix_wid:  Int };

        # Return the width (in pixels)
        # of a text element 
        #
        fun pix_width_of (TEXT { tb=>TYPEBALL { font, ... }, text } )
                =>
                xc::text_width font text;

            pix_width_of (FILL { pix_wid, ... } )
                =>
                pix_wid;
        end;


        # Return the width (in characters)
        # of a text element:
        #
        fun chr_width_of (TEXT { text,    ... } ) =>  size text;
            chr_width_of (FILL { chr_wid, ... } ) =>  chr_wid;
        end;


        # Return the width of a text string
        # using the given typeball:
        #
        fun text_width (TYPEBALL { font, ... } )
            =
            xc::text_width  font;


        # Return the substring
        # of a text element:
        #
        fun substr (TEXT { tb, text }, i, n)
                =>
                TEXT { tb, text=>string::substring (text, i, n) };

            substr (FILL { tb, chr_wid, pix_wid }, i, n)
                =>
                if (i < 0  or  n < 0  or  chr_wid < i+n)
                    #
                    raise exception  SUBSCRIPT;
                else
                    FILL { tb, chr_wid=>n-i, pix_wid=>(pix_wid*(n-i)) % chr_wid };
                fi;
        end;

        # Return the font of a typeball:
        #
        fun font_of (TYPEBALL { font, ... } )
            =
            font;

        # Do a copy_blt on the canvas:
        #
        fun blt (TEXT_CANVAS { drawable, default_pen, ... } )
            =
            xc::copy_blt_mailop
                drawable
                default_pen;

        # Clear the specified box
        # to the background color 
        #
        fun clear_box (TEXT_CANVAS { drawable, ... } )
            =
            xc::clear_box  drawable;


        fun draw_opaque_string (TYPEBALL { drawable, font, fore, ... } )
            =
            xc::draw_opaque_string  drawable  fore  font;


        fun fill (TYPEBALL { drawable, back, line_high, ascent, ... } )
            =
            {   draw = xc::fill_box  drawable  back;

                fn (xg::POINT { col, row }, wide)
                    =
                    draw (xg::BOX { col, row=>row-ascent, wide, high=>line_high } );
            };

        # What about background???      XXX BUGGO FIXME
        #
        fun draw { at=>xg::POINT { col=>x, row=>y }, elems }
            =
            draw_it (elems, x)
            where
                fun draw_it ([], _)
                        =>
                        ();

                    draw_it (TEXT { tb, text } ! r, x)
                        =>
                        {   draw_opaque_string tb (xg::POINT { col=>x, row=>y }, text);

                            draw_it (r, x + text_width tb text);
                        };

                    draw_it (FILL { tb, pix_wid, ... } ! r, x)
                        =>
                        {   fill tb (xg::POINT { col=>x, row=>y }, pix_wid);

                            draw_it (r, x+pix_wid);
                        };
                end;
            end;


        fun draw_text tb
            =
            {   draw = draw_opaque_string tb;

                fn { at, text }
                    =
                    draw (at, text);
            };


        fun draw_fill tb
            =
            {   draw = fill tb;

                fn { at, wid }
                    =
                    draw (at, wid);
            };

    /**
      #  Cursors 
        enum text_cursor
          = NO_CURSOR
          | BOX_CURSOR      ??
          | OUTLINE_CURSOR  ??
          | CARET_CURSOR    ??
          | BAR_CURSOR      ??
          | XTERM_CURSOR    ??
          | GLYPH_CURSOR    ??
          ;

        fun set_cursor:  (Text_Canvas, Text_Cursor) -> Void;
            #  set the type of the cursor 

        fun move_cursor:  (Text_Canvas, tw::Char_Coord) -> Void;
            #  set the current cursor position 

        fun cursor_on (Text_Canvas {... } ) = ??
            #  enable display of the text cursor 

        fun cursor_off (TextCanvas {... } ) = ??
            #  Disable display of the text cursor 
    **/

    };                                          # package text_canvas 

end;


Comments and suggestions to: bugs@mythryl.org

PreviousUpNext