CP/M/CPM_CDROM.iso/lambda/soundpot/p/windoman.lbr/WINDOW.PZS/WINDOW.PAS

Pascal/Delphi Source File | 1993-10-25 | 18.4 KB | 798 lines

{ **********  Window Management Services    ********** }
{ **********  Version 1.0   8/06/84         ********** }

{ (c) Copyright 1984  Timothy E. Ide  All commercial rights reserved }

{ ********** constant and variable declarations ********** }

const
  _wxa = 1;  {min col}
  _wya = 1;  {min row}
  _wxz = 80;  {max col}
  _wyz = 23;  {max row}
  _wlz = 1840;  {max length}
  _wxv : set of byte = [_wxa.._wxz];
  _wyv : set of byte = [_wya.._wyz];
  _wzr : integer = 0;

type
  _wbs = string[4];  {border character string}
  _wpt = ^_wcb;
  _wcb = record  {window control block}
           _wno,  {window number}
           _wx,   {window col}
           _wy,   {window row}
           _ww,   {window width}
           _wh : byte;  {window height}
           _wxo,  {window origin col}
           _wyo,  {window origin row}
           _wl : integer;  {window length}
           _wb : boolean; {window border flag}
           _wbc : array [1..4] of char; {window border char}
           _wc,  {window cols}
           _wr : byte;  {window rows}
           _wcv : set of _wxa.._wxz;  {available width}
           _wrv : set of _wya.._wyz;  {available height}
           _wrp : array [_wya.._wyz] of integer;  {window row positions}
           _wnx : _wpt;  {next pointer}
           _wch : array [1.._wlz] of char;  {window contents}
         end;
  _wst = string[_wxz];

var
{ global variables available to user }
  wi_status : boolean; { true = success, false = failure }
  wi_eow, wi_eoln : boolean;

{ for use by window management services }
  _whd, _wp0, _wp1 : _wpt;



{ ********** internal function and procedure declarations ********** }

function _wi_find ( no : integer ) : boolean; forward;
procedure  _wi_stb ( var c; l : integer; var st : _wst); forward;
procedure _wi_bord1 ( var b : _wbs ); forward;
procedure _wi_bord2; forward;
procedure _wi_out ( var no : integer;
                    var st : _wst; out : boolean ); forward;
procedure _wi_outln ( var no : integer;
                      var st : _wst; out : boolean ); forward;
procedure _wi_getst ( l, x, y : integer; var s : _wst ); forward;
procedure _wi_inp ( var no, l : integer;
                    var st : _wst; inp : boolean ); forward;
procedure _wi_inpln ( var no, l : integer;
                      var st : _wst; inp : boolean ); forward;
procedure _wi_sher ( var no : integer; show : boolean ); forward;



{ **********  Window Management Services  ********** }

{ *********  wi_delln  ********** }
{ delete line from window }

procedure wi_delln ( no, y : integer );
var
  i : integer;
begin
  wi_status := false;
  if (_wi_find(no)) then begin
    with _wp1^ do begin
      if not (y in _wrv) then
        wi_status := false
      else begin
        for i := y to pred(_wr) do
          move(_wch[(succ(_wrp[succ(i)]))],_wch[(succ(_wrp[i]))],_wc);
        fillchar(_wch[(succ(_wrp[_wr]))],_wc,' ');
        _wx := 1;
        _wy := y;
        wi_status := true;
      end;
    end;
  end;
end; {wi_delln}


{ **********  wi_insln  ********** }
{ insert line into window }

procedure wi_insln ( no, y : integer );
var
  i : integer;
begin
  wi_status := false;
  if (_wi_find(no)) then begin
    with _wp1^ do begin
      if not (y in _wrv) then begin
        if (y < 1) then
          wi_status := false
        else begin
          wi_delln(no,1);
          _wy := _wr;
        end
      end
      else begin
        for i := _wr downto y do
          move(_wch[(succ(_wrp[pred(i)]))],_wch[(succ(_wrp[i]))],_wc);
        fillchar(_wch[(succ(_wrp[y]))],_wc,' ');
        _wy := y;
        _wx := 1;
        wi_status := true;
      end;
    end;
  end;
