CP/M/CPM_CDROM.iso/beehive/program/bw.arc/BW.PAS

Pascal/Delphi Source File | 1991-02-18 | 12.8 KB | 528 lines

{*
 * BeeWindows
 *
 * windowing stuff for MicroBee computers and Turbo Pascal
 *
 *}

type

        {*
         * record of information for each virtual screen
         *}

        window_buffer           =       record

                screen          :       array[ 0 .. 1919 ] of byte;
                xsite           :       byte;
                ysite           :       byte;
                xpos            :       byte;
                ypos            :       byte;
                xsize           :       byte;
                ysize           :       byte;
                xcurs           :       byte;
                ycurs           :       byte

        end;

        window                  =       ^window_buffer;

        {*
         * a stack is used to store a record of which windows are
         * on the screen
         *}

        window_stack_ptr        =       ^window_node;

        window_node             =       record

                window_id       :       window;
                link            :       window_stack_ptr

        end;

        any_string              =       string[ 255 ];

var

        window_screen   :       array[ 0 .. 1919 ] of byte absolute $f000;

        window_stack_1  :       window_stack_ptr;
        window_stack_2  :       window_stack_ptr;

procedure init_windows;

type

        bitmap          =       array[ 0 .. 15 ] of byte;

var

        i               :       integer;
        pcg             :       array[ 0 .. 127 ] of bitmap absolute $f800;

const

        topleftleft     :       bitmap
                =       ( 0, 0, 0, 0, 1, 3, 6, 12, 24, 48, 96, 96, 0, 0, 0, 0 );

        topleftright    :       bitmap
                =       ( 0, 63, 96, 192, 128, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 );

        topline         :       bitmap
                =       ( 0, 255, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 );

        toprightleft    :       bitmap
                =       ( 0, 252, 6, 3, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 );

        toprightright   :       bitmap
                =       ( 0, 0, 0, 0, 128, 192, 96, 48, 24, 12, 6, 6, 0, 0, 0, 0 );

        rightline       :       bitmap
                =       ( 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 0, 0, 0, 0 );

        botrightright   :       bitmap
                =       ( 6, 6, 12, 24, 48, 96, 192, 128, 0, 0, 0, 0, 0, 0, 0, 0 );

        botrightleft    :       bitmap
                =       ( 0, 0, 0, 0, 0, 0, 0, 1, 3, 6, 252, 0, 0, 0, 0, 0 );

        botline         :       bitmap
                =       ( 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 255, 0, 0, 0, 0, 0 );

        botleftright    :       bitmap
                =       ( 0, 0, 0, 0, 0, 0, 0, 128, 192, 96, 63, 0, 0, 0, 0, 0 );

        botleftleft     :       bitmap
                =       ( 96, 96, 48, 24, 12, 6, 3, 1, 0, 0, 0, 0, 0, 0, 0, 0 );

        leftline        :       bitmap
                =       ( 96, 96, 96, 96, 96, 96, 96, 96, 96, 96, 96, 96, 0, 0, 0, 0 );

begin

        pcg[ 0 ] := topleftleft;
        pcg[ 1 ] := topleftright;
        pcg[ 2 ] := topline;
        pcg[ 3 ] := toprightleft;
        pcg[ 4 ] := toprightright;
        pcg[ 5 ] := rightline;
        pcg[ 6 ] := botrightright;
        pcg[ 7 ] := botrightleft;
        pcg[ 8 ] := botline;
        pcg[ 9 ] := botleftright;
        pcg[ 10 ] := botleftleft;
        pcg[ 11 ] := leftline;
        window_stack_1 := nil;
        window_stack_2 := nil

end; { init_windows }

function make_window : window;

var

        w       :       window;

begin

        new( w );

        with w^ do begin

                fillchar( screen, 1920, 32 );
                xsite := 1;
                ysite := 1;
                xpos := 1;
                ypos := 1;
                xsize := 78;
                ysize := 22;
                xcurs := 1;
                ycurs := 1

        end; { with }

        make_window := w

end; { make_window }

procedure window_draw_window( w : window );

var

        buf             :       array[ 0 .. 79 ] of byte;
        b, i, s         :       integer;

begin

        with w^ do begin

                s := xpos + ypos * 80 - 81;
                move( window_screen[ s ], screen, xsize + 2 );
                window_screen[ s ] := 128;
                window_screen[ s + 1 ] := 129;
                fillchar( window_screen[ s + 2 ], xsize - 2, 130 );
                window_screen[ s + xsize ] := 131;
                window_screen[ s + xsize + 1 ] := 132;

                b := xsite + ysite * 80;
                s := s + 80;

                for i := 1 to ysize do begin

                        screen[ i * 80 ] := window_screen[ s ];
                        window_screen[ s ] := 139;
                        move( window_screen[ s + 1 ], buf, xsize );
                        move( screen[ b ], window_screen[ s + 1 ], xsize );
                        move( buf, screen[ b ], xsize );
                        screen[ i * 80 + 79 ] := window_screen[ s + xsize + 1 ];
                        window_screen[ s + xsize + 1 ] := 133;
                        b := b + 80;
                        s := s + 80;

                end; { for }

                move( window_screen[ s ], screen[ 1840 ], xsize + 2 );
                window_screen[ s ] := 138;
                window_screen[ s + 1 ] := 137;
                fillchar( window_screen[ s + 2 ], xsize, 136 );
                window_screen[ s + xsize ] := 135;
                window_screen[ s + xsize + 1 ] := 134

        end { with }

end; { window_draw_window }

procedure window_undraw_window( w : window );

var

        buf             :       array[ 0 .. 79 ] of byte;
        b, i, s         :       integer;

