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);
      if Length(sTmp) > ListWidth then
      begin
        (* Cut too long line *)
        sTmp := Copy(sTmp, 1, ListWidth-3) + '...';
      end;
      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;
        goto doAgain;
      end
      else if sc = #$4F(*END*) then
      begin
        itemIndex := ListCount(items);
        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 735	Rev 738
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(str: 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(str: string);	190	procedure DrawTitleBar(center, left, right: string);
191	begin	191	begin
192	DrawTextBar(str, 1);	192	DrawTextBar(center, 1);
-		193
-		194	(* Put left text into the title bar *)
-		195	GoToXY(1,1);
-		196	TextBackground(White);
-		197	TextColor(Black);
-		198	WriteLn(left);
-		199	TextBackground(Black);
-		200	TextColor(White);
-		201
-		202	(* Put right text into the title bar *)
-		203	GotoXY(ScreenWidth-Length(right)+1,1);
-		204	TextBackground(White);
-		205	TextColor(Black);
-		206	WriteLn(right);
-		207	TextBackground(Black);
-		208	TextColor(White);
193	end;	209	end;
194		210
195	procedure DrawStatusBar(str: string);	211	procedure DrawStatusBar(str: string);
196	begin	212	begin
197	DrawTextBar(str, ScreenHeight);	213	DrawTextBar(str, ScreenHeight);
198	end;	214	end;
199		215
200	function DrawSelectionList(X, Y, ListWidth, ListHeight: integer;	216	function DrawSelectionList(X, Y, ListWidth, ListHeight: integer;
201	items: PStringList; allowESC: boolean;	217	items: PStringList; allowESC: boolean;
202	Title: string; borderStrength: integer): integer;	218	Title: string; borderStrength: integer): integer;
203	var	219	var
204	i: integer;	220	i: integer;
205	itemIndex: integer;	221	itemIndex: integer;
206	sc: char;	222	sc: char;
207	iStartScope, iEndScope: integer;	223	iStartScope, iEndScope: integer;
208	sTmp: string;	224	sTmp: string;
209	label	225	label
210	doAgain;	226	doAgain;
211	begin	227	begin
212	if borderStrength = 1 then	228	if borderStrength = 1 then
213	begin	229	begin
214	DrawThinBorder(X-1, Y-1, ListWidth+2, ListHeight+2);	230	DrawThinBorder(X-1, Y-1, ListWidth+2, ListHeight+2);
215	end;	231	end;
216		232
217	if borderStrength = 2 then	233	if borderStrength = 2 then
218	begin	234	begin
219	DrawDoubleBorder(X-1, Y-1, ListWidth+2, ListHeight+2);	235	DrawDoubleBorder(X-1, Y-1, ListWidth+2, ListHeight+2);
220	end;	236	end;
221		237
222	if Title <> '' then	238	if Title <> '' then
223	begin	239	begin
224	if borderStrength > 0 then	240	if borderStrength > 0 then
225	GoToXY(X+1, Y-1)	241	GoToXY(X+1, Y-1)
226	else	242	else
227	GoToXY(X, Y-1);	243	GoToXY(X, Y-1);
228	Write(Title);	244	Write(Title);
229	end;	245	end;
230		246
231	(CursorOff;)	247	(CursorOff;)
232		248
233	itemIndex := 0;	249	itemIndex := 0;
234	iStartScope := itemIndex;	250	iStartScope := itemIndex;
235	iEndScope := itemIndex + ListHeight;	251	iEndScope := itemIndex + ListHeight;
236		252
237	doAgain:	253	doAgain:
238		254
239	if itemIndex < 0 then	255	if itemIndex < 0 then
240	itemIndex := 0;	256	itemIndex := 0;
241	if itemIndex > ListCount(items)-1 then	257	if itemIndex > ListCount(items)-1 then
242	itemIndex := ListCount(items)-1;	258	itemIndex := ListCount(items)-1;
243		259
244	if itemIndex < iStartScope then	260	if itemIndex < iStartScope then
245	begin	261	begin
246	Dec(iEndScope);	262	Dec(iEndScope);
247	Dec(iStartScope);	263	Dec(iStartScope);
248	end;	264	end;
249		265
250	if itemIndex > iEndScope-1 then	266	if itemIndex > iEndScope-1 then
251	begin	267	begin
252	Inc(iEndScope);	268	Inc(iEndScope);
253	Inc(iStartScope);	269	Inc(iStartScope);
254	end;	270	end;
255		271
256	if borderStrength > 0 then	272	if borderStrength > 0 then
257	begin	273	begin
258	(* Show scroll arrows *)	274	(* Show scroll arrows *)
259	GotoXY(X+ListWidth, Y);	275	GotoXY(X+ListWidth, Y);
260	if iStartScope > 0 then	276	if iStartScope > 0 then
261	begin	277	begin
262	TextBackground(White);	278	TextBackground(White);
263	TextColor(Black);	279	TextColor(Black);
264	WriteLn(#$18(ArrowUp));	280	WriteLn(#$18(ArrowUp));
265	TextBackground(Black);	281	TextBackground(Black);
266	TextColor(White);	282	TextColor(White);
267	end	283	end
268	else if borderStrength = 1 then	284	else if borderStrength = 1 then
269	WriteLn(ThinLineChars[4])	285	WriteLn(ThinLineChars[4])
270	else if borderStrength = 2 then	286	else if borderStrength = 2 then
271	WriteLn(DoubleLineChars[4]);	287	WriteLn(DoubleLineChars[4]);
272		288
273	GotoXY(X+ListWidth, Y+ListHeight-1);	289	GotoXY(X+ListWidth, Y+ListHeight-1);
274	if ListCount(items) > iEndScope then	290	if ListCount(items) > iEndScope then
275	begin	291	begin
276	TextBackground(White);	292	TextBackground(White);
277	TextColor(Black);	293	TextColor(Black);
278	WriteLn(#$19(ArrowDown));	294	WriteLn(#$19(ArrowDown));
279	TextBackground(Black);	295	TextBackground(Black);
280	TextColor(White);	296	TextColor(White);
281	end	297	end
282	else if borderStrength = 1 then	298	else if borderStrength = 1 then
283	WriteLn(ThinLineChars[4])	299	WriteLn(ThinLineChars[4])
284	else if borderStrength = 2 then	300	else if borderStrength = 2 then
285	WriteLn(DoubleLineChars[4]);	301	WriteLn(DoubleLineChars[4]);
286	end;	302	end;
287		303
288	for i := iStartScope to iEndScope-1 do	304	for i := iStartScope to iEndScope-1 do
289	begin	305	begin
290	if itemIndex = i then	306	if itemIndex = i then
291	begin	307	begin
292	TextColor(Black);	308	TextColor(Black);
293	TextBackground(White);	309	TextBackground(White);
294	end	310	end
295	else	311	else
296	begin	312	begin
297	TextColor(White);	313	TextColor(White);
298	TextBackground(Black);	314	TextBackground(Black);
299	end;	315	end;
300	GotoXY(x,y+i-iStartScope);	316	GotoXY(x,y+i-iStartScope);
301	if i > ListCount(items)-1 then	317	if i > ListCount(items)-1 then
302	Write(FillRight('', ListWidth, ' '))	318	Write(FillRight('', ListWidth, ' '))
303	else	319	else
304	begin	320	begin
305	sTmp := ListGetElement(items, i);	321	sTmp := ListGetElement(items, i);
306	if Length(sTmp) > ListWidth then	322	if Length(sTmp) > ListWidth then
307	begin	323	begin
308	(* Cut too long line *)	324	(* Cut too long line *)
309	sTmp := Copy(sTmp, 1, ListWidth-3) + '...';	325	sTmp := Copy(sTmp, 1, ListWidth-3) + '...';
310	end;	326	end;
311	Write(FillRight(sTmp, ListWidth, ' '));	327	Write(FillRight(sTmp, ListWidth, ' '));
312	end;	328	end;
313	TextColor(White);	329	TextColor(White);
314	TextBackground(Black);	330	TextBackground(Black);
315	end;	331	end;
316		332
317	repeat	333	repeat
318	GotoXY(ScreenWidth, ScreenHeight);	334	GotoXY(ScreenWidth, ScreenHeight);
319		335
320	sc := ReadKey;	336	sc := ReadKey;
321	if sc = #$00(ExtendedKeyCode) then	337	if sc = #$00(ExtendedKeyCode) then
322	begin	338	begin
323	sc := ReadKey;	339	sc := ReadKey;
324	if sc = #$48(UpKey) then	340	if sc = #$48(UpKey) then
325	begin	341	begin
326	dec(itemIndex);	342	dec(itemIndex);
327	goto doAgain;	343	goto doAgain;
328	end	344	end
329	else if sc = #$50(DownKey) then	345	else if sc = #$50(DownKey) then
330	begin	346	begin
331	inc(itemIndex);	347	inc(itemIndex);
332	goto doAgain;	348	goto doAgain;
333	end	349	end
334	else if sc = #$47(POS1) then	350	else if sc = #$47(POS1) then
335	begin	351	begin
336	itemIndex := 0;	352	itemIndex := 0;
337	goto doAgain;	353	goto doAgain;
338	end	354	end
339	else if sc = #$4F(END) then	355	else if sc = #$4F(END) then
340	begin	356	begin
341	itemIndex := ListCount(items);	357	itemIndex := ListCount(items);
342	goto doAgain;	358	goto doAgain;
343	end;	359	end;
344	end;	360	end;
345		361
346	if sc = #13(Return) then	362	if sc = #13(Return) then
347	begin	363	begin
348	DrawSelectionList := itemIndex;	364	DrawSelectionList := itemIndex;
349	break;	365	break;
350	end;	366	end;
351		367
352	if allowESC and (sc = #27(ESC)) then	368	if allowESC and (sc = #27(ESC)) then
353	begin	369	begin
354	DrawSelectionList := -1;	370	DrawSelectionList := -1;
355	break;	371	break;
356	end;	372	end;
357	until false;	373	until false;
358		374
359	(CursorOn;)	375	(CursorOn;)
360	end;	376	end;
361		377
362	procedure ClearSection(x, y, width, height: integer);	378	procedure ClearSection(x, y, width, height: integer);
363	var	379	var
364	ix, iy: integer;	380	ix, iy: integer;
365	begin	381	begin
366	for iy := y to y+height-1 do	382	for iy := y to y+height-1 do
367	begin	383	begin
368	for ix := x to x+width-1 do	384	for ix := x to x+width-1 do
369	begin	385	begin
370	GoToXY(ix,iy);	386	GoToXY(ix,iy);
371	Write(' ');	387	Write(' ');
372	end;	388	end;
373	end;	389	end;
374	end;	390	end;
375		391
376	function QueryVal(var s: string; initX, initY, width, height: integer;	392	function QueryVal(var s: string; initX, initY, width, height: integer;
377	Title: string; borderStrength: integer): boolean;	393	Title: string; borderStrength: integer): boolean;
378	var	394	var
379	x, y: integer;	395	x, y: integer;
380	i, j: integer;	396	i, j: integer;
381	sc: char;	397	sc: char;
382	stmp: string;	398	stmp: string;
383	begin	399	begin
384	if borderStrength = 1 then	400	if borderStrength = 1 then
385	DrawThinBorder(initX-1,initY-1,width+2,height+2);	401	DrawThinBorder(initX-1,initY-1,width+2,height+2);
386	if borderStrength = 2 then	402	if borderStrength = 2 then
387	DrawDoubleBorder(initX-1,initY-1,width+2,height+2);	403	DrawDoubleBorder(initX-1,initY-1,width+2,height+2);
388	if title <> '' then	404	if title <> '' then
389	begin	405	begin
390	if borderStrength > 0 then	406	if borderStrength > 0 then
391	GoToXY(initX+1, initY-1)	407	GoToXY(initX+1, initY-1)
392	else	408	else
393	GoToXY(initX, initY-1);	409	GoToXY(initX, initY-1);
394	Write(title);	410	Write(title);
395	end;	411	end;
396	ClearSection(initX,initY,width,height);	412	ClearSection(initX,initY,width,height);
397		413
398	x := initX;	414	x := initX;
399	y := initY;	415	y := initY;
400		416
401	(* Write existing string value and set cursor *)	417	(* Write existing string value and set cursor *)
402	stmp := s;	418	stmp := s;
403	s := '';	419	s := '';
404	for i := 1 to Length(stmp) do	420	for i := 1 to Length(stmp) do
405	begin	421	begin
406	if stmp[i] = #10 then	422	if stmp[i] = #10 then
407	begin	423	begin
408	s := s + stmp[i];	424	s := s + stmp[i];
409	continue;	425	continue;
410	end;	426	end;
411		427
412	GoToXY(x,y);	428	GoToXY(x,y);
413	s := s + stmp[i];	429	s := s + stmp[i];
414	Write(stmp[i]);	430	Write(stmp[i]);
415	Inc(x);	431	Inc(x);
416		432
417	if (x=initX+width-1) and (y=initY+height-1) then	433	if (x=initX+width-1) and (y=initY+height-1) then
418	begin	434	begin
419	(* Attention: Data following after this will be lost! *)	435	(* Attention: Data following after this will be lost! *)
420	break;	436	break;
421	end;	437	end;
422		438
423	if stmp[i] = #13 then	439	if stmp[i] = #13 then
424	begin	440	begin
425	if y=initY+height-1 then	441	if y=initY+height-1 then
426	begin	442	begin
427	(* Attention: Data following after this will be lost! *)	443	(* Attention: Data following after this will be lost! *)
428	s := Copy(s, 1, Length(s)-1);	444	s := Copy(s, 1, Length(s)-1);
429	Dec(x);	445	Dec(x);
430	break;	446	break;
431	end;	447	end;
432	x := initX;	448	x := initX;
433	Inc(y);	449	Inc(y);
434	continue;	450	continue;
435	end;	451	end;
436		452
437	if x=initX+width then	453	if x=initX+width then
438	begin	454	begin
439	Inc(y);	455	Inc(y);
440	x := initX;	456	x := initX;
441	end;	457	end;
442	end;	458	end;
443		459
444	repeat	460	repeat
445	GotoXY(x, y);	461	GotoXY(x, y);
446	sc := ReadKey;	462	sc := ReadKey;
447		463
448	if sc = #0 then	464	if sc = #0 then
449	begin	465	begin
450	(* Extended key code *)	466	(* Extended key code *)
451	sc := ReadKey;	467	sc := ReadKey;
452	(* TODO: Implement keys like DEL, END, POS1, and ArrowKeys *)	468	(* TODO: Implement keys like DEL, END, POS1, and ArrowKeys *)
453	Beep;	469	Beep;
454	continue;	470	continue;
455	end	471	end
456	else if sc = #8(Backspace) then	472	else if sc = #8(Backspace) then
457	begin	473	begin
458	if x <= initX then	474	if x <= initX then
459	begin	475	begin
460	if y = initY then	476	if y = initY then
461	begin	477	begin
462	Beep;	478	Beep;
463	continue;	479	continue;
464	end;	480	end;
465	Dec(y);	481	Dec(y);
466		482
467	(* Find out length of previous line *)	483	(* Find out length of previous line *)
468	j := Length(s)-2(CRLF);	484	j := Length(s)-2(CRLF);
469	while (j >= 0) do	485	while (j >= 0) do
470	begin	486	begin
471	if (s[j]=#13) or (s[j]=#10) then break;	487	if (s[j]=#13) or (s[j]=#10) then break;
472	Dec(j);	488	Dec(j);
473	end;	489	end;
474	j := Length(s)-2(CRLF)-j;	490	j := Length(s)-2(CRLF)-j;
475	x := initX + j;	491	x := initX + j;
476	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 *)
477	end	493	end
478	else	494	else
479	begin	495	begin
480	Dec(x);	496	Dec(x);
481	end;	497	end;
482	GotoXY(x, y);	498	GotoXY(x, y);
483	Write(' ');	499	Write(' ');
484	GotoXY(x, y);	500	GotoXY(x, y);

Subversion Repositories oidplus

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