home *** CD-ROM | disk | FTP | other *** search
/ ftp.barnyard.co.uk / 2015.02.ftp.barnyard.co.uk.tar / ftp.barnyard.co.uk / cpm / walnut-creek-CDROM / CPM / DATABASE / SCHEDULE.ARK / SCH1.INC next >
Text File  |  1987-01-20  |  8KB  |  392 lines
  1. { INCLUDE File SCH1.INC}
  2.  
  3. PROCEDURE CursorOn;
  4.  
  5. BEGIN
  6.    Write(^[, 'B4');
  7. END;
  8.  
  9. PROCEDURE CursorOff;
  10.  
  11. BEGIN
  12.    Write(^[, 'C4');
  13. END;
  14.  
  15. PROCEDURE UnderOn;
  16.  
  17. BEGIN
  18.    Write(^[, 'B3');
  19. END;
  20.  
  21. PROCEDURE UnderOff;
  22.  
  23. BEGIN
  24.    Write(^[, 'C3');
  25. END;
  26.  
  27. PROCEDURE ReverseOn;
  28.  
  29. BEGIN
  30.    Write(^[, 'B0');
  31. END;
  32.  
  33. PROCEDURE ReverseOff;
  34.  
  35. BEGIN
  36.    Write(^[, 'C0');
  37. END;
  38.  
  39. PROCEDURE HMove(Xbgn,Xend,Y:Integer; Ch:Char);
  40.  
  41. VAR
  42.    I, NextI, DFlag, IPos : Integer;
  43.  
  44. BEGIN
  45.    If Xbgn < Xend Then DFlag := 1 Else DFlag := -1;
  46.    GotoXY(Xbgn,Y);
  47.    Write(Ch);
  48.    Xbgn := Xbgn + DFlag;
  49.    Xbgn := Xbgn*DFlag;
  50.    Xend := Xend*DFlag;
  51.    For I := Xbgn to Xend Do
  52.    BEGIN
  53.       Delay(20);
  54.       IPos := I*DFlag;
  55.       NextI := IPos - DFlag;
  56.       GotoXY(NextI,Y);
  57.       Write(' ');
  58.       GotoXY(IPos,Y);
  59.       Write(Ch);
  60.    END;
  61. END;
  62.  
  63. PROCEDURE VMove(Ybgn,Yend,X:Integer; Ch:Char);
  64.  
  65. VAR
  66.    J, NextJ, DFlag, JPos : Integer;
  67.  
  68. BEGIN
  69.    If Ybgn < Yend Then DFlag := 1 Else DFlag := -1;
  70.    GotoXY(X,Ybgn);
  71.    Write(Ch);
  72.    Ybgn := Ybgn + DFlag;
  73.    Ybgn := Ybgn*DFlag;
  74.    Yend := Yend*DFlag;
  75.    For J := Ybgn to Yend Do
  76.    BEGIN
  77.       Delay(40);
  78.       JPos := J*DFlag;
  79.       NextJ := JPos - DFlag;
  80.       GotoXY(X,NextJ);
  81.       Write(' ');
  82.       GotoXY(X,JPos);
  83.       Write(Ch);
  84.    END;
  85. END;
  86.  
  87. PROCEDURE SignOn;
  88.  
  89. BEGIN
  90.    ClrScr;
  91.    CursorOff;
  92.    HMove(1,32,10,'S');
  93.    VMove(1,10,34,'C');
  94.    HMove(80,36,10,'H');
  95.    VMove(24,10,38,'E');
  96.    VMove(1,10,40,'D');
  97.    VMove(24,10,42,'U');
  98.    HMove(80,44,10,'L');
  99.    HMove(80,46,10,'E');
  100.    GotoXY(37,12);
  101.    Write('v', Version:1:1);
  102.    GotoXY(32,14);
  103.    Write(Programmer:1);
  104.    GotoXY(28,16);
  105.    Write('Last Update : ', LastUpdate);
  106.    Delay(3000);
  107.    CursorOn;
  108. END; {of SignOn}
  109.  
  110. PROCEDURE SignOff;
  111.  
  112. BEGIN
  113.    ClrScr;
  114.    GotoXY(30,12);
  115.    Writeln('Have a good day!!');
  116. END; {of SignOff}
  117.  
  118. PROCEDURE StatusLine;
  119.  
  120. BEGIN
  121.    GotoXY(1,23);
  122.    ClrEol;
  123. END; {of StatusLine}
  124.  
  125. FUNCTION NoYes(I : Integer) : Boolean;
  126.  
  127. VAR
  128.    Ch : Char;
  129.    Valid : Boolean;
  130.  
  131. BEGIN
  132.    Repeat
  133.       Read(Kbd,Ch);
  134.       If Ch In ['N', 'Y', 'n', 'y'] Then Valid := True Else Valid := False;
  135.       If Not Valid Then Write(^G);
  136.    Until Valid;
  137.    If Ch In ['N', 'n'] Then NoYes := False Else Noyes := True;
  138. END; {of NoYes}
  139.  
  140. PROCEDURE Menu;
  141.  
  142. BEGIN
  143.    CursorOff;
  144.    GotoXY(IM,JM);
  145.    UnderOn;
  146.    Write('Command Sammary');
  147.    UnderOff;
  148.    GotoXY(IM,JM + 2);
  149.    Write('[^E]  : Up Hour');
  150.    GotoXY(IM,JM + 3);
  151.    Write('[^X]  : Down Hour');
  152.    GotoXY(IM,JM + 4);
  153.    Write('[ESC] : Enter Note');
  154.    GotoXY(IM,JM + 5);
  155.    Write('[^C]  : Cancel Note');
  156.    GotoXY(IM,JM + 6);
  157.    Write('[^S]  : Save/Resume');
  158.    GotoXY(IM,jM + 7);
  159.    Write('[^T]  : Delete Record');
  160.    GotoXY(IM,JM + 8);
  161.    Write('[^D]  : Display Dates');
  162.    GotoXY(IM,JM + 9);
  163.    Write('[^P]  : Save/Print');
  164.    GotoXY(IM,JM + 10);
  165.    Write('[^F]  : Save/Open File');
  166.    GotoXY(IM,JM + 11);
  167.    Write('[^Q]  : Save/Quit');
  168.    CursorOn;
  169. END; {of Menu}
  170.  
  171. PROCEDURE Ucase;
  172.  
  173. VAR
  174.    Len, I : Integer;
  175.    Ftemp : FileName;
  176.  
  177. BEGIN
  178.    Ftemp := '';
  179.    Len := Length(DataFile);
  180.    For I := 1 To Len Do Ftemp := Ftemp + UpCase(DataFile[I]);
  181.    DataFile := Ftemp;
  182. END; {of Ucase}
  183.  
  184. PROCEDURE Error;
  185.  
  186. BEGIN
  187.    CreateMode := False;
  188.    If IOResult = 0 Then NoError := True Else NoError := False;
  189.    If Not NoError Then
  190.    BEGIN
  191.       Close(AptFile);
  192.       ClrScr;
  193.       GotoXY(12,7);
  194.       Write(^G, 'Cannot find ', DataFile);
  195.       GotoXY(12,9);
  196.       Write('Do you want to create it (y/n) ? ');
  197.       CreateMode := NoYes(1);
  198.       If Not CreateMode Then
  199.       BEGIN
  200.          GotoXY(12,10);
  201.          Write('Continue (y/n) ? ');
  202.          If Not NoYes(1) Then Halt;
  203.       END;
  204.    END;
  205. END; {of Error}
  206.  
  207. PROCEDURE OpenToUpdate;
  208.  
  209. BEGIN
  210.    Assign(AptFile, DataFile);
  211.    {$I-}
  212.    Reset(AptFile);
  213.    {$I+}
  214. END; {of OpenToUpdate}
  215.  
  216. PROCEDURE OpenToCreate;
  217.  
  218. BEGIN
  219.    Assign(AptFile, DataFile);
  220.    Rewrite(AptFile);
  221. END; {of OpenToCreate}
  222.  
  223. PROCEDURE EnterFile;
  224.  
  225. VAR
  226.    I : Integer;
  227.  
  228. BEGIN
  229.    Repeat
  230.       ClrScr;
  231.       GotoXY(12,7);
  232.       Write('Enter Schedule File name : ');
  233.       Readln(DataFile);
  234.       GotoXY(12,7);
  235.       Ucase;
  236.       OpenToUpDate;
  237.       Error;
  238.    Until NoError Or CreateMode;
  239.    If CreateMode Then
  240.    BEGIN
  241.       OpenToCreate;
  242.       For I := HrBgn To HrEnd Do AptRec.Note[I] := Blank;
  243.    END;
  244. END; {of EnterFile}
  245.  
  246. PROCEDURE SearchDate;
  247.  
  248. LABEL
  249.    Found;
  250.  
  251. VAR
  252.    I, RecSize : Integer;
  253.    Exist : Boolean;
  254.  
  255. BEGIN
  256.    Rec := 0;
  257.    Exist := False;
  258.    If CreateMode Then Goto Found;
  259.    OpenToUpdate;
  260.    RecSize := FileSize(AptFile);
  261.    If RecSize = 0 Then Goto Found;
  262.    While Rec < RecSize Do
  263.    BEGIN
  264.       Seek(AptFile,Rec);
  265.       Flush(AptFile);
  266.       Read(AptFile,AptRec);
  267.       If AptRec.Date = Date1 Then
  268.       BEGIN
  269.          Exist := True;
  270.          Goto Found;
  271.       END;
  272.       Rec := Succ(Rec);
  273.    END;
  274.    Found : With AptRec Do Date := Date1;
  275.    If Not Exist Then For I := HrBgn To HrEnd Do AptRec.Note[I] := Blank;
  276. END; {ofSearchDate}
  277.  
  278. PROCEDURE SetCal;
  279.  
  280. VAR
  281.    Yr, AcDays, I : Integer;
  282.    Leap : Boolean;
  283.  
  284. BEGIN
  285.    Yr := Year - 80;
  286.    Leap := False;
  287.    If (Yr Mod 4 = 0) Then Leap := True;
  288.    AcDays := 365*Yr + Yr Div 4 + 1;
  289.    For I := 1 To Month Do AcDays := AcDays + DaysOfMonth[I];
  290.    AcDays := AcDays - DaysOfMonth[Month];
  291.    If (Month > 2) And Leap Then AcDays := Succ(AcDays);
  292.    DayOfWeek := (AcDays + 2)  Mod 7 + 1;
  293.    DOM := DaysOfMonth[Month];
  294.    If Leap And (Month = 2) Then DOM := Succ(DOM);
  295. END; {of SetCal}
  296.  
  297. PROCEDURE EnterDate;
  298.  
  299. LABEL
  300.    Retry;
  301.  
  302. VAR
  303.    Valid, ValidDay : Boolean;
  304.    Y : Integer;
  305.  
  306. BEGIN
  307.    Repeat
  308.       StatusLine;
  309.       Write('Month (1-12) ? ');
  310.       {$I-}
  311.       Readln(Month);
  312.       {$I+}
  313.       If (Month In [1..12]) And (IOResult = 0) Then Valid := True Else Valid := False;
  314.       If Not Valid Then Write(^G);
  315.    Until Valid;
  316.    Repeat
  317.       StatusLine;
  318.       Retry: Write('Day ? ');
  319.       {$I-}
  320.       Readln(Day);
  321.       {$I+}
  322.       If (Day In [1..31]) And (IOResult = 0) Then ValidDay := True Else ValidDay := False;
  323.       If Not ValidDay Then Write(^G);
  324.    Until ValidDay;
  325.    Repeat
  326.       StatusLine;
  327.       Write('Year (80-99) ? ');
  328.       {$I-}
  329.       Readln(Year);
  330.       {$I+}
  331.       If (Year In [80..99]) And (IOResult = 0) Then Valid := True Else Valid := False;
  332.       If Not Valid Then Write(^G);
  333.    Until Valid;
  334.    SetCal;
  335.    If Not (Day In [1..DOM]) Then ValidDay := False Else ValidDay := True;
  336.    If Not ValidDay Then
  337.    BEGIN
  338.       Write(^G);
  339.       StatusLine;
  340.       Y := 1900 + Year;
  341.       Write('Invalid Day entered for ', MonthOfYear[Month]:1, ', ', Y:1,'.');
  342.       Write('   Please re-enter ');
  343.       Goto Retry;
  344.    END;
  345. END; {of EnterDate}
  346.  
  347. PROCEDURE MakeDate;
  348.  
  349. VAR
  350.    I : Integer;
  351.  
  352. BEGIN
  353.    Str(Year:2,DY);
  354.    Str(Month:2,DM);
  355.    Str(Day:2,DD);
  356.    Date1 := DY + '/' + DM + '/' + DD;
  357.    For I := 1 To 8 Do If Date1[I] = ' ' Then Date1[I] := '0';
  358. END; {of MakeDate}
  359.  
  360. PROCEDURE Calendar;
  361.  
  362. VAR
  363.    J, K, Ih, Jh, Yr : Integer;
  364.  
  365. BEGIN
  366.    CursorOff;
  367.    j := JC;
  368.    Yr := 1900 + Year;
  369.    Ih := (15 -  Length(MonthOfYear[Month])) Div 2 + IC;
  370.    Jh := Pred(JC);
  371.    For K := 0 To 7 Do
  372.    BEGIN
  373.       GotoXY(IC,Jh + K);
  374.       Write('                    ');
  375.    END;
  376.    GotoXY(Ih,Jh);
  377.    Write(MonthOfYear[Month]:1, ', ', Yr:1);
  378.    GotoXY(IC,J);
  379.    Write('Su Mo Tu We Th Fr Sa');
  380.    LowVideo;
  381.    For K := 1 To DOM Do
  382.    BEGIN
  383.       DOW := (DayOfWeek + K - 2) Mod 7 + 1;
  384.       GotoXY(3*(DOW - 1) + IC,J + 1);
  385.       If K = Day Then NormVideo Else LowVideo;
  386.       Write(K:2);
  387.       If DOW = 7 Then J := Succ(J);
  388.    END;
  389.    NormVideo;
  390.    CursorOn;
  391. END; {of Calendar}
  392.