home *** CD-ROM | disk | FTP | other *** search
/ Zodiac Super OZ / MEDIADEPOT.ISO / FILES / 13 / COMMIO0B.ZIP / DOORIO.PAS < prev    next >
Pascal/Delphi Source File  |  1996-05-14  |  34KB  |  996 lines
  1. {$X+}
  2. unit DOORIO;
  3. {
  4.           This unit is a companion to the COMMIO communications unit.
  5.                 Written by Jason Morriss a.k.a. Lief O'Pardy
  6.  
  7.                   Copyright (C) 1995,1996 by Jason Morriss
  8.  
  9.   This unit has a group of procedures and functions for getting input from
  10.   the user in various ways, and writting text in various ways, including
  11.   some animation.
  12.   Some of the following routines CAN NOT be used over the modem since there's
  13.   no way to "TELL" the other computer how to do it.  They are here because
  14.   this unit used to be my own IO unit for my "normal" programs, i just
  15.   converted it for these DOOR routines, and then added more routines
  16.   ... enjoy.
  17. }
  18. INTERFACE
  19.  
  20. uses crt, commio;
  21.  
  22. Type
  23.   TCharSet = Set of Char;
  24.   Tauto = (noauto,upper,lower,smart);
  25.   Twriter = (nofx,wipe1,fadein,fadeout);
  26. Var
  27.   Pause_Proc: procedure(s:string);
  28. {  More_Proc : function(s:string;chs:tcharset):TMoreResults;}
  29. Const Charset : tcharset = [#32..#232,#234..#255];
  30. Const NumSet  : tcharset = ['0'..'9','-'];
  31. Const
  32. {  pausestr  : string[100] = 'Θ|1ΘB <PAUSE> Θ|0';
  33.   pausestrl : byte = 9;{}
  34.   inserton  : boolean = false;
  35. {--[v- how the string is displayed with putstr/xy() ]--}
  36.   writer    : Twriter = nofx;
  37.   dlay      : array[Twriter] of word = (0,10,100,100);
  38. {--[v- if true Getstr() will echo "secretchar" (used for passwords) ]--}
  39.   secret    : boolean = false;
  40.   secretchar: char = '█';
  41. {--[v- The Getstr() string will be filtered according to Tauto ]--}
  42.   autocaps  : Tauto = noauto;
  43. {--[v- if true input will be highlighted according to the const BGCol,
  44.        when using most input routines                                  ]--}
  45.   highlight : boolean = true;
  46. {--[v- These are the allowable exit keys for getstr(): ]--}
  47.   normalexitkeys : tcharset = [#27,#13];    {esc, enter}
  48. {--[v- Extended keys are the ones who send #0 first, then the scancode ]--}
  49.   extendedexitkeys : tcharset = [];
  50.  
  51.   FGCol   : Byte = 15;  {white}       { Fg color for most input routines }
  52.   BGCol   : Byte = 1;   {blue}        { Bg color for most input routines }
  53.  
  54.   DVseg   : word = $B800;  {.$B800=color; $B000 for mono}
  55.   DVofs   : word = $0000;  {the ofs is needed incase i/you create routines
  56.                             that will write to a virtual page, virtual pages
  57.                             will not always start at 0000.}
  58.  
  59. const
  60.   nomemory     = 1;
  61.   filenotfound = 2;
  62.  
  63. procedure terminate(s:string);
  64. {^ Halts the program with the Error String "s". }
  65. function CommaInt(number:longint):string;
  66. {^ Inserts comma's into a number and returns a string of the number with the
  67.    commas. ie: s:=Commint(1000000); (* s='1,000,000' *) Makes Larger numbers
  68.    easier to read. }
  69. function padFstr(s:string; ch:char; len:byte):string;
  70. {^ Pad the front of the string with CH, up to LEN. }
  71. function padEstr(s:string; ch:char; len:byte):string;
  72. {^ Pad the end of the string with CH, up to LEN. }
  73. function istr(n:longint; pad:byte):string;
  74. {^ converts a number to a string.
  75.      pad = how many 0's will be padded in front of the string, to make
  76.            the number a certain length. ie: istr(45,3) = '045'}
  77. function sint(s:string):longint;
  78. {^ converts a string to a number.  if the string is invalid, 0 is returned. }
  79. function CSLen(s:string):byte;
  80. {^ returns the length of the string, not including any of the "Θ" control
  81.    codes. }
  82. function UpChar(Ch:Char):Char;
  83. {^ converts the Char to upper case.  this also supports some foreign chars. }
  84. function LowChar(Ch:Char):Char;
  85. {^ converts the char to lower case.  "     "    "        "   "        ". }
  86. function UpCaseStr(s:string):string;
  87. {^ conerts a string to upper case; uses Upchar. }
  88. function LowCaseStr(s:string):string;
  89. {^ converts a string to lower case; uses Lowchar. }
  90. function SmartCaseStr(s:string):string;
  91. {^ converts a string to a PROPERLY capitalized string.  only useful for
  92.    names.  ie: "jasON moRRisS" = "Jason Morriss". }
  93. procedure hidecursor;
  94. {^ LOCAL ONLY: turns the cursor off; you can't see it on the screen, but its
  95.    still there. }
  96. procedure showcursor;
  97. {^ LOCAL ONLY: turns the cursor on, if it was off. }
  98. {function whereX:byte;
  99. {^ LOCAL ONLY: returns the X position of the cursor.  This is just like TP's
  100.    WhereX, except it is NOT window relitive. }
  101. {function whereY:byte;
  102. {^ LOCAL ONLY: returns the Y position of the cursor.  This is just like TP's
  103.    WhereY, except it is NOT window relitive. }
  104. procedure SetCursorSize(Top,Bot:Byte);
  105. {^ LOCAL ONLY: Set the size of the cursor.  top=top scanline; bot=bottom
  106.    scanline of cursor.  Both in the range of 1..8.  (7,8)="normal" cursor,
  107.    (1,8)=block cursor... }
  108. procedure KillBlanks(var s:string);
  109. {^ Kills ALL blanks in the string. }
  110. procedure KillExtraBlanks(var s:string);
  111. {^ Kills any blanks in FRONT of, and at the END of the string. }
  112. function AreYouSureY : char;
  113. {^ Special procedure.  Displays a colored "[Y,n]" prompt and returns when the
  114.    user presses either: 'Y','N',<enter>.  If <enter> is pressed then 'Y' is
  115.    returned. }
  116. function AreYouSureN : char;
  117. {^ Special procedure.  Displays a colored "[y,N]" prompt and returns when the
  118.    user presses either: 'Y','N',<enter>.  If <enter> is pressed then 'N' is
  119.    returned. }
  120. procedure GetPW(var st:string; len:byte);
  121. {^ Special procedure.  Get a password from the user.  the character echoed
  122.    is in the "secretchar" variable above. }
  123. procedure GetInt(var num:longint; hotkey:boolean; l:longint; h:longint);
  124. {^ Special procedure.  Get a number from the user.  l=lowest # allowed,
  125.    h=highest # allowed.  If hotkey is true then the user will not always
  126.    have to push enter after entering the number.  example:  if you want to
  127.    get a number in the range of 1 to 500 and the user enters 325 then he/she
  128.    won't have to hit enter, it will return the 325, since if the user were to
  129.    enter ANY other number after the 5 (in 325) then the number would be
  130.    larger then the maximum you set of 500.  But if the user enters something
  131.    like 20 then he/she will have to push enter.  otherwise it will wait until
  132.    the user pushes enter, to return the value.  got it?  negitive numbers are
  133.    allowed also. }
  134. function HotKey(CharSet:TCharSet):char;
  135. {^ Special procedure.  Get A char from the user.  CharSet is the set of
  136.    allowable characters to be pressed, any other character not in this
  137.    set is ignored.  As soon as one of the allowed chars is read, it returns
  138.    that char.  This does not echo any characters. }
  139. function GetStr(var DestStr:String; MaxLen:Byte; CharSet:TCharSet):char;
  140. {^ Get a string from the user.  If DestStr is not empty then the user starts
  141.    with that string, and the cursor starts at the end of the string (this
  142.    will write the string to the screen).  MaxLen is the maximum allowed
  143.    length of the string (duh).  CharSet is the set of chars allowed to be
  144.    entered into the string.  Also, look at the front of this unit, there are
  145.    a bunch of other variables that effect the output of this routine.  This
  146.    function returns the char that terminated the function. }
  147. procedure PutStr(S:string);
  148. {^ Powerful writting routine.  Color codes can be put directly into the
  149.    string to change colors easily.  Also there are a few animation Codes
  150.    also, you can easily write your own animation procedures and include them
  151.    also; that ofcourse requires a recompilation.
  152.    The CODE is: "Θ" (alt+233).
  153.    To change colors, the CODE comes first then one of the following chars:
  154.     --------------------------------------------
  155.     0,1,2,3,4,5,6,7,8,9,A,B,C,D,E,F (UPPERCASE!)
  156.     a,b,c,d,e,f,g,h                 (LOWERCASE!)
  157.     [,]
  158.     --------------------------------------------
  159.     The first line has all the values for changing the Foreground color.
  160.       They must be UPPERCASE.  The values are the standard TP set, in
  161.       that:  0=black, 1=blue, 2=green, ..., F (15)=white.
  162.     The second line has all the values for changing the Background color.
  163.       They must be LOWERCASE.  The values here go like: a=black, b=blue,
  164.       c=green, d=cyan, e=red, f=magenta, g=brown, h=lgtgray, the same order
  165.       as TP.
  166.     The third line has the values for turning blinking on/off.
  167.       [=blink on, ]=blink off.
  168.     There are some other codes to know, look in the procedure itself to see
  169.     them... Animation codes start with "Θ|" and then a number for which
  170.     writter (animator) to use.
  171.     ■Remember CAPs DO matter! }
  172. procedure PutStrxy(S:string;x1,y1:byte);
  173. {^ Same as above, except you can change the X,Y position first. }
  174.  
  175. {procedure LocalSetColor(f,b:byte);
  176. {^ LOCAL ONLY: Sets the color to f & b (fore & back). F range: 0..15;
  177.    B range: 0..15; add 128 to turn blinking on, for B: 0..7.  This does not
  178.    get sent to the remote side.  The only procedure that uses the this
  179.    procedure is the "WriteStr()" below. }
  180. procedure WriteStr(x,y:byte; s:string);
  181. {^ LOCAL ONLY: This procedure is like the "PutStr()" procedure except it only
  182.    writes to the LOCAL screen, AND it uses DIRECT Screen writes! (the cursor
  183.    doesn't move)..  Colors can be used, but animation codes can not.  Any
  184.    color changes you make with this will not effect the users color. }
  185.  
  186. {───────────────────────────────────────────────────────────────────────────}
  187.  
  188. IMPLEMENTATION
  189.  
  190. type
  191.   TWriter_Proc = procedure(s:string; var l:byte; f,b:byte);
  192.  
  193. procedure Writer_Nofx(s:string; var l:byte; f,b:byte); far; forward;
  194. procedure Writer_Wipe1(s:string; var l:byte; f,b:byte); far; forward;
  195. {procedure Writer_Wipe2(s:string; var l:byte; f,b:byte); far; forward;}
  196. procedure Writer_fadein(s:string; var l:byte; f,b:byte); far; forward;
  197. procedure Writer_fadeout(s:string; var l:byte; f,b:byte); far; forward;
  198. {^- none of these are ever called directly.  But it wouldn't hurt anything
  199.     if you did. }
  200.  
  201. const
  202.   LocalAttr   : byte = 7;
  203.   Writer_Proc : TWriter_Proc = Writer_Nofx;
  204.  
  205.  
  206. {───────────────────────────────────────────────────────────────────────────}
  207. procedure Terminate(s:string);
  208. begin
  209.   textattr:=7;
  210.   clrscr;
  211.   textattr:=12;
  212.   writeln(s);
  213.   writeln;
  214.   textattr:=7;
  215.   delay(1000);
  216.   halt;
  217. end;
  218. {───────────────────────────────────────────────────────────────────────────}
  219. function CommaInt(number:longint):string;
  220. var
  221.   numstr : string[15];
  222.   len : byte;
  223.   i : byte;
  224. begin
  225.   str(number,numstr);
  226.   len := length(numstr);
  227.   i := len+1;
  228.   while (i>4)and(i<=len+1) do begin
  229.     dec(i,3);
  230.     insert(',',numstr,i);
  231.   end;
  232.   CommaInt := numstr;
  233. end;
  234. {───────────────────────────────────────────────────────────────────────────}
  235. function padEstr(s:string; ch:char; len:byte):string;
  236. var i:byte;
  237. begin
  238.   while length(s)<len do s:=s+ch;
  239.   padEstr:=s;
  240. end;
  241. {───────────────────────────────────────────────────────────────────────────}
  242. function padFstr(s:string; ch:char; len:byte):string;
  243. var i:byte;
  244. begin
  245.   while length(s)<len do s:=ch+s;
  246.   padFstr:=s;
  247. end;
  248. {───────────────────────────────────────────────────────────────────────────}
  249. function istr(n:longint; pad:byte):string;
  250. var
  251.   s:string[20];
  252. begin
  253.   str(n,s);
  254.   while length(s)<pad do insert('0',s,1);
  255.   istr:=s;
  256. end;
  257. {───────────────────────────────────────────────────────────────────────────}
  258. function sint(s:string):longint;
  259. var
  260.   l:longint;
  261.   u:integer;
  262. begin
  263.   val(s,l,u);
  264.   sint:=l;
  265. end;
  266. {───────────────────────────────────────────────────────────────────────────}
  267. function CSLen(s:string):byte;
  268. { Returns the length of a -Color Coded- string EX-Cluding any 'Θ' codes }
  269. var
  270.   slen : byte absolute s;
  271.   i,len: byte;
  272. begin
  273.   len:=0;
  274.   for i := 1 to slen do begin
  275.     if i>length(s) then break;
  276.     if (s[i]='Θ')and(s[i+1]='|')
  277.       then inc(i,2)
  278.       else if S[i]='Θ' then begin
  279.         Inc(i);
  280.         if S[i]='Θ' then inc(len)
  281.       end else inc(len);
  282.   end;
  283.   CSLen:=len;
  284. end;
  285. {───────────────────────────────────────────────────────────────────────────}
  286. Function UpChar(Ch : Char) : Char;
  287. begin
  288.   If Ch In [#97..#122] Then Ch:=chr(byte(ch) and $DF) {Chr(Ord(Ch)-32)}
  289. {    Else If Ch>#90 Then If Ch='' Then Ch:='Æ'{}
  290.     Else if Ch='¢' Then Ch:='¥' Else If Ch='å' Then Ch:='Å'
  291.     Else If Ch='ä' Then Ch:='Ä' Else If Ch='ç' Then Ch:='Ç'
  292.     Else If Ch='é' Then Ch:='É' Else If Ch='ö' Then Ch:='Ö'
  293.     Else If Ch='ñ' Then Ch:='Ñ' Else If Ch='ü' Then Ch:='Ü';
  294.   UpChar:=Ch;
  295. end;
  296. {───────────────────────────────────────────────────────────────────────────}
  297. Function LowChar(Ch : Char) : Char;
  298. begin
  299.   If Ch In [#65..#90] Then Ch:=chr(byte(ch) and $20) {Chr(Ord(Ch)+32)}
  300. {    Else If Ch>#122 Then If Ch='Æ' Then Ch:=' '{}
  301.     Else If Ch='¥' Then Ch:='¢' Else If Ch='Å' Then Ch:='å'
  302.     Else If Ch='Ä' Then Ch:='ä' Else If Ch='Ç' Then Ch:='ç'
  303.     Else If Ch='É' Then Ch:='é' Else If Ch='Ö' Then Ch:='ö'
  304.     Else If Ch='Ñ' Then Ch:='ñ' Else If Ch='Ü' Then Ch:='ü';
  305.   LowChar:=Ch;
  306. end;
  307. {───────────────────────────────────────────────────────────────────────────}
  308. Function UpCaseStr(S : String) : String;
  309. Var
  310.   SLen : Byte Absolute S;
  311.   x    : Integer;
  312. begin
  313.   For x := 1 To SLen Do S[x]:=UpChar(S[x]);
  314.   UpCaseStr := S;
  315. end;
  316. {───────────────────────────────────────────────────────────────────────────}
  317. Function LowCaseStr(S : String) : String;
  318. Var
  319.   SLen : Byte Absolute S;
  320.   i    : Integer;
  321. begin
  322.   For i := 1 To SLen Do S[i]:=LowChar(S[i]);
  323.   LowCaseStr := S;
  324. end;
  325. {───────────────────────────────────────────────────────────────────────────}
  326. Function SmartCaseStr(S : String) : String;
  327. Var
  328.   SLen : Byte Absolute S;
  329.   i    : Integer;
  330. begin
  331.   s:=LowCaseStr(s);
  332.   For i := 1 To SLen Do begin
  333.     If i=1 Then S[1]:=UpChar(S[1])
  334.     Else if S[i-1]=' ' Then S[i]:=UpChar(S[i])
  335.     Else if (Ord(S[i-1]) In [32..64]) And (S[i-1]<>'''')
  336.       Then S[i]:=UpChar(S[i]);
  337.   end;
  338.   SmartCaseStr := S;
  339. end;
  340. {───────────────────────────────────────────────────────────────────────────}
  341. Procedure HideCursor; Assembler;
  342. asm
  343.   mov   ax,0100h
  344.   mov   cx,2607h
  345.   int   10h
  346. end;
  347. {───────────────────────────────────────────────────────────────────────────}
  348. Procedure ShowCursor; Assembler;
  349. asm
  350.   mov   ax,0100h
  351.   mov   cx,0506h
  352.   int   10h
  353. end;
  354. {───────────────────────────────────────────────────────────────────────────}
  355. {function whereX:byte; assembler;
  356. asm
  357.   push  dx
  358.   mov   ah,03h
  359.   mov   bh,0
  360.   int   10h
  361.   mov   al,dl
  362.   inc   al
  363.   pop   dx
  364. end;
  365. {───────────────────────────────────────────────────────────────────────────}
  366. {function whereY:byte; assembler;
  367. asm
  368.   push  dx
  369.   mov   ah,03h
  370.   mov   bh,0
  371.   int   10h
  372.   mov   al,dh
  373.   inc   al
  374.   pop   dx
  375. end;
  376. {───────────────────────────────────────────────────────────────────────────}
  377. Procedure SetCursorSize(Top,Bot:Byte); Assembler;
  378. Asm
  379.   Mov ah,01h
  380.   Mov ch,[Top]
  381.   Mov cl,[Bot]
  382.   Int 10h
  383. End;
  384. {───────────────────────────────────────────────────────────────────────────}
  385. procedure killblanks(var s:string);
  386. {This kills ALL the blanks in the string}
  387. var i:byte;
  388. begin
  389.   i:=1;
  390.   while i<=length(s) do
  391.     if (s[i]=' ') then delete(s,i,1) else inc(i);
  392. end;
  393. {───────────────────────────────────────────────────────────────────────────}
  394. procedure KillExtraBlanks(var s:string);
  395. {This only kills the blanks in front of and at the end of the string}
  396. var i:byte;
  397. begin
  398.   i:=1;
  399.   while (s[i]=' ')and(i<=length(s)) do
  400.     delete(s,i,1);
  401.   i:=length(s);
  402.   while (s[i]=' ')and(i>=1) do begin
  403.     delete(s,i,1);
  404.     dec(i);
  405.   end;
  406. end;
  407. {───────────────────────────────────────────────────────────────────────────}
  408. {───────────────────────────────────────────────────────────────────────────}
  409. function AreYouSureY : char;
  410. var ch:char;
  411. begin
  412.   putstr('ΘaΘ8[Θ3YΘ8,Θ3nΘ8] Θ7ΘΘ ');
  413.   repeat
  414.     ch:=HotKey([#13,'Y','N']);
  415.     if ch=#13 then ch:='Y';
  416.   until ch in [#13,'Y','N'];
  417.   AreYouSureY := ch;
  418. end;
  419. {───────────────────────────────────────────────────────────────────────────}
  420. function AreYouSureN : char;
  421. var ch:char;
  422. begin
  423.   putstr('ΘaΘ8[Θ3yΘ8,Θ3NΘ8] Θ7ΘΘ ');
  424.   repeat
  425.     ch:=HotKey([#13,'Y','N']);
  426.     if ch=#13 then ch:='N';
  427.   until ch in [#13,'Y','N'];
  428.   AreYouSureN := ch;
  429. end;
  430. {───────────────────────────────────────────────────────────────────────────}
  431. procedure GetPW(var st:string; len:byte);
  432. const
  433.   PWset : tcharset = [#0..#31,#33..#58,#60..#232,#234..#255];
  434. var
  435.   oldsec  : boolean;
  436.   oldauto : tauto;
  437.   x,y     : byte;
  438. begin
  439.   oldauto:=autocaps;
  440.   autocaps:=upper;
  441.   oldsec:=secret;
  442.   secret:=true;
  443.   x:=wherex; y:=wherey;
  444.   repeat
  445.     siogotoxy(x,y);
  446.     GetStr(st,len,PWset);
  447.   until st<>'';
  448.   secret:=oldsec;
  449.   autocaps:=oldauto;
  450. end;
  451. {───────────────────────────────────────────────────────────────────────────}
  452. procedure GetInt;
  453. var
  454.   done:boolean;
  455.   c:integer;
  456.   st:string[15];
  457.   v:longint;
  458.   ch:char;
  459. begin
  460.   done:=false;
  461.   st:='';
  462.   repeat
  463.     ch:=sioreadkey; if ch=#0 then ch:=sioreadkey;
  464.     case ch of
  465.       '0'..'9' : if (length(st)<12)and(sint(st+ch)<=h)and(sint(st+ch)>=l) then begin
  466.         if (ch='0') then begin
  467.           if (st<>'-')and(st<>'') then begin
  468.             insert(ch,st,length(st)+1);
  469.             siowritec(ch);
  470.           end;
  471.         end else begin
  472.           insert(ch,st,length(st)+1); {1..9}
  473.           siowritec(ch);
  474.         end;
  475.       end;
  476.       '-' : if (l<0)and(st='') then begin
  477.         siowritec('-');
  478.         st:='-';
  479.       end;
  480.       #8  : if st<>'' then begin
  481.         siowrite(#8' '#8);
  482.         delete(st,length(st),1);
  483.       end;
  484.       #13 : done:=true;
  485.     end;
  486.  
  487.     val(st,v,c);
  488.     if (hotkey)and(sint(st+'0')>h) then done:=true;
  489.  
  490.   until done;
  491.   num:=v;
  492. end;
  493. {───────────────────────────────────────────────────────────────────────────}
  494. function HotKey(CharSet : TCharSet) : char;
  495. var
  496.   ch:char;
  497. begin
  498.   if CharSet=[] then begin HotKey:=#255; exit; end;
  499.   if highlight then putstr('Θb Θa'#8);
  500.   repeat
  501.     ch:=upchar(sioReadkey);
  502.   until ch in CharSet;
  503.   HotKey:=ch;
  504. end;
  505. {───────────────────────────────────────────────────────────────────────────}
  506. function GetStr( Var DestStr  : String;                   {Self explanitory}
  507.                      MaxLen   : Byte;                     {Ditto.. .  .    }
  508.                      CharSet  : TCharSet )    {Set of allowable input chars}
  509.                      : char;                      {returns char that exited}
  510. Var
  511.   StrSize : Byte;
  512.   SPos : Byte;
  513.   Extended : Boolean;
  514.  {------------------------------------------------------------------------}
  515.   Function GetKeyPress : Char;
  516.   Var ch:Char;
  517.   Begin
  518.     Extended:=False;
  519.     ch:=sioreadkey;
  520.     case autocaps of
  521.       noauto: ;
  522.       upper: ch:=UpChar(ch);
  523.       lower: ch:=LowChar(ch);
  524.       smart: begin
  525.         ch:=LowChar(ch);
  526.         If SPos=1 Then ch:=UpChar(ch)
  527.         Else if DestStr[SPos-1]=' ' Then ch:=UpChar(ch)
  528.         Else if (Ord(DestStr[Spos-1]) In [32..64])And(DestStr[Spos-1]<>'''')
  529.         Then ch:=UpChar(ch);
  530.       end;
  531.     end; {case autocaps}
  532.     {If (Ch=#0)or((ch='[')and(Skeypressed)) Then Begin
  533.       Extended:=True; Sread_char(ch);
  534.     End;}
  535.     GetKeyPress:=ch;
  536.   End;
  537.  {------------------------------------------------------------------------}
  538.   Procedure DelEndBlank;
  539.   Begin
  540.     If DestStr[StrSize] = #32 Then Begin
  541.       Delete(DestStr,StrSize,1);
  542.       Dec(StrSize);
  543.     End;
  544.   End;
  545.  {------------------------------------------------------------------------}
  546. Const
  547.   Right = #77; {0,M}  {Move cursor right}        {these cannot be used!}
  548.   Left  = #75; {0,K}  {Move cursor left}         {these cannot be used!}
  549.   Del   = #83; {0,S}  {Delete character}         {these cannot be used!}
  550.   Ins   = #82; {0,R}  {Insert on/off}            {these cannot be used!}
  551.   HomeK = #71; {0,G}  {Goto begining of string}  {these cannot be used!}
  552.   EndK  = #79; {0,O}  {Goto end of string}       {these cannot be used!}
  553.   CtrlX = #24; {}     {Erase entire line, start over}             {done}
  554.   Esc   = #27; {}     {Exit with no changes to DestStr}           {done}
  555.   BS    = #08; {}     {Destructive BackSpace}                     {done}
  556.   Codes : Set of Char = [CtrlX,Esc,BS]; { these would literally print out
  557.                                           if not in this set. }
  558. Var
  559.   OverWrite : Boolean; {insert on/off}
  560.   X,Y    : Byte;
  561.   Xmin   : Byte;
  562.   Xmax   : Byte;
  563.   i      : Byte;
  564.   Ch     : Char;
  565.   OldStr : String;
  566.   oldcol : byte;
  567. Label
  568.   Start;
  569. Begin
  570.   If (MaxLen<1) Then Exit;
  571.   OldStr:=DestStr;
  572.   oldcol:=textattr;
  573.   OverWrite:=False;
  574.   Xmin:=WhereX;
  575.   Xmax:=MaxLen+Xmin-1;
  576.   X:=Xmin;
  577.   Y:=WhereY;
  578.   StrSize:=Length(DestStr);
  579.   SPos:=StrSize+1;
  580.   If (Xmax>80) Then Begin
  581.     Xmax := 80;
  582.     MaxLen := Xmax-(StrSize+Xmin-1);   { Must adjust if it will excede Xmax }
  583.   End;
  584.   if SPos-1 > maxlen then SPos:= maxlen;
  585.   while length(deststr) > maxlen do  {if str>maxlen then delete ending chars}
  586.     delete(deststr,length(deststr),1);
  587.   strsize:=length(deststr); {get new len (incase the above was true)}
  588.   if door.USEcolor then SetColor(FGCol,BGCol);  {Set the colors}
  589.   if highlight then begin
  590.     case secret of
  591.       false : sioWrite(DestStr);
  592.       true  : for i := 1 to length(deststr) do siowritec(secretchar);
  593.     end;
  594.     For i:=Xmin+length(deststr)-1 to Xmax-1 Do siowritec(' ');
  595.   end;
  596.   siogotoxy(Xmin+SPos-1,Y);
  597.   X:=X+SPos-1;
  598.   {Gotoxy(X,Y);}
  599.   if inserton then begin
  600.     setcursorsize(1,8);
  601.     overwrite:=true;
  602.   end
  603.   else SetCursorSize(7,8);
  604.  {----------------------------}
  605.   Repeat
  606.     Ch:=GetKeyPress;
  607. start:
  608.     If Extended Then
  609.       Case Ch of
  610.         Ins   : Begin
  611.           OverWrite:= Not Overwrite;
  612.           case overwrite of
  613.             false : SetCursorSize(7,8); {this ofcourse, is only seen locally}
  614.             true  : SetCursorSize(1,8);
  615.           end;
  616.         end;
  617.         HomeK : Begin
  618.           SPos:=1;
  619.           X:=Xmin;
  620.           While DestStr[StrSize] = #32 Do DelEndBlank;
  621.           siogotoxy(X,Y);
  622.         End;
  623.         EndK  : Begin
  624.           SPos:=StrSize+1;
  625.           X:=StrSize+Xmin;
  626.           If (StrSize=MaxLen) Then Begin Dec(X); Dec(SPos) End;
  627.           siogotoxy(X,Y);
  628.         End;
  629.         Right : If (X<Xmax)and(SPos<StrSize+1) Then Begin
  630.           Inc(SPos);
  631.           Inc(X);
  632.           siogotoxy(X,Y);
  633.         End;
  634.         Left  : If (X>Xmin)and(SPos>0) Then Begin
  635.           Dec(SPos);
  636.           Dec(X);
  637.           siogotoxy(X,Y);
  638.           DelEndBlank;
  639.           If (StrSize=1)and(DestStr[SPos]=#32)and(SPos=1) Then DelEndBlank;
  640.         End;
  641.         Del   : If (StrSize>0)and(SPos<=StrSize) Then Begin
  642.           Delete(DestStr,SPos,1);
  643.           Dec(StrSize);
  644.           For i := SPos to StrSize+1 Do siowrite(DestStr[i]);
  645.           siowrite(' ');
  646.         End;
  647.       End {Of Case}
  648.  
  649.     Else If (Ch in CharSet)and not(Ch in Codes)and
  650.               not(ch in normalexitkeys)and(X-1<Xmax) Then Begin
  651.       Case OverWrite of
  652.         False : If (StrSize<MaxLen) Then Begin    {Chars will be moved right}
  653.           Insert(Ch,DestStr,SPos);
  654.           case secret of
  655.             false : siowritec(Ch);
  656.             true  : siowritec(secretchar);
  657.           end;
  658.           Inc(StrSize);
  659.           Inc(SPos);
  660.           Inc(X);
  661.           If SPos-1<StrSize Then
  662.             For i := SPos to StrSize Do siowritec(DestStr[i]);
  663.         End;
  664.         True  : Begin                             {Chars will be overwritten}
  665.           If SPos<=StrSize Then Delete(DestStr,SPos,1);
  666.           Insert(Ch,DestStr,SPos);
  667.           case secret of
  668.             false : siowritec(Ch);
  669.             true  : siowritec(secretchar);
  670.           end;
  671.           If (SPos-1=StrSize)and(StrSize<MaxLen) Then Inc(StrSize);
  672.           If (X<Xmax) Then Begin Inc(SPos); Inc(X); siogotoxy(X,Y) End;
  673.         End;
  674.       End; {Of Case}
  675.     End {Else..If}
  676.     Else
  677.       Case Ch of
  678.         CtrlX : Begin
  679.           X:=Xmin;
  680.           StrSize:=0;
  681.           SPos:=1;
  682.           siogotoxy(X,Y);
  683.           For i := Xmin to Xmin+Length(DestStr) Do
  684.             siowritec(' ');
  685.             {DVWrite(i,Y,' ',BGCol,FGCol,0);}
  686.           DestStr:='';
  687.           siogotoxy(X,Y);
  688.         End;
  689.         BS    : If (X>Xmin)and(Spos>0) Then Begin
  690.           Delete(DestStr,SPos-1,1);
  691.           Dec(SPos);
  692.           Dec(StrSize);
  693.           Dec(X);
  694.           siowrite(#8' '#8);
  695.         End;
  696.       End; {Of Case}
  697.   Until (Ch in normalexitkeys) or ((extended)and(ch in extendedexitkeys));
  698.  {----------------------------}
  699.   While DestStr[StrSize] = #32 Do DelEndBlank;
  700.   If Ch = Esc Then DestStr := OldStr;
  701.   KillExtraBlanks(DestStr);
  702. {  Sgotoxy(Xmin,Y);
  703.   PutStr(DestStr);
  704.   for i := Xmin+Length(DestStr)-1 to XMax-1 do Swrite(' ');}
  705.   getstr:=ch;
  706.   SetCursorSize(7,8);
  707.   if door.USEcolor then textattr:=oldcol;
  708. End;
  709. {───────────────────────────────────────────────────────────────────────────}
  710. procedure writer_nofx(s:string; var l:byte; f,b:byte);
  711. begin
  712.   siowritec(s[l]);
  713. end;
  714. {───────────────────────────────────────────────────────────────────────────}
  715. procedure writer_fadein(s:string; var l:byte; f,b:byte);
  716. const
  717.   fc : array[9..15] of record a,b,c : byte; end =
  718.          ( (a:08;b:01;c:09),(a:08;b:02;c:10),(a:08;b:03;c:11),
  719.            (a:08;b:04;c:12),(a:08;b:05;c:13),(a:08;b:06;c:14),
  720.            (a:08;b:07;c:15) );
  721.  
  722. var
  723.   j,x,y : byte;
  724.   s2    : string;
  725. begin
  726.   j:=1; s2:='';
  727.   while (s[l]<>#233)and(l<=length(s)) do begin
  728.     insert(s[l],s2,j);
  729.     inc(l); inc(j);
  730.   end; if l>0 then dec(l);
  731.   if f>8 then begin
  732.     x:=wherex; y:=wherey;
  733.     textcolor(fc[f].a); siowrite(s2);
  734.     siogotoxy(x,y);
  735.     delay(dlay[writer]);
  736.     textcolor(fc[f].b); siowrite(s2); siogotoxy(x,y); delay(dlay[writer]);
  737.     textcolor(fc[f].c); siowrite(s2);
  738.     if door.USEcolor then textattr:=f+(b*16);
  739.   end else siowrite(s2);
  740. end;
  741. {───────────────────────────────────────────────────────────────────────────}
  742. procedure writer_fadeout(s:string; var l:byte; f,b:byte);
  743. const
  744.   fc : array[9..15] of record a,b,c : byte; end =
  745.          ( (a:09;b:01;c:08),(a:10;b:02;c:08),(a:11;b:03;c:08),
  746.            (a:12;b:04;c:08),(a:13;b:05;c:08),(a:14;b:06;c:08),
  747.            (a:15;b:07;c:08) );
  748.  
  749. var
  750.   j,x,y : byte;
  751.   s2    : string;
  752. begin
  753.   j:=1; s2:='';
  754.   while (s[l]<>#233)and(l<=length(s)) do begin
  755.     insert(s[l],s2,j);
  756.     inc(l); inc(j);
  757.   end; if l>0 then dec(l);
  758.   if f>8 then begin
  759.     x:=wherex; y:=wherey;
  760.     textcolor(fc[f].a); siowrite(s2); siogotoxy(x,y); delay(dlay[writer]);
  761.     textcolor(fc[f].b); siowrite(s2); siogotoxy(x,y); delay(dlay[writer]);
  762.     textcolor(fc[f].c); siowrite(s2); siogotoxy(x,y); delay(dlay[writer]);
  763.     textcolor(0);       siowrite(s2);
  764.     if door.USEcolor then textattr:=f+(b*16);
  765.   end else siowrite(s2);
  766. end;
  767. {───────────────────────────────────────────────────────────────────────────}
  768. procedure writer_wipe1(s:string; var l:byte; f,b:byte);
  769. const
  770.   wipech : array[1..2] of char = '▌▐';
  771. var
  772.   w:byte;
  773. begin
  774.   if door.USEcolor then setcolor(15,0);
  775.   for w:=1 to 2 do siowrite(wipech[w]+#8);
  776.   delay(dlay[writer]);
  777.   if door.USEcolor then setcolor(F,B);
  778.   siowritec(s[l]);
  779. end;
  780. {───────────────────────────────────────────────────────────────────────────}
  781. procedure writer_wipe2(s:string; var l:byte; f,b:byte); far;
  782. const
  783.   wipech : array[1..2] of char = '▌▐';
  784. var
  785.   w:byte;
  786. begin
  787.   {not finished}
  788. {  if door.USEcolor then setcolor(15,0);
  789.   for w:=1 to 2 do siowrite(wipech[w]+#8);
  790.   delay(dlay[writer]);
  791.   if door.USEcolor then setcolor(F,B);
  792.   siowrite(s[l]);}
  793. end;
  794. {───────────────────────────────────────────────────────────────────────────}
  795. procedure PutStr(S:string);
  796. label writeit;
  797. const
  798.   Fg : byte = 7;
  799.   Bg : byte = 0;
  800.   Blk: byte = 0;
  801.   savedattr : byte = 7;
  802. var
  803.   I : byte;
  804.   C : char;
  805.  
  806. begin
  807.   for I := 1 to Length(S) do Begin
  808.     if I>length(S) Then Exit;
  809.     C:=S[I];
  810.     if C=#233 then Begin
  811.       Inc(I); C:=S[I];
  812.       if (door.USEcolor)and(C in ['0'..'9','A'..'F','a'..'h','[',']']) then case C of
  813.         '0' : textcolor(0);
  814.         '1' : textcolor(1);
  815.         '2' : textcolor(2);
  816.         '3' : textcolor(3);
  817.         '4' : textcolor(4);
  818.         '5' : textcolor(5);
  819.         '6' : textcolor(6);
  820.         '7' : textcolor(7);
  821.         '8' : textcolor(8);
  822.         '9' : textcolor(9);
  823.         'A' : textcolor(10);
  824.         'B' : textcolor(11);
  825.         'C' : textcolor(12);
  826.         'D' : textcolor(13);
  827.         'E' : textcolor(14);
  828.         'F' : textcolor(15);
  829.         'a' : textbackground(0);
  830.         'b' : textbackground(1);
  831.         'c' : textbackground(2);
  832.         'd' : textbackground(3);
  833.         'e' : textbackground(4);
  834.         'f' : textbackground(5);
  835.         'g' : textbackground(6);
  836.         'h' : textbackground(7);
  837.         '[' : textattr:=textattr or 128;
  838.         ']' : textattr:=textattr and 127;
  839.       end else case c of
  840. {        '@' : Pause_Proc(pausestr);{}
  841.         '.' : begin
  842.           siowriteln('');
  843. {          if morechk then begin
  844.             inc(curlinenum);
  845.             if curlinenum>=24 then begin
  846.               Pause_Proc(pausestr);
  847.               curlinenum:=1;
  848.             end;
  849.           end;}
  850.         end;
  851.         's' : savedattr:=textattr;   {save current color}
  852.         'r' : textattr:=savedattr;   {restore saved color}
  853.         '>' : siocursorright(1);
  854.         '<' : siocursorleft(1);
  855.         '!' : siowritec(#7);
  856.         '*' : sioclrscr;
  857.         '-' : sioclrEol;
  858.         'Θ' : goto writeit;   {so you can write an actual control code}
  859.         '|' : begin
  860.                 inc(I);
  861.                 if ord(s[I])-48 in [ord(low(twriter))..ord(high(twriter))]
  862.                   then writer:=twriter(ord(s[I])-48) else dec(I);
  863.                 case door.USEani of
  864.                   true : case writer of
  865.                     nofx    : Writer_Proc:=Writer_Nofx;
  866.                     wipe1   : Writer_Proc:=Writer_Wipe1;
  867.                     {wipe2   : ;}
  868.                     fadein  : if door.USEcolor
  869.                       then Writer_Proc:=Writer_fadein
  870.                       else Writer_Proc:=Writer_Nofx;
  871.                     fadeout : if door.USEcolor
  872.                       then Writer_Proc:=Writer_fadeout
  873.                       else Writer_Proc:=Writer_Nofx;
  874.                   end;
  875.                   false : Writer_Proc:=Writer_Nofx;
  876.                 end;
  877.               end; {'|'}
  878.       end; { CASE }
  879.     end else begin
  880. writeit: {label}
  881.       fg:=textattr mod 16;
  882.       bg:=textattr shr 4;
  883.       Writer_Proc(S,i,fg,bg);
  884.     end;
  885.   end;
  886. end;
  887. {───────────────────────────────────────────────────────────────────────────}
  888. procedure PutStrxy(S:string; x1,y1:byte);
  889. begin
  890.   siogotoxy(x1,y1);
  891.   putstr(S);
  892. end;
  893. {───────────────────────────────────────────────────────────────────────────}
  894. procedure LocalSetColor(f,b:byte);
  895. begin
  896.   LocalAttr:=f+(b*16);
  897. end;
  898. {───────────────────────────────────────────────────────────────────────────}
  899. procedure DVWRITE(x,y:word;attr:byte; s:string); assembler;
  900. {x,y are 1 based; not 0 zero based}
  901. asm
  902.   push ds
  903.   mov bx,[y]
  904.   dec bx
  905.   shl bx,1
  906.   mov ax,bx
  907. {$ifopt G+}
  908.   shl bx,2
  909. {$else}
  910.   shl bx,1
  911.   shl bx,1
  912. {$endif}
  913.   add ax,bx
  914.   add ax,[DVseg]
  915.   mov es,ax
  916.   mov di,[x]
  917.   dec di
  918.   shl di,1
  919.   add di,[DVofs]
  920.  
  921.   lds si,s
  922.   mov cl,byte ptr [si]
  923.   inc si
  924.   mov ah,attr
  925. @1:
  926.   mov al,byte ptr [si]
  927.   mov word ptr es:[di],ax
  928.   inc si
  929.   add di,2
  930.   dec cl
  931.   jnz @1
  932.   pop ds
  933. end;
  934. {───────────────────────────────────────────────────────────────────────────}
  935. procedure WriteStr;
  936. label writeit;
  937. const
  938.   Fg : byte = 7;
  939.   Bg : byte = 0;
  940.   Blk: byte = 0;
  941. var
  942.   I,plus : byte;
  943.   C : char;
  944.  
  945. begin
  946.   plus:=0;
  947.   for I := 1 to Length(S) do Begin
  948.     if I>length(S) Then Exit;
  949.     C:=S[I];
  950.     if C=#233 then Begin
  951.       Inc(I); C:=S[I];
  952.       if (C in ['0'..'9','A'..'F','a'..'h','[',']']) then case C of
  953.         '0' : localattr:=0  or (localattr and $F0);
  954.         '1' : localattr:=1  or (localattr and $F0);
  955.         '2' : localattr:=2  or (localattr and $F0);
  956.         '3' : localattr:=3  or (localattr and $F0);
  957.         '4' : localattr:=4  or (localattr and $F0);
  958.         '5' : localattr:=5  or (localattr and $F0);
  959.         '6' : localattr:=6  or (localattr and $F0);
  960.         '7' : localattr:=7  or (localattr and $F0);
  961.         '8' : localattr:=8  or (localattr and $F0);
  962.         '9' : localattr:=9  or (localattr and $F0);
  963.         'A' : localattr:=10 or (localattr and $F0);
  964.         'B' : localattr:=11 or (localattr and $F0);
  965.         'C' : localattr:=12 or (localattr and $F0);
  966.         'D' : localattr:=13 or (localattr and $F0);
  967.         'E' : localattr:=14 or (localattr and $F0);
  968.         'F' : localattr:=15 or (localattr and $F0);
  969.         'a' : localattr:=(0 shl 4) or (localattr and $0F);
  970.         'b' : localattr:=(1 shl 4) or (localattr and $0F);
  971.         'c' : localattr:=(2 shl 4) or (localattr and $0F);
  972.         'd' : localattr:=(3 shl 4) or (localattr and $0F);
  973.         'e' : localattr:=(4 shl 4) or (localattr and $0F);
  974.         'f' : localattr:=(5 shl 4) or (localattr and $0F);
  975.         'g' : localattr:=(6 shl 4) or (localattr and $0F);
  976.         'h' : localattr:=(7 shl 4) or (localattr and $0F);
  977.         '[' : localattr:=localattr or 128;
  978.         ']' : localattr:=localattr and 127;
  979.       end else case c of
  980.         '>' : inc(y);                  {crlf}
  981.         '<' : if x>1 then dec(x);      {backspace}
  982.         '!' : write(#7);               {bell}
  983. {        '*' : clrscr;}
  984.         '-' : ClrEol;
  985.         'Θ' : goto writeit;   {so you can write an actual control code}
  986.       end; { CASE }
  987.     end else begin
  988. writeit: {label}
  989.       DVwrite(x+plus,y,localattr,C);
  990.       inc(plus);
  991.     end;
  992.   end;
  993. end;
  994. {───────────────────────────────────────────────────────────────────────────}
  995.  
  996. end.