end; {wi_insln}


{ **********  wi_clreol  ********** }
{ clear from current window position to end of line }

procedure wi_clreol ( no : integer );
begin
  wi_status := false;
  if (_wi_find(no)) then begin
    with _wp1^ do begin
      if (_wy in _wrv) and (_wx in _wcv) then begin
        fillchar(_wch[(_wrp[_wy]+_wx)],(succ(_wc-_wx)),' ');
        wi_status := true;
      end;
    end;
  end;
end; {wi_clreol}


{ **********  wi_clear  ********* }
{ blank window contents }

procedure wi_clear ( no : integer );
begin
  wi_status := false;
  if (_wi_find(no)) then begin
    with _wp1^ do begin
      fillchar(_wch[1],_wl,' ');
      _wx := 1;
      _wy := 1;
      _wi_bord2;
    end;
    wi_status := true;
  end;
end; {wi_clear}


{ *********  wi_home  ********** }
{ set window position to beginning of first line }

procedure wi_home ( no : integer );
begin
  wi_status := false;
  if (_wi_find(no)) then begin
    with _wp1^ do begin
      _wx := 1;
      _wy := 1;
    end;
    wi_status := true;
  end;
end; {wi_clear}


{ *********  wi_border ********** }
{ set/reset window border characters }

{ overlay }
procedure wi_border ( no : integer; b : _wbs );
begin
  wi_status := false;
  if (_wi_find(no)) then begin
    with _wp1^ do begin
      if (_wb) then begin
        _wi_bord1(b);
        _wi_bord2;
        wi_status := true;
      end;
    end;
  end;
end; {wi_border}


{ *********  wi_open  ********** }
{ open window - allocate dynamic memory for window control block }

{ overlay }
procedure wi_open ( no, x, y, w ,h : integer; b : _wbs );
var
  i, l : integer;
begin
  wi_status := false;
  if (w in _wxv) and (h in _wyv)
      and not (_wi_find(no)) then begin
    l := w * h;
    getmem (_wp1, ((sizeof(_wcb)-_wlz)+l));
    with _wp1^ do begin
      _wno := no;
      _wx := 1;
      _wy := 1;
      _wxo := x;
      _wyo := y;
      _ww := w;
      _wh := h;
      _wl := l;
      if (length(b) > 0) then begin
        _wb := true;
        _wc := _ww-2;
        _wr := _wh-2;
        _wcv := [1.._wc];
        _wrv := [1.._wr];
        _wi_bord1(b);
        for i := _wya to _wyz do
          _wrp[i] := (succ(i*_ww));
      end
      else begin
        _wb := false;
        _wc := _ww;
        _wr := _wh;
        _wcv := [_wxa.._ww];
        _wrv := [_wya.._wh];
        for i := _wya to _wyz do
          _wrp[i] := (pred(i)*_wc);
      end;
      _wnx := _whd;
      _whd := _wp1;
    end;
    wi_clear(no);
  end;
end; {wi_open}


{ **********  wi_close  ********** }
{ close window - release dynamic memory }

{ overlay }
procedure wi_close ( no : integer );
begin
  wi_status := false;
  if (_wi_find(no)) then begin
    if _wp1 = _whd then
      _whd := _wp1^._wnx
    else begin
      _wp0^._wnx := _wp1^._wnx
    end;
    with _wp1^ do
      freemem(_wp1,((sizeof(_wcb)-_wlz)+_wl));
    _wp1 := nil;
    wi_status := true;
  end;
end; {wi_close}


{ **********  wi_getpos  ********** }
{ get window position }

{ overlay }
procedure wi_getpos ( no : integer; var x, y : integer );
begin
  wi_status := false;
  if (_wi_find(no)) then begin
    with _wp1^ do begin
      x := _wx;
      y := _wy;
    end;
    wi_status := true;
  end;
end; {wi_getpos}


{ *********  wi_getorg  ********** }
{ get window screen origin }

