WebSVN – oidplus – Diff – /trunk_dos/VTSCUI.PAS


unit VTSCUI;
 
(************************************************)
(* VTSCUI.PAS                                   *)
(* Author:   Daniel Marschall                   *)
(* Revision: 2022-02-14                         *)
(* License:  Apache 2.0                         *)
(* This file contains:                          *)
(* - ViaThinkSoft CUI (Console User Interface)  *)
(************************************************)
 
interface
 
uses
  StrList;
 
const
  ScreenWidth = 80;
  ScreenHeight = 25;
  SINGLE_LINE_BOX_PADDING = 3;
  SINGLE_LINE_BOX_PADDING_INNER = 10;
 
procedure DrawThinBorder(x, y, width, height: integer);
procedure DrawDoubleBorder(x, y, width, height: integer);
procedure DrawTextBar(str: string; line: integer);
procedure DrawTitleBar(center, left, right: string);
procedure DrawStatusBar(str: string);
function DrawSelectionList(X, Y, ListWidth, ListHeight: integer;
                           items: PStringList; allowESC: boolean;
                           Title: string; borderStrength: integer): integer;
procedure ClearSection(x, y, width, height: integer);
function QueryVal(var s: string; initX, initY, width, height: integer;
                  Title: string; borderStrength: integer): boolean;
procedure ShowMessage(msg: string; title: string; dobeep: boolean);
 
implementation
 
uses
  Crt, Drivers, VtsFuncs;
 
type
  TCharDefs = array[0..7] of char;
 
const
  ThinLineChars: TCharDefs =
    ( #$DA, #$C4, #$BF,
      #$B3,       #$B3,
      #$C0, #$C4, #$D9
    );
  DoubleLineChars: TCharDefs =
    ( #$C9, #$CD, #$BB,
      #$BA,       #$BA,
      #$C8, #$CD, #$BC
    );
 
function FillRight(str: string; len: integer; c: char): string;
var
  s: string;
  i: integer;
begin
  s := str;
  for i := Length(str) to len-1 do
  begin
    s := s + c;
  end;
  FillRight := s;
end;
 
procedure DrawBorder(x, y, width, height, thickness: integer);
var
  ix,iy: integer;
  chars: TCharDefs;
begin
  if thickness = 1 then
    chars := ThinLineChars;
  if thickness = 2 then
    chars := DoubleLineChars;
 
  (* Top line *)
  if y >= 1 then
  begin
    (* Top left corner *)
    if x >= 1 then
    begin
      GotoXY(x,y);
      Write(chars[0]);
    end
    else
    begin
      GotoXY(1,y);
    end;
 
    (* Top edge *)
    for ix := 1 to width-2 do
      Write(chars[1]);
 
    (* Top right corner *)
    if x+width-1 <= ScreenWidth then
      Write(chars[2]);
  end;
 
  (* Left edge *)
  for iy := 1 to height-2 do
  begin
    if (x    >= 1) and (x    <= ScreenWidth) and
       (y+iy >= 1) and (y+iy <= ScreenHeight) then
    begin
      GotoXY(x,y+iy);
      Write(chars[3]);
    end;
  end;
 
  (* Right edge *)
  for iy := 1 to height-2 do
  begin
    if (x+width-1 >= 1) and (x+width-1 <= ScreenWidth) and
       (y+iy      >= 1) and (y+iy      <= ScreenHeight) then
    begin
      GotoXY(x+width-1,y+iy);
      Write(chars[4]);
    end;
  end;
 
  (* Bottom line *)
  if y+height-1 <= ScreenHeight then
  begin
    (* Bottom left corner *)
    if x >= 1 then
    begin
      GotoXY(x,y+height-1);
      Write(chars[5]);
    end
    else
    begin
      GotoXY(1,y+height-1);
    end;
 
    (* Bottom edge *)
    for ix := 1 to width-2 do
      Write(chars[6]);
 
    (* Bottom right corner *)
    if x+width-1 <= ScreenWidth then
      Write(chars[7]);
  end;
end;
 
procedure DrawThinBorder(x, y, width, height: integer);
begin
  DrawBorder(x, y, width, height, 1);
end;
 
procedure DrawDoubleBorder(x, y, width, height: integer);
begin
  DrawBorder(x, y, width, height, 2);
end;
 
procedure DrawTextBar(str: string; line: integer);
var
  i, left, right: integer;
  len: integer;
begin
  GotoXY(1,line);
 
  TextBackground(White);
  TextColor(Black);
  len := Length(str);
 
  left := round((ScreenWidth-len)/2);
  right := ScreenWidth - left - len;
 
  for i := 1 to left do
  begin
    Write(' ');
  end;
 
  Write(str);
 
  (* TODO: If we do "for i := 1 to right", then the console will scroll *)
  (*       since the char in the right bottom corner is written!        *)
  for i := 1 to right-1 do
  begin
    Write(' ');
  end;
 
  TextBackground(Black);
  TextColor(White);
end;
 
