PreviousUpNext

15.4.1477  src/lib/x-kit/xclient/pkg/window/pen-guts.pkg

## pen-guts.pkg
#
# A read-only drawing context.
# This is gets mapped onto an
# X-server graphics context (GC) by
#     src/lib/x-kit/xclient/pkg/window/pen-to-gcontext-imp.pkg

# Compiled by:
#     src/lib/x-kit/xclient/xclient-internals.sublib



# The internal representation of pen values.

stipulate
    package xg =  xgeometry;                                            # xgeometry             is from   src/lib/std/2d/xgeometry.pkg
    package xt =  xtypes;                                               # xtypes                is from   src/lib/x-kit/xclient/pkg/wire/xtypes.pkg
herein


    package   pen_guts
    : (weak)  Pen_Guts                                                  # pen_guts              is from   src/lib/x-kit/xclient/pkg/window/pen-guts.pkg
    {
        my (&)  = unt::bitwise_and;
        my (>>) = unt::(>>);

    #    infix val & >>;

        Pen_Part                                                        # Internal representation of pen trait values.
          = IS_DEFAULT
          | IS_WIRE    Unt                                              # A trait's wire representation.
          | IS_PIXMAP  xt::Pixmap_Id
          | IS_POINT   xg::Point
          | IS_BOXES   (xt::Box_Order, List( xg::Box ))
          | IS_DASHES  List( Int )
          ;

        Pen = PEN { traits:   vector::Vector( Pen_Part ),               # The state vector (read-only).
                    bitmask:  Unt                                       # Bitmask giving which vector entries have non-default values. 
                  };

        pen_slot_count = 19;

        default_pen
            =
            PEN { traits  =>  vector::tabulate (pen_slot_count, fn _ = IS_DEFAULT),
                  bitmask =>  0u0
                };



        fun pen_match (0u0, _, _)
                =>
                TRUE;                                           # Bitmask selects no state components, so match is vacuously true.

            pen_match
                ( used_mask,
                  PEN { bitmask => bitmask1, traits => traits1 },
                  PEN { bitmask => bitmask2, traits => traits2 }
                )
                =>
                (traits1 == traits2)                            #  first test for same chunk 
                or
                {
                    m = (used_mask & bitmask1);

                    (m == (bitmask2 & used_mask))
                    and 
                    match_vals (m, 0)
                    where
                        fun match_val (IS_WIRE a, IS_WIRE b)
                                =>
                                a == b;

                            match_val (IS_PIXMAP (xt::XID a), IS_PIXMAP (xt::XID b))
                                =>
                                a == b;

                            match_val (IS_POINT a, IS_POINT b)
                                =>
                                a == b;

                            match_val (IS_BOXES (o1, rl1), IS_BOXES (o2, rl2))
                                =>
                                (o1 == o2) and eq (rl1, rl2)
                                where
                                    fun eq ([], []) => TRUE;
                                        eq ((a:  xg::Box) ! ra, b ! rb) => (a==b) and eq (ra, rb);
                                        eq _ => FALSE;
                                    end;
                                end;

                            match_val (IS_DASHES a, IS_DASHES b)
                                =>
                                {
                                    fun eq ([], []) => TRUE;
                                        eq ((a:  Int) ! ra, b ! rb) => (a==b) and eq (ra, rb);
                                        eq _ => FALSE;
                                    end;

                                    eq (a, b);
                                  };

                            match_val _ => FALSE;
                        end;

                        fun match_vals (0u0, _)
                                => TRUE;

                            match_vals (m, i)
                                => 
                              (((m & 0u1) == 0u0)
                                or match_val (vector::get (traits1, i), vector::get (traits2, i)))
                              and match_vals (m >> 0u1, i+1);
                        end;
                    end;
                };
        end;

    };          # package pen_guts
end;


Comments and suggestions to: bugs@mythryl.org

PreviousUpNext