begin

        with w^ do begin

                s := xpos + ypos * 80 - 81;
                b := xsite + ysite * 80;

                move( screen, window_screen[ s ], xsize + 2 );
                s := s + 80;

                for i := 1 to ysize do begin

                        window_screen[ s ] := screen[ i * 80 ];
                        move( window_screen[ s + 1 ], buf, xsize );
                        move( screen[ b ], window_screen[ s + 1 ], xsize );
                        move( buf, screen[ b ], xsize );
                        window_screen[ s + xsize + 1 ] := screen[ i * 80 + 79 ];
                        s := s + 80;
                        b := b + 80

                end; { for }

                move( screen[ 1840 ], window_screen[ s ], xsize + 2 )

        end { with }

end; { window_undraw_window }

function window_isonscreen( w : window ) : boolean;

var

        s       :       window_stack_ptr;
        found   :       boolean;

begin

        found := false;
        s := window_stack_1;

        while ( s <> nil ) and ( not found ) do begin
                found := ( s^.window_id = w );
                s := s^.link
        end;

        window_isonscreen := found

end;

procedure break_window( var w : window );

begin

        if not window_isonscreen( w ) then begin
                dispose( w );
                w := nil
        end

end;

procedure resite_window( w : window; x, y : integer );

begin

        if not window_isonscreen( w ) then
                if ( x > 0 ) and ( y > 0 ) and ( x < 79 ) and ( y < 23 ) then
                begin

                        w^.xsite := x;
                        w^.ysite := y

                end

end;

procedure clean_window( w : window );

begin

        if not window_isonscreen( w ) then
                fillchar( w^.screen, 1920, 32 )

end;

procedure resize_window( w : window; x, y : integer );

begin

        if not window_isonscreen( w ) then
                with w^ do begin

                        if ( x + xpos > 77 ) then
                                x := 77 - xpos;
                        if ( y + ypos > 21 ) then
                                y := 21 - ypos;

                        xsize := x;
                        ysize := y

                end

end;

procedure move_window( w : window; x, y : integer );

begin

        if not window_isonscreen( w ) then
                with w^ do begin

                        if ( xsize + x > 77 ) then
                                xsize := 77 - x;
                        if ( ysize + y > 21 ) then
                                ysize := 21 - y;

                        xpos := x;
                        ypos := y

                end

end;

procedure close_window( w : window );

var

        s               :       window_stack_ptr;

begin

        if window_isonscreen( w ) then begin

                repeat

                        s := window_stack_1;
                        window_stack_1 := window_stack_1^.link;

                        window_undraw_window( s^.window_id );

                        s^.link := window_stack_2;
                        window_stack_2 := s;

                until s^.window_id = w;

                s := window_stack_2;
                window_stack_2 := window_stack_2^.link;
                dispose( s );

                while window_stack_2 <> nil do begin

                        s := window_stack_2;
                        window_stack_2 := window_stack_2^.link;

                        window_draw_window( s^.window_id );

                        s^.link := window_stack_1;
                        window_stack_1 := s

                end

        end

end;

procedure open_window( w : window );

var

        s               :       window_stack_ptr;

begin

        if window_isonscreen( w ) then
                close_window( w );

        new( s );
        s^.window_id := w;
        s^.link := window_stack_1;
        window_stack_1 := s;
        window_draw_window( w )

end;

procedure wgotoxy( w : window; x, y : integer );

begin

        if ( x > 0 ) and ( y > 0 ) and ( x < 79 ) and ( y < 23 ) then begin

                w^.xcurs := x;
                w^.ycurs := y

        end

end;


procedure window_update_cursor( w : window );

begin

        with w^ do begin

                xcurs := succ( xcurs );
                if xcurs > 78 then begin

                        xcurs := 1;
                        ycurs := succ( ycurs );

                        if ycurs > 22 then begin

                                ycurs := 1

                        end

                end

        end

end;

procedure window_bputc( w : window; c : char );

var

        b       :       integer;

begin

        b := w^.xcurs + w^.ycurs * 80;
        w^.screen[ b ] := byte( c );
        window_update_cursor( w )

end; { window_bputc }

procedure wputc( w : window; c : char );

var

        s       :       integer;

begin

        if not window_isonscreen( w ) then
                window_bputc( w, c )
        else if window_stack_1^.window_id = w then begin

                with w^ do
                        if ( xcurs >= xsite ) and ( xcurs <= ( xsite + xsize ))
                                and ( ycurs >= ysite ) and ( ycurs <=
                                        ( ysite + ysize )) then begin

                                s := integer(xpos) + integer(xcurs)  - integer(xsite) +
                                        ( integer(ypos) + integer(ycurs) - integer(ysite) ) * 80;
                                window_screen[ s ] := byte( c );
                                window_update_cursor( w );

                        end
                        else
                                window_bputc( w, c )

        end

end; { wputc }

procedure wputs( w : window; var s : any_string );

var

        i               :       integer;

begin

        for i := 1 to length( s ) do
                wputc( w, s[ i ] )

end; { wputs }

procedure save_window( w : window; var fn : any_string );

var

        f               :       file;

begin

        if not window_isonscreen( w ) then begin

                assign( f, fn );
                rewrite( f );
                blockwrite( f, w^.screen, 15 );
                close( f )

        end

end;

procedure load_window( w : window; var fn : any_string );

var

        f               :       file;

begin

        if not window_isonscreen( w ) then begin

                assign( f, fn );
                reset( f );
                blockread( f, w^.screen, 15 );
                close( f )

        end

end;

procedure wputsxy( w : window; var s : any_string; x, y : integer );

begin

        wgotoxy( w, x, y );
        wputs( w, s )

end;