procedure DrawTitleBar(center, left, right: string);
begin
  DrawTextBar(center, 1);
 
  (* Put left text into the title bar *)
  GoToXY(1,1);
  TextBackground(White);
  TextColor(Black);
  WriteLn(left);
  TextBackground(Black);
  TextColor(White);
 
  (* Put right text into the title bar *)
  GotoXY(ScreenWidth-Length(right)+1,1);
  TextBackground(White);
  TextColor(Black);
  WriteLn(right);
  TextBackground(Black);
  TextColor(White);
end;
 
procedure DrawStatusBar(str: string);
begin
  DrawTextBar(str, ScreenHeight);
end;
 
function DrawSelectionList(X, Y, ListWidth, ListHeight: integer;
                           items: PStringList; allowESC: boolean;
                           Title: string; borderStrength: integer): integer;
var
  i: integer;
  itemIndex: integer;
  sc: char;
  iStartScope, iEndScope: integer;
  sTmp: string;
label
  doAgain;
begin
  if borderStrength = 1 then
  begin
    DrawThinBorder(X-1, Y-1, ListWidth+2, ListHeight+2);
  end;
 
  if borderStrength = 2 then
  begin
    DrawDoubleBorder(X-1, Y-1, ListWidth+2, ListHeight+2);
  end;
 
  if Title <> '' then
  begin
    if borderStrength > 0 then
      GoToXY(X+1, Y-1)
    else
      GoToXY(X, Y-1);
    Write(Title);
  end;
 
  (*CursorOff;*)
 
  itemIndex := 0;
  iStartScope := itemIndex;
  iEndScope := itemIndex + ListHeight;
 
