home *** CD-ROM | disk | FTP | other *** search
/ CP/M / CPM_CDROM.iso / simtel / sigm / vols000 / vol019 / strdemo.pas < prev    next >
Pascal/Delphi Source File  |  1984-04-29  |  14KB  |  533 lines
  1. {********************************************************}
  2. {*                            *}
  3. {*  PROGRAM TITLE:    STRING Functions Demonstration    *}
  4. {*                            *}
  5. {*  WRITTEN BY:        Raymond E. Penley        *}
  6. {*  DATE WRITTEN:    27 MAY 80            *}
  7. {*                            *}
  8. {*  WRITTEN FOR:    Pascal/Z Users Group        *}
  9. {*                            *}
  10. {*  NOTE:                        *}
  11. {*     All comments about the string library are    *}
  12. {*     found in the file 'STRLIB.DOC'            *}
  13. {*                            *}
  14. {********************************************************}
  15.  
  16. PROGRAM StringDemo;
  17.  
  18. CONST
  19.   master = 'THE QUICK BROWN FOX JUMPED OVER THE LAZY BLACK DOG';
  20.   sign5 = 'This is the master string we will be using:';
  21.   space = ' ';
  22.   StrMax = 255; {maximum length of a string}
  23. (* !!!! IMPLEMENTATION DEPENDENT !!!! *)
  24.     INPUT = 0;
  25.  
  26. TYPE
  27.   alfa         = STRING 10 ;{just the right size}
  28.   string40   = STRING 40 ;{ 1/2 of default length  }
  29.   string79   = STRING 79 ;{ ONE less than default length }
  30.   string80   = STRING 80 ;{ DEFAULT length for strings }
  31.   MString    = STRING StrMax ;{ The BIG GUN }
  32. (*---Use these for the Pascal/Z supplied functins---*)
  33.   $STRING0   = STRING 0 ;
  34.   $STRING255 = STRING Strmax ;
  35.  
  36. VAR
  37.   error  : Boolean; {---required for the STRING Library---}
  38.  
  39. (*---Required for Pascal/Z supplied string functins---*)
  40. FUNCTION LENGTH(X: $STRING255): INTEGER; EXTERNAL;
  41. FUNCTION INDEX(X,Y :$STRING255): INTEGER; EXTERNAL;
  42. PROCEDURE SETLENGTH(VAR X :$STRING0; Y :INTEGER); EXTERNAL;
  43. (*----------------------------------------------------*)
  44.  
  45.  
  46. (************************************************)
  47.  
  48.  
  49. Function UCase(ch : char) : char;
  50. (*---Returns an uppercase ASCII character---*)
  51. begin
  52.   If ch IN ['a'..'z'] then
  53.     UCase := CHR(ORD(ch) -32)
  54.   Else
  55.     UCase := ch
  56. end;
  57.  
  58. (************************************************)
  59.  
  60.  
  61.     {---------------------------------------}
  62.     {        STRLIB LIBRARY        }
  63.     {---------------------------------------}
  64.  
  65. PROCEDURE PRINT( A : MString);
  66. VAR
  67.   I : 1..StrMax;
  68. begin
  69.   If (LENGTH(A) > 0) and (LENGTH(A) <= StrMax) then
  70.     For I:= 1 to LENGTH(A) do
  71.     write(A[ I ])
  72.   Else
  73.     Write(space)
  74. end;
  75.  
  76.   (*********************************************)
  77.  
  78.  
  79. PROCEDURE COPY( {    TO     } VAR dest : string80 ;
  80.         {   FROM    } THIS : MSTRING ;
  81.         {STARTING AT} POSN : INTEGER ;
  82.         {# OF CHARS } LEN  : INTEGER ) ;
  83. {  COPY(NEW_NAME, NBUF, NAME_ADDR, NAME_LEN);    }
  84. {  COPY(A_STRING, A_STRING, 5, 5);        }
  85. {GLOBAL
  86.   StrMax = 255;
  87.   MSTRING = STRING StrMax;            }
  88. LABEL    99;
  89. CONST    line_length = 80 ;
  90. VAR    ix   : 1..StrMax;
  91. begin
  92.   SETLENGTH(dest,0);  {length returned string=0}
  93.   If (len + posn) > line_length then{exit}goto 99;
  94.   IF ((len+posn-1) <= LENGTH(this)) and
  95.      (len > 0) and (posn > 0) then
  96.      FOR ix:=1 to len do
  97.          APPEND(dest, this[posn+ix-1]);
  98. 99: {Any error returns dest with a length of ZERO.}
  99. End{of COPY};
  100.  
  101.   (*********************************************)
  102.  
  103.  
  104. PROCEDURE CONCAT({New_String} VAR C : string80 ;
  105.          {Arg1_str  }     A : Mstring ;
  106.          {Arg2_str  }     B : Mstring );
  107. {  CONCAT(New_string, Arg1, Arg2);   }
  108. CONST
  109.   line_length = 80;
  110. VAR
  111.   ix : 1..StrMax;
  112. begin
  113.   SETLENGTH(C,0);
  114.   If (LENGTH(A) + LENGTH(B)) <= line_length then
  115.     begin
  116.     APPEND(C,A);
  117.         APPEND(C,B);
  118.     end;
  119.   {If error then returns length of new_string=0}
  120. End{of CONCAT};
  121.  
  122.   (*********************************************)
  123.  
  124.  
  125. PROCEDURE REPLACE(VAR source    : string80;
  126.           VAR dest    : string80;
  127.               K1    : Integer);
  128. (*
  129.  *    REPLACE(Source, Destination, Index);
  130.  *    REPLACE(Sub,Next,N);
  131.  *)
  132. CONST    line_length = 80;
  133. VAR    temp1,temp2 : Mstring;
  134.     pos, k      : 1..StrMax;
  135. begin
  136.   If (K1 > 0) and (K1 <= LENGTH(dest)) and (K1 <= line_length) then
  137.     begin (* Position 'K1' is within STRING 'dest'    *)
  138.       (* but not longer than line_length        *)
  139.       SETLENGTH(temp1,0);
  140.       SETLENGTH(temp2,0);
  141.       COPY(temp1,dest,1,K1-1);
  142.       APPEND(temp1,source);(* concatenate temp1 and A *)
  143.       k := K1 + LENGTH(source);(* extract remaining chars from dest *)
  144.       COPY(temp2,dest,k,(LENGTH(dest)-k+1));
  145.       CONCAT(dest,temp1,temp2)
  146.     end(*If*)
  147.   Else(* Issue error message and do nothing *)
  148.     Writeln('Index out of range')
  149. end(* of REPLACE *);
  150.  
  151.   (*********************************************)
  152.  
  153.  
  154.  
  155. Procedure GetLine( VAR Agr_string : string80 ;
  156.                 count : integer );
  157. (*----------------------------------------------*)
  158. (* version: 31 MAY 80 by R.E.Penley        *)
  159. (* Valid Alphanumeric chars are:        *)
  160. (* from the ASCII space - CHR(32) to the    *)
  161. (*        ASCII tilde - CHR(126)        *)
  162. (* In order to get this to work with        *)
  163. (* Pascal/Z v 3.0 I have defined a line        *)
  164. (* as a string[80]                *)
  165. (*----------------------------------------------*)
  166. (*
  167. GLOBAL    StrMax = 255;
  168.     Mstring = STRING 255;
  169.     error  : boolean; <<to be returned to caller>>
  170. *)
  171. CONST    SPACE = ' ';
  172.     a_error = 'Alphanumerics only - ';
  173.     line_length = 80;
  174. VAR    InChar : char;
  175.     CHAR_COUNT : INTEGER;
  176.     ix : 1..StrMax;
  177. begin
  178.   error := false;
  179.   SETLENGTH( Agr_string, 0 );
  180.   CHAR_COUNT := 0;
  181.   REPEAT
  182.   If (count <= line_length) AND (CHAR_COUNT < count) then
  183.     begin{start accepting chars}
  184.     READ( InChar );
  185.     If InChar IN [' ' .. '~'] then{valid char}
  186.       begin{increment CHAR_COUNT and store InChar}
  187.     CHAR_COUNT := char_count + 1 ;
  188.     APPEND( Agr_string, InChar );
  189.       end(* If *)
  190.     Else (* we have a non-acceptable character *)
  191.       begin
  192.     WRITELN(a_error);
  193.     error:=TRUE
  194.       end(* else *)
  195.     end(* If *)
  196.   Else    (*   ERROR   *)
  197.     begin (* RESET EndOfLine <EOLN> *)
  198. {}    READLN( Agr_string[ CHAR_COUNT ] );
  199.       WRITELN('Maximum of', count:4, ' characters please!');
  200.       error:=TRUE
  201.     end(* else *)
  202.   UNTIL EOLN(INPUT) or error;
  203.   If error then{return a length of zero}
  204.     SETLENGTH( Agr_string, 0 );
  205. End{of GetLine};
  206.  
  207.  
  208.     {---------------------------------------}
  209.     {        UTILITY ROUTINES        }
  210.     {---------------------------------------}
  211.  
  212. Procedure DRAW(picture : Mstring ; count : integer);
  213. VAR    ix : integer;
  214. begin
  215.   For ix:=1 to count do
  216.     WRITE(picture);
  217. end;
  218.  
  219. Procedure DELAY(timer:integer);
  220. {  DELAY(10);    will give about 1 second delay }
  221. {  DELAY(5);    will give about 0.5 second delay }
  222. {  DELAY(30);    will give about 3 second delay }
  223. CONST    factor = 172;
  224. var    ix,jx : integer;
  225. begin
  226.   for ix:=1 to factor do
  227.     for jx:=1 to timer do {dummy};
  228. end;
  229.  
  230. Function QUIRY(message : string80) : boolean ;
  231. {    Try to write a general purpose        }
  232. {    routine that gets a 'YES' or 'NO'    }
  233. {    response from the user.            }
  234. VAR    ans : string 2;
  235.     valid : boolean;
  236. begin
  237.   Repeat
  238.     valid := false;
  239.     Write(message);
  240.     readln(ans);
  241.     If ans='OK' then
  242.       begin valid := true; QUIRY := true end
  243.     Else
  244.     If ans[1] IN ['Y','y','N','n'] then
  245.       begin
  246.         valid := true;
  247.         QUIRY := ( (ans='Y') or (ans='y') )
  248.       end
  249.   Until valid{response}
  250. end{of Quiry};
  251.  
  252. Procedure CLEAR;
  253. var    ix :1..25;
  254. begin
  255.   for ix:=1 to 25 do writeln
  256. end;
  257.  
  258. Procedure SKIP(n : integer);
  259. var    ix : 0..255;
  260. begin
  261.   for ix:=1 to n do writeln
  262. end;
  263.  
  264. Procedure PAUSE;
  265. CONST    sign = 'Enter return to continue ';
  266. var    ch : char;
  267. begin
  268.   write(sign);
  269.   readln(CH)
  270. end;
  271.  
  272. Procedure HEADER( title : string80 );
  273. CONST    left_margin  = 11;
  274.     right_margin = 51;
  275.     center         = 31;
  276.     dashes         = '{---------------------------------------}';
  277. VAR    F1,    {filler left side}
  278.     F2,    {filler right side}
  279.     CL,    {center line of title}
  280.     len    {length of title}
  281.          : integer;
  282. begin
  283.   len := LENGTH(title);
  284.   CL := len DIV 2;
  285.   {If length of title is odd then increase CL by one}
  286.   If ODD(len) then CL := CL +1;
  287.   F1 := (center - CL) - left_margin;
  288.   {If length of title is even then reduce F1 by 1   }
  289.   If not ODD(len) then F1 := F1 - 1;
  290.   F2 := right_margin - (center + CL);
  291.   writeln(' ':left_margin,dashes);
  292.   writeln(' ':left_margin,'{',' ':F1,title,' ':F2,'}');
  293.   writeln(' ':left_margin,dashes);
  294. end;
  295.  
  296.     {---------------------------------------}
  297.     {    DEMONSTRATION ROUTINES        }
  298.     {---------------------------------------}
  299.  
  300. Procedure Simple_IO;
  301. VAR    line : string80;
  302.     C   : char;
  303.     again: boolean;
  304. begin
  305.   CLEAR;
  306.   writeln;writeln;
  307.   HEADER('Input/Output DEMONSTRATION');
  308.   SKIP(5);
  309.   REPEAT
  310.     WRITE('Enter one character >');
  311.     Readln(C);
  312.     WRITELN('The Char you entered was ', C);
  313.     writeln;writeln;
  314.     again := QUIRY('Again? ');
  315.   Until not again;
  316.   Repeat
  317.     Repeat
  318.       WRITELN;
  319.       WRITELN('Input a short string');
  320.       WRITELN('            <--- Max 10 char');
  321.       WRITE('>>');
  322.       GetLine(line,10);
  323.       IF NOT error THEN
  324.         begin
  325.       WRITELN;
  326.       WRITE('You entered a');
  327.       write(LENGTH(line):3, ' Character String. >');
  328.       PRINT(line);Writeln;
  329.         end;
  330.     Until not error;
  331.     writeln;writeln;
  332.     again := QUIRY('Again? ');
  333.   Until not again;
  334. End{of I/O demo};
  335.  
  336. Procedure Str_Comp;
  337. VAR    S  : string 40;
  338.     T  : string 20;
  339. begin
  340.   S := 'SOMETHING';
  341.   T := 'SOMETHING BIGGER';
  342.   CLEAR;
  343.   HEADER('STRING COMPARISONS');
  344.   SKIP(2);
  345.   writeln('First we will compare these two string variables:');
  346.   writeln('1. ',S);
  347.   writeln('2. ',T);
  348.   DELAY(20);
  349.   IF S=T THEN
  350.     WRITELN('Strings do not work very well')
  351.   ELSE
  352.     IF S > T THEN
  353.       WRITELN(S, ' is greater than ', T)
  354.     ELSE
  355.       IF S < T THEN
  356.         WRITELN(S, ' is less than ', T);
  357.   writeln;
  358.   writeln('Now to compare the variable string S against the');
  359.   writeln('literal strings ''SOMETHING'' and ''SAMETHING''');
  360.   DELAY(20);
  361.   IF S = 'SOMETHING' THEN
  362.     WRITELN(S, ' equals ', S);
  363.   IF S > 'SAMETHING' THEN
  364.     WRITELN(S, ' is greater than SAMETHING');
  365.   writeln;
  366.   PAUSE;
  367.   writeln;
  368.   writeln('The same test but with extra blanks in the literal string');
  369.   DELAY(10);
  370.   IF S = 'SOMETHING               ' THEN
  371.     WRITELN('BLANKS DON''T COUNT')
  372.   ELSE
  373.     WRITELN('BLANKS APPEAR TO MAKE A DIFFERENCE');
  374.   writeln;
  375.   writeln('Now to change the variable strings:');
  376.   writeln('1.  S := ''XXX''');
  377.   writeln('2.  T := ''ABCDEF''');
  378.   S := 'XXX' ;
  379.   T := 'ABCDEF' ;
  380.   DELAY(20);
  381.   IF S > T THEN
  382.     WRITELN(S, ' is greater than ', T)
  383.   ELSE
  384.     WRITELN(S, ' is less than ',T);
  385.   writeln;writeln;
  386.   PAUSE;
  387. End{of Str_Comp};
  388.  
  389. Procedure Copy_demo;
  390. (* global
  391.     master : string80; *)
  392. CONST    sign1 = 'First - Enter the starting position in the main string';
  393.     sign2 = 'Next - Enter the number of chars to copy';
  394. VAR    sub     : string 80;
  395.     again     : boolean;
  396.     start,
  397.     count     : INTEGER;
  398. begin
  399.   CLEAR;
  400.   HEADER('STRING COPY');
  401.   writeln;writeln;
  402.   WRITELN(sign5);
  403.   Repeat
  404.     WRITELN;
  405.     WRITELN(master);
  406.     writeln;writeln;
  407.     Writeln(sign1);
  408.     WRITE(' >'); Readln(start);
  409.     Writeln(sign2);
  410.     write(' >'); Readln(count);
  411.     WRITELN;
  412.     COPY(SUB,master,start,count);
  413.     write('The substring = ');WRITELN(SUB);
  414.     writeln;writeln;
  415.     again := QUIRY('Again? ');
  416.   Until not again;
  417. End{of Copy_demo};
  418.  
  419. Procedure C_cat_demo;
  420. VAR    strg1,strg2,
  421.     sub    : string 80;
  422.     again    : boolean;
  423. begin
  424.   CLEAR;
  425.   HEADER('CONCATENATION DEMONSTRATION');
  426.   writeln;writeln;
  427.   Repeat
  428.     writeln;writeln;
  429.     writeln('Now to CONCAT two strings');
  430.     writeln('Enter a short string');
  431.     GetLine(strg1,40);
  432.     writeln('Enter another short string');
  433.     GetLine(strg2,40);
  434.     CONCAT(sub,strg1,strg2);
  435.     writeln(SUB);
  436.     writeln;writeln;
  437.     again := QUIRY('Again? ');
  438.   Until not again;
  439. end{of C_cat_demo};
  440.  
  441. Procedure Replc_demo;
  442. CONST    sign1 = 'First - give me a short string within the master';
  443. VAR    pattern,
  444.     work     : string80;
  445.     pos     : integer;
  446.     again     : boolean;
  447. begin
  448.   CLEAR;
  449.   HEADER('Position & Replace demo');
  450.   writeln;writeln;
  451.   WRITELN(sign5);
  452.   Repeat
  453.     work := master;
  454.     WRITELN;
  455.     WRITELN(work);
  456.     writeln;writeln;
  457.     Writeln(sign1);
  458.     WRITE(' >');
  459.     Readln(pattern);
  460.     pos := INDEX(work,pattern);
  461.     writeln('The position of ',pattern,' is : ',pos);
  462.     writeln;
  463.     writeln('Now to replace `BROWN` with `APPLE`');
  464.     writeln;
  465.     pattern := 'APPLE';
  466.     pos := INDEX(work,'BROWN');
  467.     REPLACE(pattern,work,pos);
  468.     writeln(work);
  469.     writeln;
  470.     writeln('Finally to replace `LAZY BLACK DOG`');
  471.     writeln;
  472.     pattern := 'SLOW TURTLE';
  473.     pos := INDEX(work,'LAZY');
  474.     REPLACE(pattern,work,pos);
  475.     writeln(work);
  476.     writeln;writeln;
  477.     again := QUIRY('Again? ');
  478.   Until not again;
  479. End{of Replc_demo};
  480.  
  481. Procedure SIGNON;
  482. var    ix : integer;
  483. begin
  484.   For ix := 1 to 2 do
  485.     begin DRAW('*',72);writeln end;
  486.   DRAW('*',4);DRAW(' ',64);DRAW('*',4);writeln;
  487.  
  488.   DRAW('*',4);
  489.   WRITE(' ':22, 'STRING DEMONSTRATION',' ':22);
  490.   DRAW('*',4);writeln;
  491.  
  492.   DRAW('*',4);DRAW(' ',64);DRAW('*',4);writeln;
  493.   For ix := 1 to 2 do
  494.     begin DRAW('*',72);writeln end;
  495. end{of signon};
  496.  
  497. Procedure Wrap_up;
  498. begin
  499.   CLEAR;
  500.   HEADER('=*= Pascal/Z is good! =*=');
  501.   writeln;writeln;
  502.   writeln('That concludes the demonstration');
  503.   writeln('You are invited to look over this Pascal program.');
  504.   writeln('There are many procedures and functions that should');
  505.   writeln('be included in your library.');
  506.   writeln('If you have any questions or can make any improvements');
  507.   writeln('please send them to the:');
  508.   writeln;
  509.   writeln(' ':12,'===/');
  510.   writeln(' ':12,'  /    USERS GROUP');
  511.   writeln(' ':12,' /========================');
  512.   writeln(' ':12,'7962 Center Parkway');
  513.   writeln(' ':12,'Sacramento, CA.  95823');
  514.   SKIP(5);
  515. end{of wrap_up};
  516.  
  517.     {---------------------------------------}
  518.     {    MASTER CONTROL PROGRAM        }
  519.     {---------------------------------------}
  520.  
  521. Begin{main program}
  522.   CLEAR;
  523.   SIGNON;
  524.   SKIP(10);
  525.   DELAY(40);{4 seconds delay};
  526.   Simple_IO;
  527.   Str_Comp;
  528.   Copy_demo;
  529.   C_cat_demo;
  530.   Replc_demo;
  531.   Wrap_up;
  532. End{of Demonstration}.
  533.