home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / MADTRB20.ZIP / PATTERN.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1985-10-08  |  10.4 KB  |  301 lines
  1. Program Pattern;
  2.                    {Written by Claire A. Rinehart}
  3.                    {18C University Houses}
  4.                    {Madison, WI  53705}
  5.                    { This program is a user supported program}
  6.                    {to be distributed under the ShareWare Concept}
  7.                    {        Last Revision  10-85        }
  8. Const
  9.  Menu : String[40]     =     '1Pat, 2Pat, 3Pat, Pal, CT, Quit';
  10. Type
  11.  String255 = String[255];
  12.  String80  = String[80];
  13. Var
  14.  Pat  : Array[1..3,0..7] of Byte;  {array containing the values for the 3 pat}
  15.  Lin  : Array[1..3,0..7,0..7] of Char;  {the primitive array for pattern input}
  16.  Ind  :  Integer;                  {Index of the pattern line}
  17.  Resp :  Integer;                  {choice selected from main menu}
  18.  Pind :  Integer;                  {pattern index 1..3}
  19.  Lind :  Integer;                  {line index}
  20.  Lnum :  Integer;                  {Line number index}
  21.  PalNum : Integer;                 {Palette number}
  22.  C0,C1,C2,C3 : Integer;            {variables for color table}
  23.  Pic : Array[1..8630] of Byte;     {used to store the patterns for CT display}
  24.  
  25. Procedure Convert;  {translates - and 0 into the decimal equivalent of the}
  26. Var                 {binary pattern for each line}
  27.  Pwr : Integer;
  28.  Sum :  Byte;
  29. Begin
  30.  Sum := 0;
  31.  For Pwr := 0 to 7 do
  32.   begin
  33.    If Lin[Pind, Ind, Pwr] = '0' then Sum := Sum + Round(Exp(Pwr * Ln(2)));
  34.   end;
  35.  Pat[PInd,Ind] := Sum;
  36. End;
  37.  
  38. {$I Graph.P }
  39.  
  40. Procedure Parse(Var Line : String255; Var Word : String80; Delim : Char);
  41. {Removes first word in Line and returns it in Word.  Line is modified so that
  42.  it no longer has leading blanks before the word is filled.  The delim constant
  43.  is used to identify the symbol used to delimit words.  The Line variable is
  44.  decreased in length by one word, and of course leading blanks, before it is
  45.  returned}
  46. Const
  47.   Space  =  ' ';
  48. Var
  49.   Indx, Len  :  Integer;
  50. Begin
  51.   While Pos(Space, Line) = 1 Do     {remove leading blanks}
  52.     Delete(Line, 1, 1);
  53.   Len := Pos(Delim, Line);
  54.   If Len = 0 then
  55.     begin             {no delimiters left}
  56.       Word := Line;
  57.       Line := '';
  58.     End
  59.   Else If Len = 1 then
  60.       begin                             {check for two delimiters in a row}
  61.         Word := '';                      {return null string}
  62.         Delete(Line, 1, Len);            {delete delimiter}
  63.       End
  64.     Else
  65.       Begin                             {get word and delete from line}
  66.         Word := Copy(Line, 1, Len -1);  {get all but delimiter}
  67.         Delete(Line, 1, Len);            {delete word plus delimeter}
  68.       End
  69. End;  {of Parse}
  70.  
  71. Procedure LowToUp(Var Line : string255);
  72. {Converts characters in Line to upper case}
  73. Var
  74.   Indx, Len      : Integer;
  75. Begin
  76.   Len := Length(Line);
  77.   For Indx := 1 to Len do
  78.     Line[Indx] := UpCase(Line[Indx]);   {built-in TURBO function}
  79. End;  {of LowToUp}
  80.  
  81. Procedure Answer(Ans : string255; Var Posn : Integer; CaseSen : Boolean);
  82. {Answer will motitor the keyboard and only allow entry of one of the possible
  83.  matches found in string255.  Responses in Ans should be separated by a comma
  84.  and may be padded with blanks, although all leading blanks will be ignored
  85.  when processing a response.  When enough keystrokes have been entered to
  86.  identify a match as being unique, the rest of the response is displayed and
  87.  the user can accept the answer by hitting return or can strike the backspace
  88.  key and re-enter another valid response.  The procedure returns the ordinal
  89.  position of the response to the calling program for further processing.
  90.  CaseSen is used to determine is the response should be upper/lower case
  91.  sensitive.}
  92. Label
  93.   Return, Start;
  94. Var
  95.   Indx           :  Integer;    {number of possible answers}
  96.   ChPos          :  Integer;    {Chacter position index}
  97.   Cnt            :  Integer;    {counter for correct matches}
  98.   Match          :  Array[1..25] of string80;       {possible answer array}
  99.   Mtch           :  Array[1..25] of Boolean;        {Previous match array}
  100.   StrPos         :  Integer;           {index for stepping through matches}
  101.   Ch             :  Char;              {variable read from the keyboard}
  102.   MtchLen        :  Integer;           {contains the length of the match}
  103.   I              :  Integer;           {counter index}
  104. Begin
  105.   Indx := 0;
  106.   If NOT CaseSen then               {Check upper/lower case sensitivity}
  107.   LowToUp(Ans);                     {If not sensitive then capitalize all ans.}
  108.   While Ans <> '' do                {Parse Ans into matching responses}
  109.     Begin
  110.       Indx := Indx +  1;               {find number of answers}
  111.       Parse(Ans,Match[Indx],',');      {and put them in Match[array]}
  112.     End;
  113.   If Indx = 0 then                 {Check to see if a string was passed in Ans}
  114.     Begin
  115.       Write('No string was passed to use as a response, please check code.');
  116.       Goto Return;
  117.     End;
  118. Start:
  119.   For Cnt := 1 to 25 do Mtch[Cnt] := True; {Initialize pointers to all true}
  120.   ChPos := 1;
  121.   Repeat
  122.     Cnt := 0;                             {set match counter}
  123.     Read(Kbd, Ch);                        {Get characters from the keyboard}
  124.     If NOT CaseSen then Ch := UpCase(Ch);
  125.       For StrPos := 1 to Indx do          {Search all responses for matches}
  126.         Begin
  127.           If Mtch[StrPos] then            {Check for previous match}
  128.             If Ch = Copy(Match[StrPos], ChPos, 1) then
  129.               Begin
  130.                 Cnt  := Cnt + 1;             {Count the number of matches}
  131.                 Posn := StrPos;              {Enter the position of the last}
  132.               End                           {match in the return variable.}
  133.         End;
  134.     If Cnt = 0 then             {Check for no match}
  135.       If Ch = Chr(8) then          {Check for a backspace}
  136.         Begin                   {If backspace has been hit then decrease}
  137.           ChPos := ChPos -1;    {the character index by one.}
  138.           If ChPos < 1 then     {If the backspace has been over used then}
  139.             Begin               {reset to position one and beep.}
  140.               ChPos := 1;
  141.               Write(Chr(7));
  142.             End
  143.           Else
  144.             Begin
  145.               Write(Chr(8));
  146.               Write(Chr(32));
  147.               Write(Chr(8));
  148.             End;
  149.         End
  150.       Else
  151.         Write(Chr(7))      {If the character has no match just beep and}
  152.     Else                        {don't write it to the screen}
  153.       Begin
  154.         For StrPos := 1 to Indx do
  155.           If Ch <> Copy(Match[StrPos], ChPos, 1) then
  156.             Mtch[StrPos] := False;
  157.         ChPos := ChPos + 1;
  158.         Write(Ch);           {Otherwise write the matching character to the}
  159.       End;
  160.   Until Cnt = 1;                 {screen.}
  161.   MtchLen := Length(Match[Posn]) - ChPos + 1;
  162.   Write(Copy(Match[Posn], ChPos, MtchLen));
  163.   Repeat
  164.    Read(Kbd, Ch);
  165.    If Ch = Chr(8) then
  166.     begin
  167.      For I := 1 to Length(Match[Posn]) do Write(Chr(8));
  168.      For I := 1 to Length(Match[Posn]) do Write(Chr(32));
  169.      For I := 1 to Length(Match[Posn]) do Write(Chr(8));
  170.      ChPos := 1;
  171.      Goto Start;
  172.     end
  173.    else
  174.     If Ord(Ch) <> 13 then Write (Chr(7));
  175.   Until Ord(Ch) = 13;
  176. Return:
  177. End;  {of Answer}
  178.  
  179. Procedure Disp;
  180. Begin
  181.  FillScreen(0);
  182.  Pattern(Pat[1]);
  183.  FillPattern(8, 16, 71, 71, 1);
  184.  FillPattern(248, 16, 311, 71, 1);
  185.  Pattern(Pat[2]);
  186.  FillPattern(88, 16, 151, 71, 2);
  187.  FillPattern(248, 16, 311, 71, 2);
  188.  Pattern(Pat[3]);
  189.  FillPattern(168, 16, 231, 71, 3);
  190.  FillPattern(248, 16, 311, 71, 3);
  191. End;
  192.  
  193. Procedure Erase(X, Y, n : Integer);
  194. Const
  195.  Blank : String[1] = ' ';
  196. Begin
  197.  GoToXY(X, Y);
  198.  Write(Blank:n);     {Writes a blank field n characters long}
  199.  GoToXY(X, Y);
  200. End;
  201.  
  202. Begin
  203.  clrscr;
  204.  gotoxy(1,10);
  205.  writeln('Welcome to the       PATTERN  MAKER');
  206.  writeln;
  207.  writeln('         Writen by   Claire A. Rinehart');
  208.  writeln('                      (c) 1985');
  209.  writeln;
  210.  Delay (5000);
  211.  GraphColorMode;
  212.  GraphWindow(0, 99, 319, 199);
  213.  GraphBackground(Black);
  214.  Palette(1);
  215.  Window(1, 1, 80, 12);
  216.  FillChar(Pat, SizeOf(Pat), 0);
  217.  Lind := 0;
  218.  GotoXY(1, Lind + 3);
  219.  For Lnum := 7 downto 0 do          {set up axis display}
  220.   Writeln(Lnum);
  221.  Write(' 01234567     01234567     01234567');
  222.  Repeat
  223.   GotoXY(1,1);
  224.   Write('CHOOSE:  ',Menu);          {set up menu}
  225.   Erase(1,2,10);
  226.   Answer(Menu,Resp,False);
  227.   Case Resp of
  228.    1 : Begin
  229.         PInd := 1;
  230.         Ind := 7;
  231.         For Lind := 0 to 7 do
  232.          Begin
  233.           Erase(1,1,40);
  234.           Write('Enter:  P = ',Pind:1,' L = ',Ind:1,'  - = Blank, 0 = Dot');
  235.           Erase(2, Lind + 3, 12);
  236.           Read(Lin[Pind,Ind]);            {get response line}
  237.           Convert;                        {convert line to decimal equivalent}
  238.           Write('=',Pat[Pind,Ind]);
  239.           Disp;
  240.           Ind := Ind - 1;
  241.          End;
  242.        End;
  243.    2 : Begin
  244.         PInd := 2;
  245.         Ind := 7;
  246.         For Lind := 0 to 7 do
  247.          Begin
  248.           Erase(1,1,40);
  249.           Write('Enter:  P = ',Pind:1,' L = ',Ind:1,'  - = Blank, 0 = Dot');
  250.           Erase(15, Lind + 3, 12);
  251.           Read(Lin[Pind,Ind]);
  252.           Convert;
  253.           Write('=',Pat[Pind,Ind]);
  254.           Disp;
  255.           Ind := Ind - 1;
  256.          End;
  257.        End;
  258.  
  259.    3 : Begin
  260.         PInd := 3;
  261.         Ind := 7;
  262.         For Lind := 0 to 7 do
  263.          Begin
  264.           Erase(1,1,40);
  265.           Write('Enter:  P = ',Pind:1,' L = ',Ind:1,'  - = Blank, 0 = Dot');
  266.           Erase(28, Lind + 3, 12);
  267.           Read(Lin[Pind,Ind]);
  268.           Convert;
  269.           Write('=',Pat[Pind,Ind]);
  270.           Disp;
  271.           Ind := Ind - 1;
  272.          End;
  273.        End;
  274.    4 : Begin                              {Change Palette}
  275.         Repeat
  276.          Erase(1, 1, 40);
  277.          Write('Enter Palette number:  ');
  278.          {$I-}
  279.          Read(PalNum);
  280.          {$I+}
  281.         Until IOresult = 0;
  282.         Palette(PalNum);
  283.        End;
  284.    5 : Begin                             {Change Color Table}
  285.         Repeat
  286.          Erase(1, 1, 40);
  287.          Write('Enter values for the Color Table (0-3).');
  288.          Erase(1,2,10);
  289.          {$I-}
  290.          Read(C0, C1, C2, C3);
  291.          {$I+}
  292.         Until IOresult = 0;
  293.         ColorTable(C0, C1, C2, C3);
  294.         GetPic(Pic,8,16,311,71);         {getpicture of graphics area and then}
  295.         PutPic(Pic,8,71);                {redisplay it so that the color table}
  296.        End;                              {will be used.}
  297.    End; {Case}
  298.  Until Resp = 6;
  299.  TextMode(C80);
  300. END.
  301.