doAgain:
 
  if itemIndex < 0 then
    itemIndex := 0;
  if itemIndex > ListCount(items)-1 then
    itemIndex := ListCount(items)-1;
 
  if itemIndex < iStartScope then
  begin
    Dec(iEndScope);
    Dec(iStartScope);
  end;
 
  if itemIndex > iEndScope-1 then
  begin
    Inc(iEndScope);
    Inc(iStartScope);
  end;
 
  if borderStrength > 0 then
  begin
    (* Show scroll arrows *)
    GotoXY(X+ListWidth, Y);
    if iStartScope > 0 then
    begin
      TextBackground(White);
      TextColor(Black);
      WriteLn(#$18(*ArrowUp*));
      TextBackground(Black);
      TextColor(White);
    end
    else if borderStrength = 1 then
      WriteLn(ThinLineChars[4])
    else if borderStrength = 2 then
      WriteLn(DoubleLineChars[4]);
 
    GotoXY(X+ListWidth, Y+ListHeight-1);
    if ListCount(items) > iEndScope then
    begin
      TextBackground(White);
      TextColor(Black);
      WriteLn(#$19(*ArrowDown*));
      TextBackground(Black);
      TextColor(White);
    end
    else if borderStrength = 1 then
      WriteLn(ThinLineChars[4])
    else if borderStrength = 2 then
      WriteLn(DoubleLineChars[4]);
  end;
 
  for i := iStartScope to iEndScope-1 do
  begin
    if itemIndex = i then
    begin
      TextColor(Black);
      TextBackground(White);
    end
    else
    begin
      TextColor(White);
      TextBackground(Black);
    end;
    GotoXY(x,y+i-iStartScope);
    if i > ListCount(items)-1 then
      Write(FillRight('', ListWidth, ' '))
    else
    begin
      sTmp := ListGetElement(items, i);
 
 
 
      sTmp := TrimLineToWidth(sTmp, ListWidth);
 
      Write(FillRight(sTmp, ListWidth, ' '));
    end;
    TextColor(White);
    TextBackground(Black);
  end;
 
  repeat
    GotoXY(ScreenWidth, ScreenHeight);
 
    sc := ReadKey;
    if sc = #$00(*ExtendedKeyCode*) then
    begin
      sc := ReadKey;
      if sc = #$48(*UpKey*) then
      begin
        dec(itemIndex);
        goto doAgain;
      end
      else if sc = #$50(*DownKey*) then
      begin
        inc(itemIndex);
        goto doAgain;
      end
      else if sc = #$47(*POS1*) then
      begin
        itemIndex := 0;
        iStartScope := 0;
        iEndScope := iStartScope + ListHeight;
        goto doAgain;
      end
      else if sc = #$4F(*END*) then
      begin
        itemIndex := ListCount(items)-1;
        iStartScope := itemIndex - Min(ListHeight,ListCount(items));
        iEndScope := itemIndex;
        goto doAgain;
      end;
    end;
 
    if sc = #13(*Return*) then
    begin
      DrawSelectionList := itemIndex;
      break;
    end;
 
    if allowESC and (sc = #27(*ESC*)) then
    begin
      DrawSelectionList := -1;
      break;
    end;
  until false;
 
  (*CursorOn;*)
end;
 
procedure ClearSection(x, y, width, height: integer);
var
  ix, iy: integer;
begin
  for iy := y to y+height-1 do
  begin
    for ix := x to x+width-1 do
    begin
      GoToXY(ix,iy);
      Write(' ');
    end;
  end;
end;
 
function QueryVal(var s: string; initX, initY, width, height: integer;
                  Title: string; borderStrength: integer): boolean;
var
  x, y: integer;
  i, j: integer;
  sc: char;
  stmp: string;
begin
  if borderStrength = 1 then
    DrawThinBorder(initX-1,initY-1,width+2,height+2);
  if borderStrength = 2 then
    DrawDoubleBorder(initX-1,initY-1,width+2,height+2);
  if title <> '' then
  begin
    if borderStrength > 0 then
      GoToXY(initX+1, initY-1)
    else
      GoToXY(initX, initY-1);
    Write(title);
  end;
  ClearSection(initX,initY,width,height);
 
  x := initX;
  y := initY;
 
  (* Write existing string value and set cursor *)
  stmp := s;
  s := '';
  for i := 1 to Length(stmp) do
  begin
    if stmp[i] = #10 then
    begin
      s := s + stmp[i];
      continue;
    end;
 
    GoToXY(x,y);
    s := s + stmp[i];
    Write(stmp[i]);
    Inc(x);
 
    if (x=initX+width-1) and (y=initY+height-1) then
    begin
      (* Attention: Data following after this will be lost! *)
      break;
    end;
 
    if stmp[i] = #13 then
    begin
      if y=initY+height-1 then
      begin
        (* Attention: Data following after this will be lost! *)
        s := Copy(s, 1, Length(s)-1);
        Dec(x);
        break;
      end;
      x := initX;
      Inc(y);
      continue;
    end;
 
    if x=initX+width then
    begin
      Inc(y);
      x := initX;
    end;
  end;
 
  repeat
    GotoXY(x, y);
    sc := ReadKey;
 
    if sc = #0 then
    begin
      (* Extended key code *)
      sc := ReadKey;
      (* TODO: Implement keys like DEL, END, POS1, and ArrowKeys *)
      Beep;
      continue;
    end
    else if sc = #8(*Backspace*) then
    begin
      if x <= initX then
      begin
        if y = initY then
        begin
          Beep;
          continue;
        end;
        Dec(y);
 
        (* Find out length of previous line *)
        j := Length(s)-2(*CRLF*);
        while (j >= 0) do
        begin
          if (s[j]=#13) or (s[j]=#10) then break;
          Dec(j);
        end;
        j := Length(s)-2(*CRLF*)-j;
        x := initX + j;
        s := Copy(s, 1, Length(s)-1); (* Remove #10 now. #13 will be removed below *)
      end
      else
      begin
        Dec(x);
      end;
      GotoXY(x, y);
      Write(' ');
      GotoXY(x, y);
      s := Copy(s, 1, Length(s)-1);
      continue;
    end
    else if sc = #13(*Return*) then
    begin
      if GetShiftState and kbRightShift <> 0 then
      begin
        if y=initY+height-1 then
        begin
          Beep;
          continue;
        end;
        s := s + #13 + #10;
        x := initX;
        Inc(y);
      end
      else
      begin
        QueryVal := true;
        exit;
      end;
    end
    else if sc = #27(*ESC*) then
    begin
      QueryVal := false;
      exit;
    end
    else
    begin
      if (x=initX+width-1) and (y=initY+height-1) then
      begin
        Beep;
        continue;
      end;
      s := s + sc;
      Write(sc);
      Inc(x);
      if x >= initX+width then
      begin
        Inc(y);
        x := initX;
      end;
    end;
  until false;
end;
 
procedure ShowMessage(msg: string; title: string; dobeep: boolean);
var
  x, y, w, h: integer;
begin
  x := SINGLE_LINE_BOX_PADDING_INNER;
  y := ScreenHeight div 2 - 1;
  w := ScreenWidth - (SINGLE_LINE_BOX_PADDING_INNER-1)*2;
  h := 1;
  DrawDoubleBorder(x-1, y, w+2, h+2);
  ClearSection(x, y+1, w-2, h);
  if title <> '' then
  begin
    GoToXY(x+1, y);
    Write(title);
  end;
  GoToXY(x, y+1);
  Write(msg);
  if DoBeep then Beep;
end;
 
end.
 

Rev 738	Rev 740
1	unit VTSCUI;	1	unit VTSCUI;
2		2
3	(************************************************)	3	(************************************************)
4	(* VTSCUI.PAS *)	4	(* VTSCUI.PAS *)
5	(* Author: Daniel Marschall *)	5	(* Author: Daniel Marschall *)
6	(* Revision: 2022-02-14 *)	6	(* Revision: 2022-02-14 *)
7	(* License: Apache 2.0 *)	7	(* License: Apache 2.0 *)
8	(* This file contains: *)	8	(* This file contains: *)
9	(* - ViaThinkSoft CUI (Console User Interface) *)	9	(* - ViaThinkSoft CUI (Console User Interface) *)
10	(************************************************)	10	(************************************************)
11		11
12	interface	12	interface
13		13
14	uses	14	uses
15	StrList;	15	StrList;
16		16
17	const	17	const
18	ScreenWidth = 80;	18	ScreenWidth = 80;
19	ScreenHeight = 25;	19	ScreenHeight = 25;
20	SINGLE_LINE_BOX_PADDING = 3;	20	SINGLE_LINE_BOX_PADDING = 3;
21	SINGLE_LINE_BOX_PADDING_INNER = 10;	21	SINGLE_LINE_BOX_PADDING_INNER = 10;
22		22
23	procedure DrawThinBorder(x, y, width, height: integer);	23	procedure DrawThinBorder(x, y, width, height: integer);
24	procedure DrawDoubleBorder(x, y, width, height: integer);	24	procedure DrawDoubleBorder(x, y, width, height: integer);
25	procedure DrawTextBar(str: string; line: integer);	25	procedure DrawTextBar(str: string; line: integer);
26	procedure DrawTitleBar(center, left, right: string);	26	procedure DrawTitleBar(center, left, right: string);
27	procedure DrawStatusBar(str: string);	27	procedure DrawStatusBar(str: string);
28	function DrawSelectionList(X, Y, ListWidth, ListHeight: integer;	28	function DrawSelectionList(X, Y, ListWidth, ListHeight: integer;
29	items: PStringList; allowESC: boolean;	29	items: PStringList; allowESC: boolean;
30	Title: string; borderStrength: integer): integer;	30	Title: string; borderStrength: integer): integer;
31	procedure ClearSection(x, y, width, height: integer);	31	procedure ClearSection(x, y, width, height: integer);
32	function QueryVal(var s: string; initX, initY, width, height: integer;	32	function QueryVal(var s: string; initX, initY, width, height: integer;
33	Title: string; borderStrength: integer): boolean;	33	Title: string; borderStrength: integer): boolean;
34	procedure ShowMessage(msg: string; title: string; dobeep: boolean);	34	procedure ShowMessage(msg: string; title: string; dobeep: boolean);
35		35
36	implementation	36	implementation
37		37
38	uses	38	uses
39	Crt, Drivers, VtsFuncs;	39	Crt, Drivers, VtsFuncs;
40		40
41	type	41	type
42	TCharDefs = array[0..7] of char;	42	TCharDefs = array[0..7] of char;
43		43
44	const	44	const
45	ThinLineChars: TCharDefs =	45	ThinLineChars: TCharDefs =
46	( #$DA, #$C4, #$BF,	46	( #$DA, #$C4, #$BF,
47	#$B3, #$B3,	47	#$B3, #$B3,
48	#$C0, #$C4, #$D9	48	#$C0, #$C4, #$D9
49	);	49	);
50	DoubleLineChars: TCharDefs =	50	DoubleLineChars: TCharDefs =
51	( #$C9, #$CD, #$BB,	51	( #$C9, #$CD, #$BB,
52	#$BA, #$BA,	52	#$BA, #$BA,
53	#$C8, #$CD, #$BC	53	#$C8, #$CD, #$BC
54	);	54	);
55		55
56	function FillRight(str: string; len: integer; c: char): string;	56	function FillRight(str: string; len: integer; c: char): string;
57	var	57	var
58	s: string;	58	s: string;
59	i: integer;	59	i: integer;
60	begin	60	begin
61	s := str;	61	s := str;
62	for i := Length(str) to len-1 do	62	for i := Length(str) to len-1 do
63	begin	63	begin
64	s := s + c;	64	s := s + c;
65	end;	65	end;
66	FillRight := s;	66	FillRight := s;
67	end;	67	end;
68		68
69	procedure DrawBorder(x, y, width, height, thickness: integer);	69	procedure DrawBorder(x, y, width, height, thickness: integer);
70	var	70	var
71	ix,iy: integer;	71	ix,iy: integer;
72	chars: TCharDefs;	72	chars: TCharDefs;
73	begin	73	begin
74	if thickness = 1 then	74	if thickness = 1 then
75	chars := ThinLineChars;	75	chars := ThinLineChars;
76	if thickness = 2 then	76	if thickness = 2 then
77	chars := DoubleLineChars;	77	chars := DoubleLineChars;
78		78
79	(* Top line *)	79	(* Top line *)
80	if y >= 1 then	80	if y >= 1 then
81	begin	81	begin
82	(* Top left corner *)	82	(* Top left corner *)
83	if x >= 1 then	83	if x >= 1 then
84	begin	84	begin
85	GotoXY(x,y);	85	GotoXY(x,y);
86	Write(chars[0]);	86	Write(chars[0]);
87	end	87	end
88	else	88	else
89	begin	89	begin
90	GotoXY(1,y);	90	GotoXY(1,y);
91	end;	91	end;
92		92
93	(* Top edge *)	93	(* Top edge *)
94	for ix := 1 to width-2 do	94	for ix := 1 to width-2 do
95	Write(chars[1]);	95	Write(chars[1]);
96		96
97	(* Top right corner *)	97	(* Top right corner *)
98	if x+width-1 <= ScreenWidth then	98	if x+width-1 <= ScreenWidth then
99	Write(chars[2]);	99	Write(chars[2]);
100	end;	100	end;
101		101
102	(* Left edge *)	102	(* Left edge *)
103	for iy := 1 to height-2 do	103	for iy := 1 to height-2 do
104	begin	104	begin
105	if (x >= 1) and (x <= ScreenWidth) and	105	if (x >= 1) and (x <= ScreenWidth) and
106	(y+iy >= 1) and (y+iy <= ScreenHeight) then	106	(y+iy >= 1) and (y+iy <= ScreenHeight) then
107	begin	107	begin
108	GotoXY(x,y+iy);	108	GotoXY(x,y+iy);
109	Write(chars[3]);	109	Write(chars[3]);
110	end;	110	end;
111	end;	111	end;
112		112
113	(* Right edge *)	113	(* Right edge *)
114	for iy := 1 to height-2 do	114	for iy := 1 to height-2 do
115	begin	115	begin
116	if (x+width-1 >= 1) and (x+width-1 <= ScreenWidth) and	116	if (x+width-1 >= 1) and (x+width-1 <= ScreenWidth) and
117	(y+iy >= 1) and (y+iy <= ScreenHeight) then	117	(y+iy >= 1) and (y+iy <= ScreenHeight) then
118	begin	118	begin
119	GotoXY(x+width-1,y+iy);	119	GotoXY(x+width-1,y+iy);
120	Write(chars[4]);	120	Write(chars[4]);
121	end;	121	end;
122	end;	122	end;
123		123
124	(* Bottom line *)	124	(* Bottom line *)
125	if y+height-1 <= ScreenHeight then	125	if y+height-1 <= ScreenHeight then
126	begin	126	begin
127	(* Bottom left corner *)	127	(* Bottom left corner *)
128	if x >= 1 then	128	if x >= 1 then
129	begin	129	begin
130	GotoXY(x,y+height-1);	130	GotoXY(x,y+height-1);
131	Write(chars[5]);	131	Write(chars[5]);
132	end	132	end
133	else	133	else
134	begin	134	begin
135	GotoXY(1,y+height-1);	135	GotoXY(1,y+height-1);
136	end;	136	end;
137		137
138	(* Bottom edge *)	138	(* Bottom edge *)
139	for ix := 1 to width-2 do	139	for ix := 1 to width-2 do
140	Write(chars[6]);	140	Write(chars[6]);
141		141
142	(* Bottom right corner *)	142	(* Bottom right corner *)
143	if x+width-1 <= ScreenWidth then	143	if x+width-1 <= ScreenWidth then
144	Write(chars[7]);	144	Write(chars[7]);
145	end;	145	end;
146	end;	146	end;
147		147
148	procedure DrawThinBorder(x, y, width, height: integer);	148	procedure DrawThinBorder(x, y, width, height: integer);
149	begin	149	begin
150	DrawBorder(x, y, width, height, 1);	150	DrawBorder(x, y, width, height, 1);
151	end;	151	end;
152		152
153	procedure DrawDoubleBorder(x, y, width, height: integer);	153	procedure DrawDoubleBorder(x, y, width, height: integer);
154	begin	154	begin
155	DrawBorder(x, y, width, height, 2);	155	DrawBorder(x, y, width, height, 2);
156	end;	156	end;
157		157
158	procedure DrawTextBar(str: string; line: integer);	158	procedure DrawTextBar(str: string; line: integer);
159	var	159	var
160	i, left, right: integer;	160	i, left, right: integer;
161	len: integer;	161	len: integer;
162	begin	162	begin
163	GotoXY(1,line);	163	GotoXY(1,line);
164		164
165	TextBackground(White);	165	TextBackground(White);
166	TextColor(Black);	166	TextColor(Black);
167	len := Length(str);	167	len := Length(str);
168		168
169	left := round((ScreenWidth-len)/2);	169	left := round((ScreenWidth-len)/2);
170	right := ScreenWidth - left - len;	170	right := ScreenWidth - left - len;
171		171
172	for i := 1 to left do	172	for i := 1 to left do
173	begin	173	begin
174	Write(' ');	174	Write(' ');
175	end;	175	end;
176		176
177	Write(str);	177	Write(str);
178		178
179	(* TODO: If we do "for i := 1 to right", then the console will scroll *)	179	(* TODO: If we do "for i := 1 to right", then the console will scroll *)
180	(* since the char in the right bottom corner is written! *)	180	(* since the char in the right bottom corner is written! *)
181	for i := 1 to right-1 do	181	for i := 1 to right-1 do
182	begin	182	begin
183	Write(' ');	183	Write(' ');
184	end;	184	end;
185		185
186	TextBackground(Black);	186	TextBackground(Black);
187	TextColor(White);	187	TextColor(White);
188	end;	188	end;
189		189
190	procedure DrawTitleBar(center, left, right: string);	190	procedure DrawTitleBar(center, left, right: string);
191	begin	191	begin
192	DrawTextBar(center, 1);	192	DrawTextBar(center, 1);
193		193
194	(* Put left text into the title bar *)	194	(* Put left text into the title bar *)
195	GoToXY(1,1);	195	GoToXY(1,1);
196	TextBackground(White);	196	TextBackground(White);
197	TextColor(Black);	197	TextColor(Black);
198	WriteLn(left);	198	WriteLn(left);
199	TextBackground(Black);	199	TextBackground(Black);
200	TextColor(White);	200	TextColor(White);
201		201
202	(* Put right text into the title bar *)	202	(* Put right text into the title bar *)
203	GotoXY(ScreenWidth-Length(right)+1,1);	203	GotoXY(ScreenWidth-Length(right)+1,1);
204	TextBackground(White);	204	TextBackground(White);
205	TextColor(Black);	205	TextColor(Black);
206	WriteLn(right);	206	WriteLn(right);
207	TextBackground(Black);	207	TextBackground(Black);
208	TextColor(White);	208	TextColor(White);
209	end;	209	end;
210		210
211	procedure DrawStatusBar(str: string);	211	procedure DrawStatusBar(str: string);
212	begin	212	begin
213	DrawTextBar(str, ScreenHeight);	213	DrawTextBar(str, ScreenHeight);
214	end;	214	end;
215		215
216	function DrawSelectionList(X, Y, ListWidth, ListHeight: integer;	216	function DrawSelectionList(X, Y, ListWidth, ListHeight: integer;
217	items: PStringList; allowESC: boolean;	217	items: PStringList; allowESC: boolean;
218	Title: string; borderStrength: integer): integer;	218	Title: string; borderStrength: integer): integer;
219	var	219	var
220	i: integer;	220	i: integer;
221	itemIndex: integer;	221	itemIndex: integer;
222	sc: char;	222	sc: char;
223	iStartScope, iEndScope: integer;	223	iStartScope, iEndScope: integer;
224	sTmp: string;	224	sTmp: string;
225	label	225	label
226	doAgain;	226	doAgain;
227	begin	227	begin
228	if borderStrength = 1 then	228	if borderStrength = 1 then
229	begin	229	begin
230	DrawThinBorder(X-1, Y-1, ListWidth+2, ListHeight+2);	230	DrawThinBorder(X-1, Y-1, ListWidth+2, ListHeight+2);
231	end;	231	end;
232		232
233	if borderStrength = 2 then	233	if borderStrength = 2 then
234	begin	234	begin
235	DrawDoubleBorder(X-1, Y-1, ListWidth+2, ListHeight+2);	235	DrawDoubleBorder(X-1, Y-1, ListWidth+2, ListHeight+2);
236	end;	236	end;
237		237
238	if Title <> '' then	238	if Title <> '' then
239	begin	239	begin
240	if borderStrength > 0 then	240	if borderStrength > 0 then
241	GoToXY(X+1, Y-1)	241	GoToXY(X+1, Y-1)
242	else	242	else
243	GoToXY(X, Y-1);	243	GoToXY(X, Y-1);
244	Write(Title);	244	Write(Title);
245	end;	245	end;
246		246
247	(CursorOff;)	247	(CursorOff;)
248		248
249	itemIndex := 0;	249	itemIndex := 0;
250	iStartScope := itemIndex;	250	iStartScope := itemIndex;
251	iEndScope := itemIndex + ListHeight;	251	iEndScope := itemIndex + ListHeight;
252		252
253	doAgain:	253	doAgain:
254		254
255	if itemIndex < 0 then	255	if itemIndex < 0 then
256	itemIndex := 0;	256	itemIndex := 0;
257	if itemIndex > ListCount(items)-1 then	257	if itemIndex > ListCount(items)-1 then
258	itemIndex := ListCount(items)-1;	258	itemIndex := ListCount(items)-1;
259		259
260	if itemIndex < iStartScope then	260	if itemIndex < iStartScope then
261	begin	261	begin
262	Dec(iEndScope);	262	Dec(iEndScope);
263	Dec(iStartScope);	263	Dec(iStartScope);
264	end;	264	end;
265		265
266	if itemIndex > iEndScope-1 then	266	if itemIndex > iEndScope-1 then
267	begin	267	begin
268	Inc(iEndScope);	268	Inc(iEndScope);
269	Inc(iStartScope);	269	Inc(iStartScope);
270	end;	270	end;
271		271
272	if borderStrength > 0 then	272	if borderStrength > 0 then
273	begin	273	begin
274	(* Show scroll arrows *)	274	(* Show scroll arrows *)
275	GotoXY(X+ListWidth, Y);	275	GotoXY(X+ListWidth, Y);
276	if iStartScope > 0 then	276	if iStartScope > 0 then
277	begin	277	begin
278	TextBackground(White);	278	TextBackground(White);
279	TextColor(Black);	279	TextColor(Black);
280	WriteLn(#$18(ArrowUp));	280	WriteLn(#$18(ArrowUp));
281	TextBackground(Black);	281	TextBackground(Black);
282	TextColor(White);	282	TextColor(White);
283	end	283	end
284	else if borderStrength = 1 then	284	else if borderStrength = 1 then
285	WriteLn(ThinLineChars[4])	285	WriteLn(ThinLineChars[4])
286	else if borderStrength = 2 then	286	else if borderStrength = 2 then
287	WriteLn(DoubleLineChars[4]);	287	WriteLn(DoubleLineChars[4]);
288		288
289	GotoXY(X+ListWidth, Y+ListHeight-1);	289	GotoXY(X+ListWidth, Y+ListHeight-1);
290	if ListCount(items) > iEndScope then	290	if ListCount(items) > iEndScope then
291	begin	291	begin
292	TextBackground(White);	292	TextBackground(White);
293	TextColor(Black);	293	TextColor(Black);
294	WriteLn(#$19(ArrowDown));	294	WriteLn(#$19(ArrowDown));
295	TextBackground(Black);	295	TextBackground(Black);
296	TextColor(White);	296	TextColor(White);
297	end	297	end
298	else if borderStrength = 1 then	298	else if borderStrength = 1 then
299	WriteLn(ThinLineChars[4])	299	WriteLn(ThinLineChars[4])
300	else if borderStrength = 2 then	300	else if borderStrength = 2 then
301	WriteLn(DoubleLineChars[4]);	301	WriteLn(DoubleLineChars[4]);
302	end;	302	end;
303		303
304	for i := iStartScope to iEndScope-1 do	304	for i := iStartScope to iEndScope-1 do
305	begin	305	begin
306	if itemIndex = i then	306	if itemIndex = i then
307	begin	307	begin
308	TextColor(Black);	308	TextColor(Black);
309	TextBackground(White);	309	TextBackground(White);
310	end	310	end
311	else	311	else
312	begin	312	begin
313	TextColor(White);	313	TextColor(White);
314	TextBackground(Black);	314	TextBackground(Black);
315	end;	315	end;
316	GotoXY(x,y+i-iStartScope);	316	GotoXY(x,y+i-iStartScope);
317	if i > ListCount(items)-1 then	317	if i > ListCount(items)-1 then
318	Write(FillRight('', ListWidth, ' '))	318	Write(FillRight('', ListWidth, ' '))
319	else	319	else
320	begin	320	begin
321	sTmp := ListGetElement(items, i);	321	sTmp := ListGetElement(items, i);
322	if Length(sTmp) > ListWidth then	-
323	begin	-
324	(* Cut too long line *)	-
325	sTmp := Copy(sTmp, 1, ListWidth-3) + '...';	322	sTmp := TrimLineToWidth(sTmp, ListWidth);
326	end;	-
327	Write(FillRight(sTmp, ListWidth, ' '));	323	Write(FillRight(sTmp, ListWidth, ' '));
328	end;	324	end;
329	TextColor(White);	325	TextColor(White);
330	TextBackground(Black);	326	TextBackground(Black);
331	end;	327	end;
332		328
333	repeat	329	repeat
334	GotoXY(ScreenWidth, ScreenHeight);	330	GotoXY(ScreenWidth, ScreenHeight);
335		331
336	sc := ReadKey;	332	sc := ReadKey;
337	if sc = #$00(ExtendedKeyCode) then	333	if sc = #$00(ExtendedKeyCode) then
338	begin	334	begin
339	sc := ReadKey;	335	sc := ReadKey;
340	if sc = #$48(UpKey) then	336	if sc = #$48(UpKey) then
341	begin	337	begin
342	dec(itemIndex);	338	dec(itemIndex);
343	goto doAgain;	339	goto doAgain;
344	end	340	end
345	else if sc = #$50(DownKey) then	341	else if sc = #$50(DownKey) then
346	begin	342	begin
347	inc(itemIndex);	343	inc(itemIndex);
348	goto doAgain;	344	goto doAgain;
349	end	345	end
350	else if sc = #$47(POS1) then	346	else if sc = #$47(POS1) then
351	begin	347	begin
352	itemIndex := 0;	348	itemIndex := 0;
-		349	iStartScope := 0;
-		350	iEndScope := iStartScope + ListHeight;
353	goto doAgain;	351	goto doAgain;
354	end	352	end
355	else if sc = #$4F(END) then	353	else if sc = #$4F(END) then
356	begin	354	begin
357	itemIndex := ListCount(items);	355	itemIndex := ListCount(items)-1;
-		356	iStartScope := itemIndex - Min(ListHeight,ListCount(items));
-		357	iEndScope := itemIndex;
358	goto doAgain;	358	goto doAgain;
359	end;	359	end;
360	end;	360	end;
361		361
362	if sc = #13(Return) then	362	if sc = #13(Return) then
363	begin	363	begin
364	DrawSelectionList := itemIndex;	364	DrawSelectionList := itemIndex;
365	break;	365	break;
366	end;	366	end;
367		367
368	if allowESC and (sc = #27(ESC)) then	368	if allowESC and (sc = #27(ESC)) then
369	begin	369	begin
370	DrawSelectionList := -1;	370	DrawSelectionList := -1;
371	break;	371	break;
372	end;	372	end;
373	until false;	373	until false;
374		374
375	(CursorOn;)	375	(CursorOn;)
376	end;	376	end;
377		377
378	procedure ClearSection(x, y, width, height: integer);	378	procedure ClearSection(x, y, width, height: integer);
379	var	379	var
380	ix, iy: integer;	380	ix, iy: integer;
381	begin	381	begin
382	for iy := y to y+height-1 do	382	for iy := y to y+height-1 do
383	begin	383	begin
384	for ix := x to x+width-1 do	384	for ix := x to x+width-1 do
385	begin	385	begin
386	GoToXY(ix,iy);	386	GoToXY(ix,iy);
387	Write(' ');	387	Write(' ');
388	end;	388	end;
389	end;	389	end;
390	end;	390	end;
391		391
392	function QueryVal(var s: string; initX, initY, width, height: integer;	392	function QueryVal(var s: string; initX, initY, width, height: integer;
393	Title: string; borderStrength: integer): boolean;	393	Title: string; borderStrength: integer): boolean;
394	var	394	var
395	x, y: integer;	395	x, y: integer;
396	i, j: integer;	396	i, j: integer;
397	sc: char;	397	sc: char;
398	stmp: string;	398	stmp: string;
399	begin	399	begin
400	if borderStrength = 1 then	400	if borderStrength = 1 then
401	DrawThinBorder(initX-1,initY-1,width+2,height+2);	401	DrawThinBorder(initX-1,initY-1,width+2,height+2);
402	if borderStrength = 2 then	402	if borderStrength = 2 then
403	DrawDoubleBorder(initX-1,initY-1,width+2,height+2);	403	DrawDoubleBorder(initX-1,initY-1,width+2,height+2);
404	if title <> '' then	404	if title <> '' then
405	begin	405	begin
406	if borderStrength > 0 then	406	if borderStrength > 0 then
407	GoToXY(initX+1, initY-1)	407	GoToXY(initX+1, initY-1)
408	else	408	else
409	GoToXY(initX, initY-1);	409	GoToXY(initX, initY-1);
410	Write(title);	410	Write(title);
411	end;	411	end;
412	ClearSection(initX,initY,width,height);	412	ClearSection(initX,initY,width,height);
413		413
414	x := initX;	414	x := initX;
415	y := initY;	415	y := initY;
416		416
417	(* Write existing string value and set cursor *)	417	(* Write existing string value and set cursor *)
418	stmp := s;	418	stmp := s;
419	s := '';	419	s := '';
420	for i := 1 to Length(stmp) do	420	for i := 1 to Length(stmp) do
421	begin	421	begin
422	if stmp[i] = #10 then	422	if stmp[i] = #10 then
423	begin	423	begin
424	s := s + stmp[i];	424	s := s + stmp[i];
425	continue;	425	continue;
426	end;	426	end;
427		427
428	GoToXY(x,y);	428	GoToXY(x,y);
429	s := s + stmp[i];	429	s := s + stmp[i];
430	Write(stmp[i]);	430	Write(stmp[i]);
431	Inc(x);	431	Inc(x);
432		432
433	if (x=initX+width-1) and (y=initY+height-1) then	433	if (x=initX+width-1) and (y=initY+height-1) then
434	begin	434	begin
435	(* Attention: Data following after this will be lost! *)	435	(* Attention: Data following after this will be lost! *)
436	break;	436	break;
437	end;	437	end;
438		438
439	if stmp[i] = #13 then	439	if stmp[i] = #13 then
440	begin	440	begin
441	if y=initY+height-1 then	441	if y=initY+height-1 then
442	begin	442	begin
443	(* Attention: Data following after this will be lost! *)	443	(* Attention: Data following after this will be lost! *)
444	s := Copy(s, 1, Length(s)-1);	444	s := Copy(s, 1, Length(s)-1);
445	Dec(x);	445	Dec(x);
446	break;	446	break;
447	end;	447	end;
448	x := initX;	448	x := initX;
449	Inc(y);	449	Inc(y);
450	continue;	450	continue;
451	end;	451	end;
452		452
453	if x=initX+width then	453	if x=initX+width then
454	begin	454	begin
455	Inc(y);	455	Inc(y);
456	x := initX;	456	x := initX;
457	end;	457	end;
458	end;	458	end;
459		459
460	repeat	460	repeat
461	GotoXY(x, y);	461	GotoXY(x, y);
462	sc := ReadKey;	462	sc := ReadKey;
463		463
464	if sc = #0 then	464	if sc = #0 then
465	begin	465	begin
466	(* Extended key code *)	466	(* Extended key code *)
467	sc := ReadKey;	467	sc := ReadKey;
468	(* TODO: Implement keys like DEL, END, POS1, and ArrowKeys *)	468	(* TODO: Implement keys like DEL, END, POS1, and ArrowKeys *)
469	Beep;	469	Beep;
470	continue;	470	continue;
471	end	471	end
472	else if sc = #8(Backspace) then	472	else if sc = #8(Backspace) then
473	begin	473	begin
474	if x <= initX then	474	if x <= initX then
475	begin	475	begin
476	if y = initY then	476	if y = initY then
477	begin	477	begin
478	Beep;	478	Beep;
479	continue;	479	continue;
480	end;	480	end;
481	Dec(y);	481	Dec(y);
482		482
483	(* Find out length of previous line *)	483	(* Find out length of previous line *)
484	j := Length(s)-2(CRLF);	484	j := Length(s)-2(CRLF);
485	while (j >= 0) do	485	while (j >= 0) do
486	begin	486	begin
487	if (s[j]=#13) or (s[j]=#10) then break;	487	if (s[j]=#13) or (s[j]=#10) then break;
488	Dec(j);	488	Dec(j);
489	end;	489	end;
490	j := Length(s)-2(CRLF)-j;	490	j := Length(s)-2(CRLF)-j;
491	x := initX + j;	491	x := initX + j;
492	s := Copy(s, 1, Length(s)-1); (* Remove #10 now. #13 will be removed below *)	492	s := Copy(s, 1, Length(s)-1); (* Remove #10 now. #13 will be removed below *)
493	end	493	end
494	else	494	else
495	begin	495	begin
496	Dec(x);	496	Dec(x);

Subversion Repositories oidplus

oidplus/trunk_dos/VTSCUI.PAS – Rev 738 → 740