{ overlay }
procedure wi_getorg ( no : integer; var x, y : integer );
begin
  wi_status := false;
  if (_wi_find(no)) then begin
    with _wp1^ do begin
      x := _wxo;
      y := _wyo;
    end;
  end;
end; {wi_getorg}


{ **********  wi_setpos  ********** }
{ set window position }

procedure wi_setpos ( no, x, y : integer );
begin
  wi_status := false;
  if (_wi_find(no)) then begin
    with _wp1^ do begin
      if (x in _wcv) and (y in _wrv) then begin
        _wx := x;
        _wy := y;
        wi_status := true;
      end
      else
        wi_status := false;
    end;
  end;
end; {wi_setpos}


{ **********  wi_setorg  ********** }
{ set window screen origin }

procedure wi_setorg ( no, x, y : integer );
begin
  wi_status := false;
  if (_wi_find(no)) then begin
    with _wp1^ do begin
      _wxo := x;
      _wyo := y;
    end;
    wi_status := true;
  end;
end; {wi_setorg}


{ **********  wi_put  ********* }
{ store string in window }

procedure wi_put ( no : integer; st : _wst );
begin
  _wi_out(no,st,false);
end; {wi_put}


{ *********  wi_putln  ********* }
{ store string in window }

procedure wi_putln ( no : integer ; st : _wst );
begin
  _wi_outln(no,st,false);
end; {wi_putln}


{ *********  wi_get  ********* }
{ retrieve string from window }

procedure wi_get ( no, l : integer; var  st : _wst );
begin
  _wi_inp(no,l,st,false);
end; {wi_get}


{ *********  wi_getln  ********* }
{ retrieve string from window }

procedure wi_getln ( no, l : integer; var  st : _wst );
begin
  _wi_inpln(no,l,st,false)
end; {wi_getln}


{ *********  wi_write  ********* }
{ write string to screen thru window }

procedure wi_write ( no : integer; st : _wst );
begin
  _wi_out(no,st,true);
end; {wi_write}


{ *********  wi_writeln  ********** }
{ write string to screen thru window }

procedure wi_writeln ( no : integer; st : _wst );
begin
  _wi_outln(no,st,true);
end; {wi_writeln}


{ *********  wi_read  ********* }
{ read string from keyboard thru window }

procedure wi_read ( no : integer; l : integer; var st : _wst );
begin
  _wi_inp(no,l,st,true);
end; {wi_read}


{ **********  wi_readln  ********** }
{ read string from keyboard thru window }

procedure wi_readln ( no : integer; l : integer; var st : _wst );
begin
  _wi_inpln(no,l,st,true);
end; {wi_readln}


{ **********  wi_show  ********* }
{ display window to screen }

procedure wi_show ( no : integer );
begin
  _wi_sher(no,true);
end; {wi_show}


{ *********  wi_erase  ********** }
{ blank window region on screen }

procedure wi_erase ( no : integer );
begin
  _wi_sher(no,false);
end; {wi_erase}



{ ********** internal functions and procedures ********** }

{ **********  _wi_find  ********** }
{ locate window record in defined window list }

function _wi_find { no : integer ) : boolean};
const
  first : boolean = true;
var
  fnd : boolean;
begin
  _wi_find := false;
  if first then begin
    first := false;
    _whd := nil;
    _wp0 := nil;
    _wp1 := nil;
  end;
  if (_wp1 <> nil) and (_wp1^._wno = no) then
    _wi_find := true
  else begin
    _wp1 := _whd;
    fnd := false;
    while ((_wp1 <> nil) and (not fnd)) do begin
      with _wp1^ do begin
        if _wno = no then begin
            _wi_find := true;
            fnd := true;
        end
        else begin
          _wp0 := _wp1;
          _wp1 := _wnx;
        end;
      end;
    end;
  end;
end; {_wi_find}


{ **********  _wi_stb  ********* }
{ build string }

procedure _wi_stb { var c; l : integer; var st : _wst};
var
  a : byte absolute c;
begin
  move(a,st[1],l);
  move(l,st[0],1);
end; {_wi_stb}


{ **********  _wi_bord1  ********** }
{ store window border string }

