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
/
PROGRAMS
/
LIST
/
MSIGNS12.ARK
/
GSIGNS12.SRC
< prev
Wrap
Text File
|
1986-12-24
|
26KB
|
743 lines
PROGRAM GSigns;
{******************************************************************************
**
** Robert W. Bloom
**
** Function: This program reads input from the terminal and creates signs.
** The sign can be either horizontal or vertical in a number of
** formats. The file CHARS.DAT is used to read the fonts of the
** input characters.
**
** Notes: This is a generic Pascal version of Signs.
** See Signs.DOC for more information
**
*****************************************************************************}
CONST
Date = '30 Apr 86'; {date of last revision of this prog}
MaxHeight = 12; {10 plus 2 for desenders}
MaxWidth = 10; {actual character may be smaller}
MaxLength = 220; {max number of characters on a output line}
{ TRUNC(16.5cpi * 14" line) }
TYPE
CHARREC = RECORD {record type used for random access}
character : CHAR; {the character}
width : INTEGER; {how wide is it}
height : INTEGER; {how high}
pic : ARRAY[1..MaxHeight,1..MaxWidth] OF CHAR
END; {record} {its 'picture'}
FFTYPE = FILE OF CHARREC;
S80 = STRING[80]; {for input}
SIGNARRAY = ARRAY[1..MaxHeight,1..MaxLength] OF CHAR;
VAR
fontfile : FFTYPE;
infile,outfile : TEXT;
availchars : INTEGER; {width of output device}
chrrec : CHARREC; {global's easier than passing pointers!}
fontfn : STRING[14]; {global problem parameters}
signtype : (sign,banner);
blocktype : (letter,overstrike);
osstrng : STRING[10];
multw : INTEGER;
multh : INTEGER;
inputdevice : (keyboard,textfile);
infn : STRING[14];
numcopies : INTEGER;
outputdevice : (screen,recdfile);
outfn : STRING[14];
devicesize : (wide,normal);
givenoffset : INTEGER;
givenwidth : INTEGER;
centering : (yes,no);
{************************* Procedures called: ********************************}
EXTERNAL PROCEDURE @HLT;
PROCEDURE main; FORWARD;
PROCEDURE menu; FORWARD;
PROCEDURE askparameters(VAR ffopen : BOOLEAN); FORWARD;
FUNCTION outputparameters : BOOLEAN; FORWARD;
PROCEDURE calcavailch; FORWARD;
PROCEDURE outsign (VAR inpline : S80); FORWARD;
PROCEDURE outbanner (VAR inpline : S80); FORWARD;
FUNCTION checksign (inpline : S80;
VAR actualwidth : INTEGER;
VAR outarray : SIGNARRAY) : BOOLEAN; FORWARD;
PROCEDURE findrec (inp : S80;
position : INTEGER); FORWARD;
PROCEDURE outchar (ochar : CHAR); FORWARD;
{************************* Start of Program ****************************}
PROCEDURE main;
{******************************************************************************
** Purpose: puts entry into input line or takes appropriate branch
******************************************************************************}
LABEL 1;
VAR ans : CHAR;
textinput : S80;
done,ffopen : BOOLEAN;
result,lcv : INTEGER;
BEGIN
fontfn := 'GChars.Dat'; {initialize parameters}
signtype := sign;
blocktype := letter;
osstrng := 'IMW';
multw := 1;
multh := 1;
inputdevice := keyboard;
infn := 'Signs.in';
numcopies := 1;
outputdevice := screen;
outfn := 'Signs.Out';
devicesize := normal;
givenoffset := 0;
givenwidth := 0;
centering := yes;
done := FALSE;
ffopen := FALSE;
WHILE NOT done DO BEGIN
menu;
WRITE('Entry -->');
READLN(ans);
CASE ans OF
'?' : WRITELN; {redisplay menu}
'p','P' : BEGIN {change parameters}
askparameters(ffopen);
END;
'x','X' : BEGIN {quit}
WRITELN('<done>');
done := TRUE
END;
'i','I' : BEGIN {input a line}
WRITE('enter input line to signize -->');
READLN(textinput);
IF LENGTH(textinput) = 0 THEN GOTO 1;
IF NOT ffopen THEN BEGIN
calcavailch;
ASSIGN(fontfile,fontfn);
RESET(fontfile);
ffopen := TRUE;
END; {if font file isn't open yet}
IF inputdevice = textfile THEN
FOR lcv := 1 TO numcopies DO BEGIN
WHILE NOT EOF(infile) DO BEGIN
READLN(infile,textinput);
IF signtype = sign THEN
outsign(textinput)
ELSE
outbanner(textinput)
{if sign}
END; {while not eof}
RESET(infile)
END {for each copy wanted}
ELSE
IF signtype = sign THEN
outsign(textinput)
ELSE
outbanner(textinput);
{if sign}
{if input from file}
WRITELN;
END; {process line}
ELSE WRITELN('That''s not an option!');
END {case}
END; {while not done}
1: IF ffopen THEN CLOSE(fontfile,result);
IF outputdevice = recdfile THEN CLOSE(outfile,result);
IF inputdevice = textfile THEN CLOSE(infile,result)
END; {PROCEDURE main}
PROCEDURE outsign;
{******************************************************************************
** Arguments: (VAR inpline : S80);
** Purpose: given a input line, outputs it in sign form
******************************************************************************}
VAR pageoffset,pgoslcv : INTEGER;
widthlcv,heightlcv,multhlcv : INTEGER;
strikes,oslcv : INTEGER;
outarray : SIGNARRAY; {'Sign' output line is built into this}
linewidth : INTEGER;
overflowerr : BOOLEAN;
ochar : CHAR;
BEGIN
overflowerr := checksign(inpline,linewidth,outarray);
IF (NOT overflowerr) OR (inputdevice = textfile) THEN BEGIN
IF centering = yes THEN
pageoffset := ROUND((availchars - linewidth) / 2)
ELSE
IF overflowerr THEN
pageoffset := 0
ELSE
pageoffset := givenoffset;
{if overflow}
{if centering}
IF (outputdevice <> screen) OR (inputdevice = keyboard) THEN BEGIN
WRITELN('Available line width -> ',availchars:1);
WRITELN('Actual width of line -> ',linewidth:1);
WRITELN('Added leading spaces -> ',pageoffset:1)
END;
IF blocktype = overstrike THEN
strikes := LENGTH(osstrng)
ELSE
strikes := 1;
{end if}
FOR heightlcv := 1 TO MaxHeight DO {output line}
FOR multhlcv := 1 TO multh DO BEGIN
FOR oslcv := 1 TO strikes DO BEGIN
FOR pgoslcv := 1 TO pageoffset DO outchar(' ');
FOR widthlcv := 1 TO linewidth DO BEGIN
IF (blocktype = overstrike) AND
(outarray[heightlcv,widthlcv] <> ' ') THEN
ochar := osstrng[oslcv]
ELSE
ochar := outarray[heightlcv,widthlcv];
outchar(ochar)
END; {for width}
IF (strikes <> 0) AND (strikes <> oslcv) THEN outchar(CHR(13))
END; {for overstrikes}
outchar(CHR(13));
outchar(CHR(10))
END; {for height multiplier}
{end for height}
outchar(CHR(13));
outchar(CHR(10));
inpline := '' {zero input}
END ELSE
WRITELN('Input line is too long, correct or re-enter!')
END; {PROCEDURE outsign}
PROCEDURE outbanner;
{******************************************************************************
** Arguments: (inpline : S80)
** Purpose: given an input line, outputs it in banner form
******************************************************************************}
VAR pageoffset,pgoslcv : INTEGER;
oslcv,strikes,charnum : INTEGER;
widthlcv,heightlcv : INTEGER;
multwlcv,multhlcv : INTEGER;
ochar : CHAR;
BEGIN
IF centering = yes THEN
pageoffset := ROUND((availchars - (MaxHeight * multh)) / 2)
ELSE
pageoffset := givenoffset;
IF (outputdevice <> screen) OR (inputdevice = keyboard) THEN BEGIN
WRITELN('Available line width -> ',availchars:1);
WRITELN('Actual height of line -> ',(MaxHeight*multh):1);
WRITELN('Added leading spaces -> ',pageoffset:1);
IF outputdevice <> screen THEN WRITE('processing ... ')
END;
IF blocktype = overstrike THEN
strikes := LENGTH(osstrng)
ELSE
strikes := 1;
{end if}
FOR charnum := 1 TO LENGTH(inpline) DO
IF ORD(inpline[charnum]) >= 32 THEN BEGIN {skip bad input}
findrec(inpline,charnum);
FOR widthlcv := 1 TO chrrec.width DO
FOR multwlcv := 1 TO multw DO BEGIN
FOR oslcv := 1 TO strikes DO BEGIN
FOR pgoslcv := 1 TO pageoffset DO outchar(' ');
FOR heightlcv := MaxHeight DOWNTO 1 DO
FOR multhlcv := 1 TO multh DO BEGIN
IF (blocktype = overstrike) AND
(chrrec.pic[heightlcv,widthlcv] <> ' ') THEN
ochar := osstrng[oslcv]
ELSE
ochar := chrrec.pic[heightlcv,widthlcv];
outchar(ochar)
END; {for multiplier horizontally}
{end for height}
IF (strikes <> 0) AND (strikes <> oslcv) THEN outchar(CHR(13))
END; {for overstrikes}
outchar(CHR(13));
outchar(CHR(10))
END; {for multiplier vertically}
{end for width}
outchar(CHR(13));
outchar(CHR(10))
END; {if char is in proper print range}
{end for each input char}
inpline := ''
END; {PROCEDURE outbanner}
FUNCTION checksign;
{******************************************************************************
** Arguments: (inpline : S80; VAR actualwidth : INTEGER) : BOOLEAN;
** Purpose: creates outarray for sign, checks for overflow
******************************************************************************}
LABEL 2;
VAR heightlcv,widthlcv : INTEGER;
multwlcv : INTEGER;
charnum : INTEGER;
err : BOOLEAN;
BEGIN
err := FALSE;
FOR heightlcv := 1 to MaxHeight DO
FOR widthlcv :=1 TO MaxLength DO
outarray[heightlcv,widthlcv] := ' '; {initialize line array}
IF (outputdevice <> screen) OR (inputdevice = keyboard) THEN
WRITE('processing ... ');
actualwidth := 1;
FOR charnum := 1 TO LENGTH(inpline) DO {build line}
IF ORD(inpline[charnum]) >= 32 THEN BEGIN {skip bad input}
findrec(inpline,charnum);
IF (outputdevice <> screen) OR (inputdevice = keyboard) THEN
WRITE(chrrec.character);
IF (actualwidth+(chrrec.width*multw)) > availchars THEN BEGIN
WRITELN('<- overflow!',CHR(7));
err := TRUE;
GOTO 2
END; {if overflow}
FOR widthlcv := 1 TO chrrec.width DO
FOR multwlcv := 1 TO multw DO BEGIN
FOR heightlcv := 1 TO chrrec.height DO
outarray[heightlcv,actualwidth] :=
chrrec.pic[heightlcv,widthlcv];
{end for height}
actualwidth := actualwidth + 1
END; {for width multiplier}
{end for width of char}
actualwidth := actualwidth + 1 {one space between chars}
END; {if char in in printing range}
{end for each input char}
IF givenoffset <> 0 THEN BEGIN
IF (actualwidth + givenoffset) > availchars THEN BEGIN
WRITELN('<- Overflow of available space due to given offset!',CHR(7));
err := TRUE
END {if the given offset overflows}
END; {if given the offset, check for overflow}
2: WRITELN;
checksign := err
END; {PROCEDURE checksign}
PROCEDURE menu;
{******************************************************************************
** Arguments: none
** Purpose: contains menu of command line options
******************************************************************************}
BEGIN
WRITELN(' P - To review and/or change parameters');
WRITELN(' ? - To display this menu');
WRITELN(' X - To exit program');
WRITELN(' I - To process a input line');
WRITELN
END;
PROCEDURE findrec;
{******************************************************************************
** Arguments: (inp : S80; position : INTEGER);
** Purpose: puts a picture into the global record variable 'chrrec'
******************************************************************************}
VAR searchchar : CHAR;
recnumber : INTEGER;
BEGIN
searchchar := inp[position];
recnumber := ORD(searchchar) - 32;
SEEKREAD(fontfile,recnumber);
chrrec := fontfile^
END;
PROCEDURE outchar;
{******************************************************************************
** Arguments: (ochar : CHAR)
** Purpose: outputs a character to appropriate device
******************************************************************************}
BEGIN
CASE outputdevice OF
recdfile : WRITE(outfile,ochar);
screen : WRITE(ochar)
END {case}
END; {procedure outchar}
PROCEDURE calcavailch;
{******************************************************************************
** Arguments: none
** Purpose: calculates the available space for output
******************************************************************************}
VAR pitch : REAL;
BEGIN
IF givenwidth = 0 THEN BEGIN
IF devicesize = wide THEN
availchars := 132
ELSE
availchars := 80
END ELSE
availchars := givenwidth
{if width was not given}
END; {procedure calcavailch}
PROCEDURE optx(VAR ok,done,outfopen,ffopen : BOOLEAN;VAR oldof,oldff : STRING);
VAR result : INTEGER;
BEGIN
IF ok THEN BEGIN
calcavailch;
done := TRUE;
IF outfopen AND (outputdevice <> recdfile) THEN
CLOSE(outfile,result);
{end if no more file output}
IF NOT outfopen AND (outputdevice = recdfile) THEN BEGIN
ASSIGN(outfile,outfn); {start file output}
REWRITE(outfile);
outfopen := TRUE;
END; {if new file output}
IF outfopen AND (outputdevice = recdfile) AND
(outfn <> oldof) THEN BEGIN {change output file}
CLOSE(outfile,result); {close old file}
ASSIGN(outfile,outfn);
REWRITE(outfile) {open new file}
END; {if file output was changed}
IF (oldff <> fontfn) OR NOT ffopen THEN BEGIN
ASSIGN(fontfile,fontfn);
RESET(fontfile);
ffopen := TRUE
END; {if font filename was changed}
IF inputdevice = textfile THEN BEGIN
ASSIGN(infile,infn);
RESET(infile);
END {if input from file}
END ELSE
WRITELN('Banner is too big to fit on output!');
{END}
END;
PROCEDURE optf;
VAR strngans : STRING[13];
BEGIN
WRITELN('The font file contains the definitions for all characters');
WRITELN('It is created with ''MAKEFONT'' from a ASCII file.');
WRITE('Enter FileName of Font File -> ');
READLN(strngans);
IF strngans <> '' THEN fontfn := strngans
END;
PROCEDURE opts;
VAR charans : CHAR;
BEGIN
WRITELN('One can format signs horizontally across page or');
WRITELN('banners vertically down page. Do you want a');
WRITE('Sign or Banner? (S/B) -> ');
READLN(charans);
CASE charans OF
'B','b' : signtype := banner;
'S','s' : signtype := sign
END; {case}
END;
PROCEDURE optb;
VAR charans : CHAR;
BEGIN
WRITELN('The graphic characters may be made of the letter of');
WRITELN('the character itself, or blocks. Do you want to');
WRITE('print Overstrike blocks, or Letters? (L/O) -> ');
READLN(charans);
CASE charans OF
'L','l' : blocktype := letter;
'O','o' : blocktype := overstrike
END; {case}
END;
PROCEDURE optw;
VAR sizans : INTEGER;
BEGIN
WRITELN('One can make the letters of the sign or banner bigger');
WRITELN('by entering a multiplier. 2 doubles size, 3 triples, etc.');
WRITE('Enter multiplier for width -> ');
READLN(sizans);
IF sizans <> 0 THEN multw := sizans
END;
PROCEDURE opth;
VAR sizans : INTEGER;
BEGIN
WRITELN('One can make the letters of the sign or banner bigger');
WRITELN('by entering a multiplier. 2 doubles size, 3 triples, etc.');
WRITE('Enter multiplier for height -> ');
READLN(sizans);
IF sizans <> 0 THEN multh := sizans
END;
PROCEDURE optm;
VAR sizans : INTEGER;
BEGIN
WRITELN('One can enter a given left margin to position banners and');
WRITELN('signs on the paper. If zero, one can select automatic');
WRITE('centering. Enter number for left margin? -> ');
READLN(sizans);
IF sizans <> 0 THEN BEGIN
givenoffset := sizans;
centering := no
END
END;
PROCEDURE opta;
VAR charans : CHAR;
BEGIN
WRITELN('This option is active only if the given left margin is zero.');
WRITELN('Output can be centered between maximum left and right margins.');
WRITE('Should output be automatically centered N/Y? -> ');
READLN(charans);
CASE charans OF
'N','n' : centering := no;
'Y','y' : centering := yes
END {case}
END;
PROCEDURE optg;
VAR sizans : INTEGER;
BEGIN
WRITELN('If this option is non-zero it will override any of the');
WRITELN('other output size commands. One can enter a defined output');
WRITE('device size which will be used for checks and centering -> ');
READLN(sizans);
IF sizans <> 0 THEN givenwidth := sizans
END;
PROCEDURE opti;
VAR charans : CHAR;
BEGIN
WRITELN('Input can come from the keyboard which is entered');
WRITELN('one line at a time or in a bunch from a file. Do you want');
WRITE('input from the Keyboard or File K/F? -> ');
READLN(charans);
CASE charans OF
'F','f' : inputdevice := textfile;
'K','k' : inputdevice := keyboard
END {case}
END;
PROCEDURE optt;
VAR strngans : STRING[13];
BEGIN
WRITELN('This entry is only active if input is from a file.');
WRITELN('Enter filename of the text file that contains each');
WRITE('line to be output ->');
READLN(strngans);
IF strngans <> '' THEN infn := strngans
END;
PROCEDURE optn;
VAR sizans : INTEGER;
BEGIN
WRITELN('This entry is only active if input is from a file.');
WRITELN('Multiple copies are separated by formfeeds.');
WRITE('How many copies do you want? ->');
READ(sizans);
IF sizans <> 0 THEN numcopies := sizans
END;
PROCEDURE opto;
VAR charans : CHAR;
BEGIN
WRITELN('Output may be directed to either the console screen');
WRITELN('or a file. Do you want to output to');
WRITE('the Screen or a file S/F? -> ');
READLN(charans);
CASE charans OF
'F','f' : BEGIN
outputdevice := recdfile;
givenwidth := MaxLength
END;
'S','s' : outputdevice := screen
END {case}
END;
PROCEDURE optd;
VAR charans : CHAR;
BEGIN
WRITELN('Enter (N) if the output device is a');
WRITELN('80 char screen; or (W) if it is 132 char screen.');
WRITE('Is output device size Normal or Wide? (N/W) -> ');
READLN(charans);
CASE charans OF
'W','w' : devicesize := wide;
'N','n' : devicesize := normal
END {case}
END;
PROCEDURE askparameters;
{******************************************************************************
** Arguments: (VAR ffopen : BOOLEAN);
** Purpose: sets (or changes) up program parmeters
******************************************************************************}
VAR ans,charans : CHAR;
sizans : INTEGER;
strngans : STRING[14];
outfopen,done,ok : BOOLEAN;
oldof,oldff : STRING[14];
BEGIN
IF outputdevice = recdfile THEN
outfopen := TRUE
ELSE
outfopen := FALSE;
oldof := outfn;
oldff := fontfn;
done := FALSE;
ok := outputparameters;
WHILE NOT done DO BEGIN
WRITELN;
WRITE('Enter letter of option to change -> ');
READLN(ans);
CASE ans OF
'?' : ok := outputparameters;
'X','x' : optx(ok,done,outfopen,ffopen,oldof,oldff);
'F','f' : optf;
'S','s' : opts;
'B','b' : optb;
'W','w' : optw;
'H','h' : opth;
'M','m' : optm;
'A','a' : opta;
'G','g' : optg;
'I','i' : opti;
'T','t' : optt;
'N','n' : optn;
'O','o' : opto;
'D','d' : optd;
'Z','z' : @HLT;
ELSE BEGIN
WRITELN('Bad character entered, try again (''?'' for menu)');
END
END; {case}
END; {while not done}
END; {procedure askparameters}
FUNCTION outputparameters;
{******************************************************************************
** Arguments: none, returns boolean
** Purpose: displays program parameters, returns TRUE if all ok.
******************************************************************************}
VAR ans : CHAR;
ok : BOOLEAN;
BEGIN
WRITELN;
WRITELN('Options List');
WRITELN;
WRITELN('F: Font File -> ',FontFn,' ');
WRITE('S: Sign type -> ');
IF signtype = sign THEN
WRITELN('Sign ')
ELSE
WRITELN('Banner');
WRITE('B: Block/Letter type -> ');
CASE blocktype OF
letter : WRITELN('Letters ');
overstrike : WRITELN('OverStrikeBk')
END; {case}
WRITELN('W: Width Multiplier -> ',multw:1,' ');
WRITELN('H: Height Multiplier -> ',multh:1,' ');
WRITELN('M: Given left margin -> ',givenoffset:1,' ');
IF givenoffset = 0 THEN BEGIN
WRITE('A: Auto-Centering -> ');
IF centering = yes THEN
WRITELN('Yes')
ELSE
WRITELN('No ')
END;
WRITELN('G: Given Width -> ',givenwidth:1);
WRITE('I: Input Device -> ');
IF inputdevice = keyboard THEN
WRITELN('Keyboard')
ELSE BEGIN
WRITELN('File ');
END; {if}
IF inputdevice = textfile THEN BEGIN
WRITELN('T: Text FileName -> ',infn,' ');
WRITELN('N: Number of Copies -> ',numcopies:1,' ')
END;
WRITE('O: Output device -> ');
IF outputdevice = screen THEN
WRITELN('Screen ')
ELSE
WRITELN('File ');
IF givenwidth = 0 THEN BEGIN
WRITE('D: Device size -> ');
IF devicesize = normal THEN
WRITELN('Normal')
ELSE
WRITELN('Wide ')
END;
IF outputdevice = recdfile THEN BEGIN
WRITELN('R: Record Output in -> ',outfn);
END;
WRITELN('X: Exit Parameters, return to entry menu');
WRITELN('Z: Zap Program, return to operating system');
calcavailch;
WRITELN;
WRITELN('Calculated width available -> ',availchars:1,' ');
ok := TRUE;
IF signtype = sign THEN BEGIN {est based on 8+1 spaces/char}
WRITE('Approximate number of *input* characters allowed per line -> ');
WRITELN((TRUNC(availchars/(multw*(MaxWidth-1)))):1,' ')
END ELSE BEGIN
WRITELN('The given parameters require a line ',((MaxHeight *
multh) + givenoffset):1,' long.');
IF ((MaxHeight * multh) + givenoffset) > availchars THEN BEGIN
WRITELN('Error: Output will overflow the available space!');
ok := FALSE
END
END; {if sign output approx max input line}
outputparameters := ok
END; {Procedure outputparameters}
{************************** main (dummy) program *************************}
BEGIN
WRITELN('<<< program -- GSigns, ',Date,' -- started >>>');
WRITELN;
main;
WRITELN;
WRITELN('<<< program -- GSigns -- completed >>>')
END.
,Date,' -- started >>>');
WRITELN;
main;