Pro Pascal Compiler - Version iid 3.1 Compilation of: LPCOUNT.PAS Options: L 1 program LPCOUNT(input,output); 2 3 { Program to calculate promise figures from a file in Database format} 4 5 {Brian Gilmore August 1987} 6 7 8 TYPE 9 nums = ARRAY[1..2,0..10] of 0..60000; 10 {$I lptype.ins} 11 adulta = ARRAY[1..10] OF integer; 12 fsa = ARRAY[1..4] OF integer; 13 fparty = ARRAY[0..8] OF string[3]; 14 fattrn = ARRAY[0..15] OF string[15]; 15 fsname = PACKED ARRAY[1..19] OF char; 16 ffname = PACKED ARRAY[1..25] OF char; 17 fhname = PACKED ARRAY[1..5] OF char; 18 fstne = PACKED ARRAY[1..34] OF char; 19 fpcode = PACKED ARRAY[1..8] OF char; 20 s_integer = 0..60000; 21 byte = 0..255; 22 {xattr = (sa, sb, sc, sd, se, sf, sg, sh, si, sj, sk, sl, sm, sn, so, sp);} 23 xattr = 1..15; 24 sattr = SET OF xattr; 25 26 vf = RECORD 27 sname: fsname; 28 fname: ffname; 29 hname: fhname; 30 street: s_integer; 31 r_no: s_integer; 32 cvote: byte; 33 pvote: byte; 34 attr: sattr; 35 spare1, spare2: byte; 36 END; 37 38 vfp = ^vf; 39 ntfile = FILE of vf; 40 41 rf = RECORD 42 street: fstne; 43 postcode: fpcode; 44 END; 45 46 rfp = ^rf; 47 rffile = FILE of rf; 48 49 nnf = RECORD 50 sname: string [4]; 51 street: 1..30000; 52 r_no: 1..30000; 53 END; 54 nffile = FILE of nnf; 55 56 xaf = ARRAY[0..26] of 0..30000; 57 58 59 COMMON 60 final: integer; 61 nat: text; 62 party, sparty: fparty; 63 attrn: fattrn; 64 65 dbfile: ntfile; 66 rdfile: rffile; 67 ndfile: nffile; 68 69 VAR 70 vv: vfp; 71 rv: rfp; 72 x_party, t_party: nums; 73 out, source, temp, outfile: text; {source file} 74 outf, reg, filename, ofn, rfn, name: string[14]; 75 s, line, sname, add, this_add, 76 old_street, last_line, house: string[120]; 77 target, count, c_option,i,flag,dstart,rlen,lflag: integer; 78 x_now, p3, labels, addno, last_address: integer; 79 adult: adulta; 80 field_size, field_max: fsa; 81 key: char; 82 83 PROCEDURE cursor(y,x: integer); EXTERNAL; 84 PROCEDURE clearscreen; EXTERNAL; 85 PROCEDURE Clear_from_Line(n: integer); EXTERNAL; 86 PROCEDURE Clearline(n: integer); EXTERNAL; 87 PROCEDURE set_viewport(n: integer); EXTERNAL; 88 PROCEDURE reset_viewport; EXTERNAL; 89 FUNCTION get: char; EXTERNAL; 90 FUNCTION readint: integer; EXTERNAL; 91 FUNCTION getchar: integer; EXTERNAL; 92 FUNCTION getint(x, y:integer): integer; EXTERNAL; 93 94 PROCEDURE get_address(n: integer); 95 + BEGIN 96 * if last_address <> n then seek(rdfile, n); 97 * last_address := n; 98 * END; 99 + 100 PROCEDURE show_attributes; EXTERNAL; 101 PROCEDURE set_party; EXTERNAL; 102 103 FUNCTION new_street(n: integer): BOOLEAN; 104 + BEGIN 105 * get_address(dbfile^.street); 106 * if rdfile^.street <> old_street then begin 107 * new_street := true; 108 * end else new_street := false; 109 * END; 110 + 111 PROCEDURE add_this_record; 112 VAR t, p: 0..255; 113 + BEGIN 114 * t := dbfile^.cvote; p := dbfile^.pvote; 115 * x_party[1, t] := x_party[1, t]+1; 116 * x_party[2, p] := x_party[2, p]+1; 117 + 118 * t_party[1, t] := t_party[1, t]+1; 119 * t_party[2, p] := t_party[2, p]+1 120 + END; 121 + 122 PROCEDURE zero_street; 123 VAR i: integer; 124 + BEGIN 125 * for i := 0 to 10 do begin 126 * x_party[1, i] := 0; x_party[2, i] := 0; 127 * end 128 + END; 129 + 130 PROCEDURE print_stats(w: integer); 131 VAR i,j,n: integer; 132 x, y, z: real; 133 + begin 134 * for i := 1 to 8 do begin 135 * if (i<>5) and (i<>7) then write(out, x_party[w, i]:5); 136 * end; 137 * y := x_party[w,1]+x_party[w,6]+x_party[w,8]; x := 0; 138 * if y > 0 then x := (x_party[w, 1]*100)/y; {%lab} 139 * write(out, x:6:1,'%'); 140 * y := y+x_party[w,7]; 141 * x := y*100/(y+x_party[w, 0]); 142 * writeln(out, x:7:1,'%'); 143 * end; 144 + 145 PROCEDURE pr_street(q: integer); 146 VAR i, j:integer; 147 s: string[40]; 148 + BEGIN 149 * for i := 2 to 5 do begin 150 * x_party[1, 6] := x_party[1, 6]+x_party[1, i]; 151 * x_party[2, 6] := x_party[2, 6]+x_party[2, i]; 152 * end; 153 + 154 * s := old_street; 155 * if length(s) > 25 then s := copy(s, 1, 25); 156 * write(out, s); 157 * if q <> 2 then begin 158 * print_stats(1); 159 * if q = 3 then write(out,'Previous Canvass '); 160 * end; 161 * if q <> 1 then print_stats(2); 162 * if q = 3 then writeln(out); 163 * END; 164 + 165 PROCEDURE print_totals(q: integer); {q=1 - overall only} 166 VAR i,j: integer; 167 + BEGIN 168 * old_street := 'Totals '; 169 * for i := 0 to 10 do begin 170 * x_party[1, i] := t_party[1, i]; 171 * x_party[2, i] := t_party[2, i]; 172 * end; 173 * pr_street(q); 174 * END; 175 + 176 + 177 PROCEDURE add_canvas(q: integer); 178 VAR i, j, n, ad, end_f: integer; 179 key: char; 180 + BEGIN 181 * I := 1; end_f := 0; 182 * writeln(out, ' Lab Con All SNP AGT D/N %Lab %Can'); 183 * REPEAT 184 * seek(dbfile,i); 185 * read(nat, key); {test for abort request (any key hit)} 186 * if dbfile^.r_no <> i then begin 187 * end_f := 1; 188 * end else begin 189 * if dbfile^.street <> ad then begin {may be a new street} 190 * if new_street(ad) then begin {it is} 191 * if (i > 1) and (c_option>1) then pr_street(q); 192 * cursor(15,40); write('Processing:',old_street); 193 * old_street := rdfile^.street; zero_street; 194 * end; 195 * ad := dbfile^.street; 196 * end; 197 * add_this_record; 198 * end; 199 * i := i+1; 200 * UNTIL (end_f > 0) OR (key<>chr(0)); 201 * cursor(10,0); write('Last Register Number:', dbfile^.r_no); 202 * print_totals(q); 203 * END; 204 + 205 PROCEDURE count_options; 206 VAR i,j,n: integer; 207 + BEGIN 208 * REPEAT 209 * clearscreen; writeln('Total Canvas Results'); 210 * cursor(2, 0); writeln(' 0 - Main Menu'); 211 * cursor(4, 0); writeln(' 1 - Count Current Canvas'); 212 * cursor(6, 0); writeln(' 2 - Count Previous Canvas'); 213 * cursor(8, 0); writeln(' 3 - Count BOTH'); 214 * cursor(22,0); write('Action (0-3)?'); j := getint(22,13); 215 * if (j<0) or (j>3) then begin 216 * cursor(23,0);write('Please re-enter'); 217 * end else begin 218 * case j OF 219 * 0: ; 220 * 1: add_canvas(j); 221 * 2: add_canvas(j); 222 * 3: add_canvas(j); 223 + end; 224 * end; 225 * UNTIL (j>=0) and (j<=3); 226 * clearscreen; 227 * END; 228 + 229 PROCEDURE Main_menu; 230 VAR i,j: integer; 231 + BEGIN 232 * set_viewport(1); 233 * REPEAT 234 * cursor(2,0); writeln('Main Menu'); 235 * cursor(4,0); writeln(' 0 - Exit Program'); 236 * cursor(6,0); writeln(' 1 - Total Canvas Results - overall'); 237 * cursor(8,0); writeln(' 2 - Total Canvas Results - per street'); 238 * cursor(10,0);writeln(' 3 - Extract Attribute Information'); 239 + 240 * cursor(22,0); write('Action (0-3)?'); {j := getchar-ord('0');} 241 * j := getint(22, 13); 242 * clearline(24); 243 * CASE j of 244 * 0: ; 245 * 1: begin c_option := j; Count_options; end; 246 * 2: begin c_option := 2; Count_options; end; 247 * 3: ; 248 + END; 249 * UNTIL j = 0; 250 * END; 251 + 252 + BEGIN 253 * set_party; 254 * writeln; writeln; 255 * write('Register Name?'); readln(ofn); 256 * rfn := concat('B:',ofn,'.STR'); 257 * ofn := concat('B:',ofn,'.DAT'); 258 * i := 0; 259 * REPEAT 260 * write('Output to Printer or File (P or F)?'); readln(s); 261 * if s='p' then s := 'P'; if s = 'f' then s := 'F'; 262 * if (s<>'F') and (s<>'P') then begin 263 * writeln('P or F please!'); 264 * i := 1; 265 * end; 266 * UNTIL i=0; 267 + 268 * clearscreen; 269 * write('Canvass Totals Package'); 270 * if s = 'F' then begin 271 * outf := 'm:lpout'; cursor(0, 40); writeln('Output in m:lpout') 272 * end else outf := 'LST:'; 273 * assign(out, outf); rewrite(out); 274 + 275 * assign(nat, 'KBD:'); reset(nat); {get at keyboard directly} 276 * assign(dbfile, ofn); update(dbfile); 277 * assign(rdfile, rfn); update(rdfile); 278 * flag := 0; count := 1; labels := 0; 279 + 280 * cursor(0,1); writeln('Database File:', ofn); 281 + 282 * main_menu; 283 + 284 * reset_viewport; clearscreen; 285 * END.