procedure _wi_bord1 { var b: _wbs };
var
  i : integer;
begin
  with _wp1^ do begin
    for i := 1 to 4 do begin
      if (length(b) >= i) then
        _wbc[i] := b[i]
      else
        _wbc[i] := chr(0);
    end;
    if (_wbc[2] = chr(0)) then
      _wbc[2] := _wbc[1];
    if (_wbc[3] = chr(0)) then
      _wbc[3] := _wbc[1];
    if (_wbc[4] = chr(0)) then
      _wbc[4] := _wbc[2];
  end;
end; {wi_bord1}


{ **********  _wi_bord2  ********* }
{ insert border into window }

procedure _wi_bord2;
var
  i : integer;
begin
  with _wp1^ do begin
    if (_wb) then begin
      for i := 1 to _wh do begin
        _wch[(succ(pred(i)*_ww))] := _wbc[1];
        _wch[((pred(i)*_ww)+_ww)] := _wbc[3];
      end;
      for i := 1 to _ww do begin
        _wch[i] := _wbc[2];
        _wch[(_wl-_ww+i)] := _wbc[4];
      end;
    end;
  end;
end; {_wi_bord2}


{ **********  _wi_out  ********** }
{ store string to window at current window position }
{ optionally, write string to screen at current screen position }

procedure _wi_out { var no : integer; var st : _wst; out : boolean};
var
  i, x, y : integer;
begin
  wi_status := false;
  wi_eoln := false;
  wi_eow := false;
  if (_wi_find(no)) then begin
    with _wp1^ do begin
      if (_wy > _wr) then begin
        wi_insln(no,_wy);
        if (out) then
          wi_show(no);
      end;
      i := 1;
      while (i <= length(st)) and (_wx <= _wc) do begin
        _wch[(_wrp[_wy]+_wx)] := st[i];
        if (out) then begin
          x := _wxo+_wx;
          y := _wyo+_wy;
          if (not _wb) then begin
            x := pred(x);
            y := pred(y);
          end;
          if ((x in _wxv) and (y in _wyv)) then  begin
            gotoxy(x,y);
            write(st[i]);
          end;
        end;
        _wx := succ(_wx);
        i := succ(i);
      end;
      if (_wx > _wc) then begin
        _wx := 1;
        _wy := succ(_wy);
        wi_eoln := true;
        if (_wy > _wr) then
          wi_eow := true;
      end;
      wi_status := true;
    end;
  end;
end; {_wi_out}


{ *********  _wi_outln  ********** }
{ store string to window at current window position }
{ optionally, write string to screen at current screen position }

procedure _wi_outln { var no : integer; var st : _wst; out : boolean};
begin
  _wi_out(no,st,out);
  if (wi_status) then begin
    with _wp1^ do begin
      if (_wx > 1) then begin
        fillchar(_wch[(_wrp[_wy]+_wx)],(succ(_wc-_wx)),' ');
        if (out) then begin
          if (pred(_wxo+_wx) in _wxv)
              and (pred(_wyo+_wy) in _wyv) then begin
            wi_clreol(no);
          end;
        end;
        _wx := 1;
        _wy := succ(_wy);
        wi_eoln := true;
        if (_wy > _wr) then
          wi_eow := true;
      end;
    end;
  end;
end; {_wi_outln}


{ **********  _wi_getst  ********** }
{ get character string from terminal }

procedure _wi_getst { var l, x, y : integer; var s : _wst };
const
  bel = ^G;
  bs = 08;
  cr = 13;
  del = 127;
var
  c : char;
  bgn : integer;
  eos : boolean;
begin
  s := '';
  eos := false;
  bgn := x;
  repeat
    gotoxy(x,y);
    read(kbd,c);
    case ord(c) of
      del,bs : if (x > bgn) then begin
              x := pred(x);
              gotoxy(x,y);
              write(' ');
              delete(s,length(s),1);
            end
            else
              write(bel);
      $20..$7E : if (length(s) >= l) then
                   write(bel)
                 else begin
                   s := s+c;
                   gotoxy(x,y);
                   write(c);
                   x := succ(x);
                 end;
      cr : eos := true;
      else  write(bel);
    end;
  until eos;
