home *** CD-ROM | disk | FTP | other *** search
/ The World of Computer Software / World_Of_Computer_Software-02-386-Vol-2of3.iso / c / ctkit11.zip / BBSENDU.PAS < prev    next >
Pascal/Delphi Source File  |  1991-12-15  |  24KB  |  1,148 lines
  1. Unit BBSEndU;
  2.  
  3. interface
  4.  
  5. uses
  6.    Async2, dos, crt, ctgraph,ctu, graph;
  7.  
  8. const
  9.   Version = '0.0';
  10.   Rev = 'A';      {revision code, for compatibility checking}
  11.   Esc = #27;
  12.   EndChar = #255;
  13.   OK = #1;
  14.   NOTOK = #2;
  15.   NulCh = #0;
  16.   AltX = Chr(45);
  17.   AltC = Chr(46);
  18.   AltF = Chr(33);
  19.   Alpha = ['A'..'Z','0'..'9','a'..'z','.',':'];
  20.   InitCode = Esc+#236;
  21.  
  22. var
  23.    f: text;
  24.    ComStr: string;
  25.    lastpress, TrueUK, Tlim: longint;
  26.    lastd, WaitMin, BaudRate, ComPort, FillPat, FillCol, UserNum: word;
  27.    stringing, SysAllowed, ModemOn, Local, DoTimeCheck, CTOn, SoundOn: boolean;
  28.    StrungStr, PName, BBSName, DataDir: string;
  29.    TrueSL, BkCol, FgCol: byte;
  30.    TrueGold: real;
  31.    DLim: word;
  32.  
  33. Function KeyPressed: boolean;
  34. Function KeyCheck: boolean;
  35. Procedure MakeTime (var T: longint; var D: word);
  36. Procedure SendStr(s: string);
  37. Procedure SendLine(s: string);
  38. Procedure ExitProg;
  39. Function WaitForChar: char;
  40. Procedure RdLn (var s; l: byte);
  41. Procedure Initialize;
  42. Procedure SendCommand (R: byte; ComStr, ExStr: string);
  43. Procedure PutPic(num: byte; x, y: word; how: byte);
  44. Procedure LoadPic(num: byte; place, length: word; fn: string);
  45. Procedure DoText(x, y: word; tx: string);
  46. Procedure GrInfo(var gd, gm: word);
  47. Procedure InitGr(d, m: word);
  48. Procedure ScreenPage (apage, vpage: byte);
  49. Procedure DoLine (x1, y1, x2, y2: word; color: byte);
  50. Procedure DoCircle (x, y, rad: word; color: byte);
  51. Procedure DoRect (x1, y1, x2, y2: word; color: byte);
  52. Function TestResp: boolean;
  53. Function MemFree: longint;
  54. Procedure LeaveCT;
  55. Procedure ClearScr;
  56. Procedure SetCol (fore, back: byte);
  57. Procedure InLineXY (len: byte; x, y: word; var thestring: string);
  58. Procedure FillStyle (pattern, color: word);
  59. Procedure GetPic (num: byte; x1, y1, x2, y2: word);
  60. Procedure DefSeries (Ser, Step, Command, ExNum: byte; StrStr: string);
  61. Procedure DoSeries (Ser: byte);
  62. Procedure DefExStr (num: byte; exstr: string);
  63. Procedure SetGD(gd: byte);
  64. Procedure LoadSong (SongNum: byte; Place: word; FN: string);
  65. Procedure DoSong (SongNum: byte);
  66. Procedure DefAnim (Flm, Frame, PicN: byte; pause, x, y: word; Way: byte);
  67. Procedure ShowAnim (Flm: byte; AuxX, AuxY: word);
  68. Procedure TextStyle (Size, font: word);
  69. Procedure FillCircle (x, y, rad: word);
  70. Procedure FillBar (x1, y1, x2, y2: word);
  71. Procedure FillFlood (x, y: word; BorderCol: byte);
  72. Procedure DefNote (Song, Note, l, n, o: byte);
  73. Procedure ChPalette(ColorNum: word; Color: shortint);
  74. Procedure DoArc (x, y, stangle, endangle, rad: word);
  75. Procedure VirtWind (x1, y1, x2, y2: word; Clip: boolean);
  76. Procedure HighLight (x1, y1, x2, y2: word);
  77. Procedure UnHighLight;
  78. Procedure DefScroll (x1, y1, x2, y2, scramt: word);
  79. Procedure ScrollUp;
  80. Procedure ScrollDown;
  81. Procedure SetFg (fore: byte);
  82.  
  83. { To do:
  84.   ???
  85.  
  86. }
  87.  
  88. implementation
  89.  
  90. const
  91.    maxmemused = 31043;
  92.  
  93. type
  94.    Images = array[1..MaxMemUsed] of word;
  95.    ColType = Array [0..3] of boolean;
  96.    CDType = array[1..2] of integer;
  97.    TPicType = array[1..15000] of word;
  98.    SeriesType = record
  99.       r, ExNum: byte;
  100.       ComStr: string[10];
  101.       end;
  102.    AnimType = record
  103.       PicN, Way: byte;
  104.       x, y, pause: word;
  105.       end;
  106.  
  107. var
  108.    sysoff, SpaceP: boolean;
  109.    x1, y1, x2, y2, ndex: word;
  110.    MemUsed: longint;
  111.    CurCom, Bad: byte;
  112.    PicFile: file;
  113.    t1, t2, SysEnd: byte;
  114.    redstr: string;
  115.    Memty: longint;
  116.  
  117. Function Keypressed: boolean;
  118.  
  119. var
  120.    regs: registers;
  121.  
  122. begin
  123. Regs.AH := $0B;
  124. Intr($21,Regs);
  125. keypressed := (Regs.AL = 255);
  126. end;
  127.  
  128. Function KeyCheck: boolean;
  129.  
  130. begin
  131. KeyCheck := ((modemOn) and (Async_Buffer_Check)) or ((KeyPressed) and (Not sysoff) and (SysAllowed));
  132. end;
  133.  
  134. Procedure MakeTime (var T: longint; var D: word);
  135.  
  136. var
  137.    s1, s2, hh, mm: word;
  138.  
  139. begin
  140. GetDate (s1,s2,hh,D);
  141. GetTime (hh,mm,s1,s2);
  142. T := mm+hh*60+D*60*24;
  143. end;
  144.  
  145. Procedure SendStr(s: string);
  146.  
  147. var
  148.    X: byte;
  149.  
  150. begin
  151. if sysallowed then
  152.    begin
  153.    if grmode then
  154.       begin
  155.       for x := 1 to length(s) do
  156.          if s[x] = #8 then
  157.             begin
  158.             MoveTo(GetX-TextWidth('X'),GetY);
  159.             SetFillStyle (1,Fill2);
  160.             Bar (GetX,GetY,GetX+TextWidth('X'),GetY+TextHeight('X'));
  161.             SetFillStyle (Fill1,Fill2);
  162.             end else begin
  163.             OutText(s[x]);
  164.             end;
  165.       end else
  166.       Write (s);
  167.    end;
  168. if modemon then
  169.    for x := 1 to Length(s) do
  170.       Async_send(s[x]);
  171. end;
  172.  
  173. Procedure SendLine(s: string);
  174.  
  175. var
  176.    X: byte;
  177.  
  178. begin
  179. SendStr(s);
  180. if modemon then
  181.    begin
  182.    Async_send(^M);
  183.    Async_Send(#10);
  184.    end;
  185. if SysAllowed then
  186.    begin
  187.    if grmode then
  188.       MoveTo (0,Gety+textHeight('X')+2)
  189.       else
  190.       Writeln;
  191.    end;
  192. end;
  193.  
  194. Procedure ExitProg;
  195.  
  196. begin
  197. Async_Close;
  198. halt;
  199. end;
  200.  
  201. FUNCTION WaitForChar : CHAR;
  202.  
  203. VAR
  204.    CurD: WORD;
  205.    CurT: longint;
  206.    ch, tc: char;
  207.    tb, FunkyLocal, KeyLocal: boolean;
  208.  
  209. BEGIN
  210. maketime (LastPress, LastD);
  211. REPEAT
  212.    maketime (curt, curd);
  213.    if (modemon) and (SysEnd > 0) and (KeyPressed) then
  214.       begin
  215.       if not(async_buffer_check) then
  216.          Async_Send(ReadKey);
  217.       if sysend = 1 then
  218.          SysEnd := 0;
  219.       end;
  220.    if ((CurD >= LastD) and (CurT > LastPress + WaitMin + 1)) or
  221.     (DoTimeCheck and (CurT > TLim+WaitMin) and (CurD >= DLim)) then
  222.       begin
  223.       DoCode (5,#0+#0,'');
  224.       SendLine ('Out of time.  Aborting program.');
  225.       ExitProg;
  226.       end;
  227.    if (modemon) and (not async_carrierdetect) then
  228.       begin
  229.       Writeln ('NO CARRIER');
  230.       Writeln ('Aborting...');
  231.       halt;
  232.       end;
  233.    if (sysoff or (Not SysAllowed)) and (KeyPressed) and (readkey=#0) and (readkey='D') then
  234.       begin
  235.       DoCode (5,#0+#0,'');
  236.       SendLine ('Sysop aborted.  Sorry.');
  237.       ExitProg;
  238.       end;
  239.    until KeyCheck;
  240. IF (modemon) and (Async_Buffer_Check) THEN
  241.    begin
  242.    Local := false;
  243.    WaitForChar := Async_Read;
  244.    end ELSE begin
  245.    local := true;
  246.    ch := ReadKey;
  247.    if (ch = #0) then
  248.       begin
  249.       tc := readkey;
  250.       case tc of
  251.          'D': begin
  252.             DoCode (5,#0+#0,'');
  253.             SendLine ('Sysop aborted.  Sorry.');
  254.             ExitProg;
  255.             end;
  256.          #71: tc := '7';
  257.          #72: tc := '8';
  258.          #73: tc := '9';
  259.          #75: tc := '4';
  260.          #77: tc := '6';
  261.          #79: tc := '1';
  262.          #80: tc := '2';
  263.          #81: tc := '3';
  264.          end;
  265.       WaitForChar := tc;
  266.       end else
  267.       WaitForChar := ch;
  268.    end;
  269. END;
  270.  
  271. Procedure Rdln (var s; l: byte);
  272.  
  273. var
  274.    x, kp: integer;
  275.    ch: char;
  276.    ts: string;
  277.  
  278. begin
  279. kp := 0;
  280. ts := '';
  281. repeat
  282.    ch := WaitForChar;
  283.    if (ch = #8) and (kp > 0) then
  284.       begin
  285.       SendStr (#8+' '+#8);
  286.       dec(ts[0]);
  287.       Dec (kp);
  288.       end;
  289.    if (ch > #31) and (kp < L) then
  290.       begin
  291.       tS := ts + ch;
  292.       inc(kp);
  293.       SendStr (ch);
  294.       end;
  295.    until ch = #13;
  296. SendLine ('');
  297. move (ts, s, kp+1);
  298. end;
  299.  
  300. Procedure Initialize;
  301.  
  302. const
  303.    BSet: set of byte = [3,6,12,24,48,96,192];
  304.  
  305. var
  306.    ch: char;
  307.    s, ts: string;
  308.    ts2: string[12];
  309.    BStr, CStr: string[30];
  310.    cnt, x, y: word;
  311.    f: text;
  312.    f2: file;
  313.    found: boolean;
  314.  
  315. begin
  316. TrueGold := 0;
  317. TrueSL := 0;
  318. TrueUK := 0;
  319. UserNum := 0;
  320. s := ParamStr(1);
  321. if Paramcount = 0 then
  322.    s := '/L';
  323. if (s='/l') or (s='/L') then
  324.    begin
  325.    ModemOn := False;
  326.    SendLine ('Playing local mode.');
  327.    SendStr ('Enter name: ');
  328.    RdLn(PName,30);
  329.    exit;
  330.    end;
  331. Assign (f, s);
  332. {$I-}
  333. reset(f);
  334. {$I+}
  335. If IOResult <> 0 then
  336.    begin
  337.    Writeln ('Chain file not found!');   {Got to do something about non-WWIV!}
  338.    Halt;
  339.    end;
  340.  
  341. {Dif chain files....}
  342. ts := '';
  343. x := Length(S);
  344. repeat
  345.    tS := ConCat(UpCase(s[x]),ts);
  346.    dec(x);
  347.    until (x=0) or (s[x]='\');
  348.  
  349. found := false;
  350. if ts = 'DOOR.SYS' then
  351.    begin
  352.    found := true;
  353.    Readln (f,CStr);
  354.    Readln (f,BStr);
  355.    for x := 3 to 9 do
  356.       Readln (f);
  357.    Readln (f,PName);
  358.    end;
  359. if ts = 'CALLINFO.BBS' then
  360.    begin
  361.    found := true;
  362.    Readln (f, PName);
  363.    for x := 2 to 28 do
  364.       Readln (f);
  365.    Readln (f, CStr);
  366.    Readln (f);
  367.    Readln (f, BStr);
  368.    end;
  369. ts2 := ts;
  370. Delete(ts2,8,1);
  371. if ts2 = 'DORINFO.DEF' then
  372.    begin
  373.    found := true;
  374.    for x := 1 to 3 do
  375.       Readln (f);
  376.    Readln (f,CStr);
  377.    Readln (f,BStr);
  378.    Readln (f);
  379.    Readln (f,PName);
  380.    x := 1;
  381.    while (x < Length(BStr)) and (BStr[x] <> ' ') do
  382.       inc(x);
  383.    Delete (BStr,x,Length(Bstr)-x+1);
  384.    end;
  385. if ts = 'PCBOARD.SYS' then
  386.    begin
  387.    Close(F);
  388.    found := true;
  389.    Assign (F2, s);
  390.    Reset(F2,1);
  391.    Seek (F2,13);
  392.    BStr := '';
  393.    repeat
  394.       Blockread (F2,Ch,1);
  395.       if ch <> ' ' then
  396.          BStr := BStr + ch;
  397.       until (ch = ' ') or (Length(BStr) = 5);
  398.    Seek (F2,25);
  399.    PName := '';
  400.    repeat
  401.       Blockread (F2,Ch,1);
  402.       if ch <> ' ' then
  403.          PName := PName + ch;
  404.       until (ch = ' ') or (Length(PName) = 15);
  405.    Seek (F2,125);
  406.    Blockread (F2,Ch,1);
  407.    CStr := ch;
  408.    Close(F2);
  409.    Reset(F);
  410.    end;
  411. if ts = 'SFDOORS.DAT' then
  412.    begin
  413.    found := true;
  414.    Readln (f);
  415.    Readln (f, PName);
  416.    for x := 3 to 4 do
  417.       Readln (f);
  418.    Readln (f, BStr);
  419.    Readln (f, CStr);
  420.    end;
  421. if ts = 'CHAIN.TXT' then
  422.    begin
  423.    Found := true;
  424.    Readln (F,PName);
  425.    Val (Pname, UserNum, cnt);
  426.    Readln (f,PName);
  427.    {TTime!!!!}
  428.    for cnt := 3 to 6 do
  429.       Readln (f);
  430.    Readln (f,TrueGold);
  431.    for cnt := 8 to 10 do
  432.       Readln (f);
  433.    Readln (f,TrueSL);
  434.    for cnt := 12 to 17 do
  435.       Readln (F);
  436.    Readln (f, DataDir);
  437. {  for cnt := 18 to 19 do  }
  438.       Readln (f);
  439.    Readln (f, BStr);
  440.    Readln (f, CStr);
  441.    readln (f, BBSName);
  442.    for cnt := 23 to 25 do
  443.       Readln (f);
  444.    Readln (f, TrueUK);
  445.    end;
  446.  
  447. Close(F);
  448. if not found then
  449.    begin
  450.    Writeln ('Unknown chain file format!');  {done something about non-WWIV!}
  451.    Halt;
  452.    end;
  453. if CStr[Length(CStr)] = ':' then
  454.    dec(cstr[0]);
  455. while (Length(CStr) > 0) and ((CStr[1] < '1') or (CStr[1] > '8')) do
  456.    Delete (CStr,1,1);
  457. {
  458. Writeln ('Name: ',PName);
  459. Writeln ('Com: ',CStr);
  460. Writeln ('Baud: ',BStr);
  461. }
  462. Val(BStr, BaudRate, cnt);
  463. Val(Cstr, ComPort, cnt);
  464.  
  465. {Done loading...}
  466.  
  467. Async_CheckCTS := false;
  468. if not Async_Open (Comport, BaudRate) then
  469.    begin
  470.    Writeln ('Invalid COMport or baud rate specification!');
  471.    Halt;
  472.    end;
  473. if async_CarrierDetect then
  474.    SysAllowed := False
  475.    else
  476.    ModemOn := false;
  477. for cnt := 2 to 4 do
  478.    begin
  479.    s := ParamStr(cnt);
  480.    if (s='/l') or (s='/L') then
  481.       begin
  482.       Async_Close;
  483.       ModemOn := False;
  484.       SysAllowed := true;
  485.       SendLine ('Playing local mode');
  486.       end;
  487.    if (s='/b') or (s='/B') then
  488.       begin
  489.       SysAllowed := true;
  490.       if Async_CarrierDetect then
  491.          ModemOn := true;
  492.       end;
  493.    if Upcase(s[2]) = 'X' then
  494.       begin
  495.       Delete (s,1,2);
  496.       Val (s,y,x);
  497.       if (ModemOn) and (y in Bset) then
  498.          begin
  499.          BaudRate := y*100;
  500.          if Async_Open(Comport,Baudrate) then
  501.             Writeln ('COM',Comport,' locked at ',BaudRate,'.');
  502.          end;
  503.       end;
  504.    if (upcase(s[2])='Q') then
  505.       Quiet := true;
  506.    end;
  507. if not sysallowed then
  508.    begin
  509.    Writeln ('Playing remote only.  Nothing should be displayed until the program is');
  510.    Writeln ('finished.  Press F10 at any time to abort and really annoy '+Pname+'.');
  511.    end;
  512. end;
  513.  
  514. Procedure SendCommand (R: byte; ComStr, ExStr: string);
  515.  
  516. var
  517.    tc, ch: char;
  518.    x: byte;
  519.    w1, w2: integer;
  520.    ts: string;
  521.    tsa: boolean;
  522.  
  523. begin
  524. if not cton then
  525.    exit;
  526. if stringing then
  527.    begin
  528.    StrungStr := ComStr;
  529.    exit;
  530.    end;
  531. tc := #0;
  532. Bad := 0;
  533. CurCom := r;
  534. while (modemon) and (async_buffer_check) and (r in [2, 4, 5, 10, 11, 15, 17, 22]) do
  535.    tc := WaitForChar;
  536. redstr := '';
  537. lastok := true;
  538. if ModemOn then
  539.    begin
  540.    ts := Initcode;
  541.    for x := 1 to Length(ts) do
  542.       Async_send(ts[x]);
  543.    if keypressed then
  544.       begin
  545.       if (readkey = #0) and (readkey = 'D') then
  546.          begin
  547.          DoCode (5,#0+#0,'');
  548.          SendLine ('Sysop aborting...');
  549.          ExitProg;
  550.          end;
  551.       end;
  552.    ch := chr(r);
  553.    Async_Send(ch);
  554.    for x := 1 to Length(ComStr) do
  555.       Async_send(ComStr[x]);
  556.    if ExStr <> '' then
  557.       begin
  558.       for x := 1 to Length(ExStr) do
  559.          Async_send(ExStr[x]);
  560.       Async_Send(EndChar);
  561.       end;
  562.    lastok := true;
  563.    if sysallowed and (not (r in [4,10,11,12,15])) then
  564.       DoCode (r,ComStr,Exstr);
  565.    t1 := 0;
  566.    t2 := 0;
  567.    sysoff := true;
  568.    case r of
  569.       4: begin
  570.          t1 := ord(WaitForChar);
  571.          t2 := ord(WaitForChar);
  572.          if sysallowed then
  573.             begin
  574.             DetectGraph (w1,w2);
  575.             if w1 < t1 then
  576.                t1 := w1;
  577.             if w2 < t2 then
  578.                t2 := w2;
  579.             end;
  580.          end;
  581.       11: begin
  582.          for t1 := 1 to 4 do
  583.              redstr := redstr + WaitForChar;
  584.          Move (RedStr[1], Memty, 4);
  585.          end;
  586.       12: begin
  587. {        WaitMin := 2;
  588.          SysEnd := 1;
  589.          t1 := ord(WaitForChar);
  590.          SysEnd := 0;            }
  591.          end;
  592.       15: begin
  593.          WaitMin := 6;
  594.          SysEnd := 2;
  595.          t1 := ord(WaitForChar);
  596.          SysEnd := 0;
  597.          for t2 := 1 to t1 do
  598.             redstr := redstr + WaitForChar;
  599.          end;
  600.       21: begin
  601. {        t1 := ord(WaitForChar);  }
  602.          end;
  603.       end;
  604.    sysoff := false;
  605.    WaitMin := 3;
  606.    end else begin
  607.    if not (r in [4,10,11,12,15]) then
  608.       DoCode (r,ComStr,Exstr);
  609.    if not lastok then
  610.       begin
  611.       Writeln ('did code not ok');
  612.       lastok := true;
  613.       end;
  614.    case r of
  615.       4: begin
  616.          DetectGraph (w1, w2);
  617.          t1 := w1;
  618.          t2 := w2;
  619.          end;
  620.       11: Memty := MemAvail;
  621.       end;
  622.    end;
  623. end;
  624.  
  625. Function CommandOk: boolean;
  626.  
  627. var
  628.    ch: char;
  629.    tsa: boolean;
  630.  
  631. begin
  632. CommandOk := true;
  633. if not Lastok then
  634.    Writeln ('Command ok not');
  635. if (CurCom in [2, 4, 5, 10, 11, 15, 22]) then
  636.    begin
  637.    if modemon then
  638.       begin
  639.       if CurCom = 10 then
  640.          WaitMin := 0;
  641.    {  sysoff := true;   }
  642.       repeat
  643.          ch := WaitForChar;                  { ok or not? }
  644.          if (CurCom = 10) and (ch = #32) then
  645.             begin
  646.             SpaceP := true;
  647.             ch := notok;
  648.             end;
  649.          until (ch < #3);
  650.       WaitMin := 3;
  651.    {  sysoff := false;   }
  652.       if ch <> ok then
  653.          begin
  654.          Writeln ('Error ',ord(ch));
  655.          inc(bad);
  656.          CommandOK := false;
  657.          end else
  658.          Bad := 0;
  659.       end else
  660.       if (not lastok) then
  661.          CommandOk := false;
  662.    end;
  663. if (bad > 2) then
  664.    begin
  665.    DoCode(5,#0+#0,'');
  666.    SendLine ('');
  667.    SendLine ('Aborting program.');
  668.    ExitProg;
  669.    end;
  670. end;
  671.  
  672. Procedure PutPic(num: byte; x, y: word; how: byte);
  673.  
  674. begin
  675. ComStr[0] := #6;
  676. ComStr[1] := Chr(num);
  677. move (x, ComStr[2], 2);
  678. move (y, ComStr[4], 2);
  679. ComStr[6] := Chr(how);
  680. SendCommand(1, ComStr, '');
  681. end;
  682.  
  683. Procedure LoadPic(num: byte; place, length: word; fn: string);
  684.  
  685. var
  686.    x: byte;
  687.  
  688. begin
  689. ComStr[0] := #5;
  690. ComStr[1] := Chr(num);
  691. move (place, ComStr[2], 2);
  692. move (length, ComStr[4], 2);
  693. x := 0;
  694. lastok := true;
  695. repeat
  696.    SendCommand (2, ComStr, FN);
  697.    if not lastok then
  698.       Writeln ('Load not...');
  699.    inc(x);
  700.    if x = 3 then
  701.       begin
  702.       DoCode (5,#0+#0,'');
  703.       SendLine (FN+' not found.  You must have the proper .CT files in order to run');
  704.       SendLine ('the game.  Aborting.');
  705.       ExitProg;
  706.       end;
  707.    until CommandOK;
  708. end;
  709.  
  710. Procedure DoText(x, y: word; tx: string);
  711.  
  712. begin
  713. if cton then
  714.    begin
  715.    ComStr[0] := #4;
  716.    move (x, ComStr[1], 2);
  717.    move (y, ComStr[3], 2);
  718.    if tx = '' then
  719.       tx := #254;
  720.    SendCommand (3, ComStr, tx);
  721.    end else
  722.    if tx[Length(tx)] = ' ' then
  723.       SendStr(tx)
  724.       else
  725.       SendLine (tx);
  726. end;
  727.  
  728. Procedure GrInfo(var gd, gm: word);
  729.  
  730. var
  731.    x: byte;
  732.  
  733. begin
  734. x := 0;
  735. repeat
  736.    SendCommand (4, '', '');
  737.    inc(x);
  738.    if x = 3 then
  739.       begin
  740.       SendLine ('No response.  Aborting...');
  741.       ExitProg;
  742.       end;
  743.    until CommandOk;
  744. gd := t1;
  745. gm := t2;
  746. end;
  747.  
  748. Procedure InitGr(d, m: word);
  749.  
  750. var
  751.    x: byte;
  752.  
  753. begin
  754. ComStr[0] := #2;
  755. ComStr[1] := chr(d mod 256);
  756. ComStr[2] := chr(m mod 256);
  757. gd := d;
  758. gm := m;
  759. x := 0;
  760. repeat
  761.    SendCommand (5, comstr, '');
  762.    inc(x);
  763.    if x = 3 then
  764.       begin
  765.       SendLine ('Graphics error.  Aborting...');
  766.       ExitProg;
  767.       end;
  768.    until CommandOk;
  769. end;
  770.  
  771. Procedure ScreenPage (apage, vpage: byte);
  772.  
  773. begin
  774. ComStr[0] := #2;
  775. ComStr[1] := chr(apage);
  776. ComStr[2] := chr(vpage);
  777. SendCommand (6, ComStr, '');
  778. end;
  779.  
  780. Procedure DoLine (x1, y1, x2, y2: word; color: byte);
  781.  
  782. begin
  783. ComStr[0] := #9;
  784. move (x1, ComStr[1], 2);
  785. move (y1, ComStr[3], 2);
  786. move (x2, ComStr[5], 2);
  787. move (y2, ComStr[7], 2);
  788. ComStr[9] := chr(color);
  789. fgcol := color;
  790. SendCommand (7, ComStr, '');
  791. end;
  792.  
  793. Procedure DoCircle (x, y, rad: word; color: byte);
  794.  
  795. begin
  796. ComStr[0] := #7;
  797. move (x, ComStr[1], 2);
  798. move (y, ComStr[3], 2);
  799. move (rad, ComStr[5], 2);
  800. ComStr[7] := chr(color);
  801. fgcol := color;
  802. SendCommand (8, ComStr, '');
  803. end;
  804.  
  805. Procedure DoRect (x1, y1, x2, y2: word; color: byte);
  806.  
  807. begin
  808. ComStr[0] := #9;
  809. move (x1, ComStr[1], 2);
  810. move (y1, ComStr[3], 2);
  811. move (x2, ComStr[5], 2);
  812. move (y2, ComStr[7], 2);
  813. ComStr[9] := chr(color);
  814. fgcol := color;
  815. SendCommand (9, ComStr, '');
  816. end;
  817.  
  818. Function TestResp: boolean;
  819.  
  820. var
  821.    x: byte;
  822.    g: boolean;
  823.  
  824. begin
  825. TestResp := true;
  826. if not modemon then
  827.    exit;
  828. SendLine ('If Crunchterm is not currently running, run it and press Ctrl-A.');
  829. SendLine ('Hit space to cancel.');
  830. x := 0;
  831. SpaceP := false;
  832. repeat
  833.    inc(x);
  834.    SendCommand (10, '', '');
  835.    g := commandok;
  836.    until (x = 3) or SpaceP or g;
  837. if SpaceP or (x=3) then
  838.    TestResp := false;
  839. end;
  840.  
  841. Function MemFree: longint;
  842.  
  843. begin
  844. SendCommand (11, '', '');
  845. MemFree := Memty;
  846. end;
  847.  
  848. Procedure LeaveCT;
  849.  
  850. begin
  851. SendCommand (12,'','');
  852. end;
  853.  
  854. Procedure ClearScr;
  855.  
  856. begin
  857. SendCommand (13, '', '');
  858. end;
  859.  
  860. Procedure SetCol (fore, back: byte);
  861.  
  862. begin
  863. Comstr[0] := #2;
  864. bkcol := back;
  865. fgcol := fore;
  866. comstr[1] := chr(fore);
  867. comstr[2] := chr(back);
  868. SendCommand (14, ComStr, '');
  869. end;
  870.  
  871. Procedure InLineXY (len: byte; x, y: word; var thestring: string);
  872.  
  873. begin
  874. ComStr[0] := #5;
  875. ComStr[1] := chr(len);
  876. move (x, ComStr[2], 2);
  877. move (y, ComStr[4], 2);
  878. repeat
  879.    SendCommand (15, ComStr, '');
  880.    thestring := redstr;
  881.    if (not ModemOn) and (bad = 0) then
  882.       begin
  883.       GotoXY (x,y);
  884.       Readln (thestring);
  885.       end;
  886.    until CommandOK;
  887. end;
  888.  
  889. Procedure FillStyle (pattern, color: word);
  890.  
  891. begin
  892. comstr[0] := #4;
  893. FillPat := Pattern;
  894. FillCol := Color;
  895. move (pattern, ComStr[1], 2);
  896. move (color, ComStr[3], 2);
  897. SendCommand (16, ComStr, '');
  898. end;
  899.  
  900. Procedure GetPic (num: byte; x1, y1, x2, y2: word);
  901.  
  902. begin
  903. ComStr[0] := #9;
  904. ComStr[1] := chr(num);
  905. move (x1, ComStr[2], 2);
  906. move (y1, ComStr[4], 2);
  907. move (x2, ComStr[6], 2);
  908. move (y2, ComStr[8], 2);
  909. SendCommand (17, ComStr, '');
  910. end;
  911.  
  912. Procedure DefSeries (Ser, Step, Command, ExNum: byte; StrStr: string);
  913.  
  914. begin
  915. ComStr[0] := #4;
  916. ComStr[1] := chr(Ser);
  917. ComStr[2] := chr(Step);
  918. ComStr[3] := chr(Command);
  919. ComStr[4] := chr(ExNum);
  920. SendCommand (18, ComStr, StrStr);
  921. end;
  922.  
  923. Procedure DoSeries (Ser: byte);
  924.  
  925. begin
  926. SendCommand (19, Chr(ser), '');
  927. end;
  928.  
  929. Procedure DefExStr (num: byte; exstr: string);
  930.  
  931. begin
  932. SendCommand (20, Chr(num), ExStr);
  933. end;
  934.  
  935. Procedure SetGD(gd: byte);
  936.  
  937. begin
  938. SendCommand (21,Chr(gd),'');
  939. end;
  940.  
  941. Procedure LoadSong (SongNum: byte; Place: word; FN: string);
  942.  
  943. var
  944.    test1: byte;
  945.  
  946. begin
  947. ComStr[0] := #3;
  948. ComStr[1] := chr(songnum);
  949. Move (Place, ComStr[2], 2);
  950. test1 := 0;
  951. repeat
  952.    SendCommand (22, ComStr, FN);
  953.    inc(test1);
  954.    until (CommandOk) or (test1 = 2);
  955. end;
  956.  
  957. Procedure DoSong (SongNum: byte);
  958.  
  959. begin
  960. if SoundOn then
  961.    SendCommand (23, chr(SongNum), '');
  962. end;
  963.  
  964. Procedure DefAnim (Flm, Frame, PicN: byte; pause, x, y: word; Way: byte);
  965.  
  966. begin
  967. ComStr[0] := #10;
  968. ComStr[1] := chr(Flm);
  969. Comstr[2] := chr(Frame);
  970. ComStr[3] := chr(PicN);
  971. Move (Pause, Comstr[4], 2);
  972. Move (x, Comstr[6], 2);
  973. Move (y, Comstr[8], 2);
  974. ComStr[10] := chr(Way);
  975. SendCommand (24, ComStr, '');
  976. end;
  977.  
  978. Procedure ShowAnim (Flm: byte; AuxX, AuxY: word);
  979.  
  980. var
  981.    kp: byte;
  982.  
  983. begin
  984. ComStr[0] := #5;
  985. ComStr[1] := chr(Flm);
  986. Move (Auxx, Comstr[2], 2);
  987. Move (Auxy, Comstr[4], 2);
  988. SendCommand (25, ComStr, '');
  989. end;
  990.  
  991. Procedure TextStyle (Size, font: word);
  992.  
  993. begin
  994. ComStr[0] := #4;
  995. Move (Size, ComStr[1], 2);
  996. Move (Font, ComStr[3], 2);
  997. SendCommand (26, ComStr, '');
  998. end;
  999.  
  1000. Procedure FillCircle (x, y, rad: word);
  1001.  
  1002. begin
  1003. ComStr[0] := #6;
  1004. move (x, ComStr[1], 2);
  1005. move (y, ComStr[3], 2);
  1006. move (rad, ComStr[5], 2);
  1007. SendCommand (27, ComStr, '');
  1008. end;
  1009.  
  1010. Procedure FillBar (x1, y1, x2, y2: word);
  1011.  
  1012. begin
  1013. ComStr[0] := #8;
  1014. move (x1, ComStr[1], 2);
  1015. move (y1, ComStr[3], 2);
  1016. move (x2, ComStr[5], 2);
  1017. move (y2, ComStr[7], 2);
  1018. SendCommand (28, ComStr, '');
  1019. end;
  1020.  
  1021.  
  1022. Procedure FillFlood (x, y: word; BorderCol: byte);
  1023.  
  1024. begin
  1025. ComStr[0] := #5;
  1026. move (x, ComStr[1], 2);
  1027. move (y, ComStr[3], 2);
  1028. ComStr[5] := Chr(BorderCol);
  1029. SendCommand (29, ComStr, '');
  1030. end;
  1031.  
  1032. Procedure DefNote (Song, Note, l, n, o: byte);
  1033.  
  1034. begin
  1035. ComStr[0] := #5;
  1036. ComStr[1] := chr(song);
  1037. ComStr[2] := chr(note);
  1038. ComStr[3] := chr(l);
  1039. ComStr[4] := chr(n);
  1040. ComStr[5] := chr(o);
  1041. SendCommand (30,ComStr,'');
  1042. end;
  1043.  
  1044. Procedure ChPalette(ColorNum: word; Color: shortint);
  1045.  
  1046. begin
  1047. ComStr[0] := #3;
  1048. Move (ColorNum, ComStr[1], 2);
  1049. ComStr[3] := chr(Color);
  1050. SendCommand (32, Comstr,'');
  1051. end;
  1052.  
  1053. Procedure DoArc (x, y, stangle, endangle, rad: word);
  1054.  
  1055. begin
  1056. ComStr[0] := #10;
  1057. Move (x, ComStr[1], 2);
  1058. Move (y, ComStr[3], 2);
  1059. Move (stangle, ComStr[5], 2);
  1060. Move (endangle, ComStr[7], 2);
  1061. Move (rad, ComStr[9], 2);
  1062. SendCommand (33, ComStr,'');
  1063. end;
  1064.  
  1065. Procedure VirtWind (x1, y1, x2, y2: word; Clip: boolean);
  1066.  
  1067. begin
  1068. ComStr[0] := #9;
  1069. move (x1, ComStr[1], 2);
  1070. move (y1, ComStr[3], 2);
  1071. move (x2, ComStr[5], 2);
  1072. move (y2, ComStr[7], 2);
  1073. if Clip then
  1074.    Comstr[9] := #1
  1075.    else
  1076.    ComStr[9] := #0;
  1077. SendCommand (34, ComStr, '');
  1078. end;
  1079.  
  1080. Procedure HighLight (x1, y1, x2, y2: word);
  1081.  
  1082. begin
  1083. ComStr[0] := #8;
  1084. move (x1, ComStr[1], 2);
  1085. move (y1, ComStr[3], 2);
  1086. move (x2, ComStr[5], 2);
  1087. move (y2, ComStr[7], 2);
  1088. SendCommand (35, ComStr, '');
  1089. end;
  1090.  
  1091. Procedure UnHighLight;
  1092.  
  1093. begin
  1094. SendCommand (36, '', '');
  1095. end;
  1096.  
  1097. Procedure DefScroll (x1, y1, x2, y2, scramt: word);
  1098.  
  1099. begin
  1100. ComStr[0] := #10;
  1101. move (x1, ComStr[1], 2);
  1102. move (y1, ComStr[3], 2);
  1103. move (x2, ComStr[5], 2);
  1104. move (y2, ComStr[7], 2);
  1105. move (scramt, ComStr[9], 2);
  1106. SendCommand (37, ComStr, '');
  1107. end;
  1108.  
  1109. Procedure ScrollUp;
  1110.  
  1111. begin
  1112. SendCommand (38,'','');
  1113. end;
  1114.  
  1115. Procedure ScrollDown;
  1116.  
  1117. begin
  1118. SendCommand (39,'','');
  1119. end;
  1120.  
  1121. Procedure SetFg (fore: byte);
  1122.  
  1123. begin
  1124. fgcol := fore;
  1125. SendCommand (40, chr(fore), '');
  1126. end;
  1127.  
  1128. begin
  1129. apage := 0;
  1130. vpage := 0;
  1131. SysEnd := 0;
  1132. WaitMin := 3;
  1133. DoTimeCheck := false;
  1134. Stringing := false;
  1135. SysAllowed := true;
  1136. CTOn := false;
  1137. ModemOn := true;
  1138. StrungStr := '';
  1139. FillPat := 0;
  1140. FillCol := 0;
  1141. BkCol := 0;
  1142. fgCol := 7;
  1143. CurCom := 0;
  1144. Bad := 0;
  1145. sysoff := false;
  1146. Local := true;
  1147. SoundOn := true;
  1148. end.