15.4.1381  src/lib/x-kit/widget/leaf/arrowbutton-shape.pkg

## arrowbutton-shape.pkg
#
# View for arrow buttons.

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





###                "The problem is to compress a room full
###                 of digital computation equipment into
###                 the size of a suitcase, then a shoe box,
###                 and finally small enough to hold in the
###                 palm of the hand."
###                                    -- Jack Staller, 1959

# This package gets used in:
#
#     src/lib/x-kit/widget/leaf/arrowbutton-look.pkg

stipulate
    include xgeometry;                                                  # xgeometry                     is from   src/lib/std/2d/xgeometry.pkg
    #
    package xc =  xclient;                                              # xclient                       is from   src/lib/x-kit/xclient/xclient.pkg
    #
    package d3 =  three_d;                                              # three_d                       is from   src/lib/x-kit/widget/lib/three-d.pkg
    package wg =  widget;                                               # widget                        is from   src/lib/x-kit/widget/basic/widget.pkg
    package wa =  widget_attribute;                                     # widget_attribute              is from   src/lib/x-kit/widget/lib/widget-attribute.pkg
    package wt =  widget_types;                                         # widget_types                  is from   src/lib/x-kit/widget/basic/widget-types.pkg
herein

    package arrowbutton_shape: (weak)  Button_Shape     {                       # Button_Shape                  is from   src/lib/x-kit/widget/leaf/button-shape.api


        attributes = [
            (wa::arrow_dir,    wa::ARROW_DIR,    wa::ARROW_DIR_VAL wt::ARROW_UP)
          ];

        offset = 1;

        fun get_verts (wide, high, wt::ARROW_UP)
                => 
                [ POINT { col=>wide / 2,    row=>offset - 1 },
                  POINT { col=>offset - 1,  row=>high-offset },
                  POINT { col=>wide-offset, row=>high-offset }
                ];

           get_verts (wide, high, wt::ARROW_DOWN)
               => 
               [ POINT { col=>wide / 2,     row=>high-offset },
                 POINT { col=>wide-offset,  row=>offset },
                 POINT { col=>offset,       row=>offset }
               ];

           get_verts (wide, high, wt::ARROW_LEFT)
               => 
               [ POINT { col=>offset,      row=>high / 2 },
                 POINT { col=>wide-offset, row=>high-offset },
                 POINT { col=>wide-offset, row=>offset - 1 }
               ];

           get_verts (wide, high, wt::ARROW_RIGHT)
               => 
               [ POINT { col=>wide-offset, row=>high / 2 },
                 POINT { col=>offset,      row=>offset - 1 },
                 POINT { col=>offset,      row=>high-offset }
               ];
        end;

        fun size dir (wide, high)
            =
            {   length =   ((((wide - 2*offset)*173) + 100) / 200) + 2*offset;

                my (wide, high)
                    =
                    case high
                        #
                        THE h => (wide, h);

                        _     => case dir
                                     #
                                     (wt::ARROW_DOWN | wt::ARROW_UP) => (wide, length);
                                     _                               => (length, wide);
                                 esac;
                    esac;

                wg::make_tight_size_preference (wide, high);
            };

        fun drawfn dir (d, size as SIZE { wide, high }, bwid)
            =
            {   verts = get_verts (wide, high, dir);

                fn (base, top, bottom)
                    =
                    {   xc::fill_polygon d base { verts, shape=>xc::CONVEX_SHAPE };
                        d3::draw3dpoly d (verts, bwid) { top, bottom };
                    };
            };

        fun config attributes
            =
            {   dir =   wa::get_arrow_dir (attributes wa::arrow_dir);

                (size dir, drawfn dir);
            };

    };          #  ArrowShape 

end;


## COPYRIGHT (c) 1994 by AT&T Bell Laboratories  See SMLNJ-COPYRIGHT file for details.
## Subsequent changes by Jeff Prothero Copyright (c) 2010-2013,
## released per terms of SMLNJ-COPYRIGHT.