end; { _wi_getst }


{ **********  _wi_inp  ********* }
{ retrieve string from window or from keyboard }

procedure _wi_inp { var no, l : integer;
                       var st : _wst; inp : boolean};
var
  i, j, x, y : integer;
  s : _wst;
begin
  wi_status := false;
  if (_wi_find(no)) then begin
    with _wp1^ do begin
      st := '';
      wi_eoln := false;
      wi_eow := false;
      if (_wy <= _wr) then begin
        i := 1;
        if (inp) then begin
          s := '';
          x := pred(_wxo+_wx);
          y := pred(_wyo+_wy);
          if (_wb) then begin
            x := succ(x);
            y := succ(y);
          end;
          if (_wxo in _wxv)
              and (pred(_wxo+_ww) in _wxv)
              and (_wyo in _wyv)
              and (pred(_wyo+_wh) in _wyv) then begin
            wi_status := true;
            j := succ(_wc-_wx);
            if (l > j) then
              _wi_getst(j,x,y,s)
            else
              _wi_getst(l,x,y,s);
          end
          else begin
            write(chr(7));
            wi_status := false;
          end;
          if (length(s) < l) then begin
            l := length(s);
            if (l = 0) then
              _wx := succ(_wx);
          end;
        end;
        while (not wi_eoln) and (i <= l) do begin
          with _wp1^ do begin
            if (_wy <= _wr) then begin
              j := (_wrp[_wy]+_wx);
              if (inp) then
                _wch[j] := s[i];
              st := st+_wch[j];
              i := succ(i);
              _wx := succ(_wx);
              if (_wx > _wc) then begin
                _wy := succ(_wy);
                _wx := 1;
                wi_eoln := true;
                if (_wy > _wc) then
                  wi_eow := true;
              end;
            end
            else begin
              wi_eow := true;
              wi_eoln := true;
            end;
          end;
          wi_status := true;
        end;
      end
      else
        wi_status := false;
    end;
  end;
end; {_wi_inp}


{ *********  _wi_inpln  ********* }
{ retrieve string from window or from keyboard }

procedure _wi_inpln { var no, l : integer;
                       var st : _wst; inp : boolean};
begin
  _wi_inp(no,l,st,inp);
{gotoxy(1,23);}
{clreol;}
{write('stat=',wi_status,' eoln=',wi_eoln,' eow=',wi_eow);}
  if (wi_status) then begin
    if (not wi_eow) then begin
      with _wp1^ do begin
        if (_wy <= _wr) and (_wx > 1) then begin
           _wx := 1;
           _wy := succ(_wy);
           wi_eoln := true;
           if (_wy > _wr) then
             wi_eow := true;
        end;
      end;
    end;
  end;
end; {_wi_inpln}


{ **********  _wi_sher  ********* }
{ show/erase window from screen }

procedure _wi_sher { var no : integer; show : boolean };
var
  i, j, k, x, y : integer;
  st : _wst;
begin
  wi_status := false;
  if (_wi_find(no)) then begin
    with _wp1^ do begin
      j := pred(_wxo+_ww);
      if (j <= _wxz) then
        j := _ww
      else
        j := _ww-(j-_wxz);
      if (_wxo >= 1) then begin
        k := 1;
        x := _wxo;
      end
      else begin
        j := pred(_wxo+_ww);
        k := succ(_ww-j);
        x := 1;
      end;
      if (j > 0) then begin
        if (not show) then begin
          fillchar(st[1],j,' ');
          move(j,st[0],1);
        end;
        for i := 1 to _wh do begin
          y := pred(_wyo+i);
          if (x in _wxv) and (y in _wyv) then begin
            if (show) then begin
              _wi_stb(_wch[((pred(i)*_ww)+k)],j,st);
            end;
            gotoxy(x,y);
            write(st);
          end;
        end;
      end;
    end;
    wi_status := true;
  end;
end; {_wi_sher}

{ **********  End of Window Management Services  ********* }