Pro Pascal Compiler - Version zz 2.1 Compilation of: M:LPSORT.PAS Options: LNIAP 1 0000 program LPSCAN(input,output); 2 0000 3 0000 { Program to construct an index file from a file in Database format} 4 0000 5 0000 {Brian Gilmore August 1987} 6 0000 7 0000 8 0000 TYPE 9 0000 nf = RECORD 10 0000 sname: string [4]; 11 0000 street: 1..60000; 12 0000 end; 13 0000 nfa = ARRAY[0..5000] of nf; 14 0000 nfp = ^nfa; 15 0000 16 0000 iaf = ARRAY[0..5000] of 1..60000; 17 0000 18 0000 {$I lptype.ins} 19 0000 adulta = ARRAY[1..10] OF integer; 20 0000 fsa = ARRAY[1..4] OF integer; 21 0000 fparty = ARRAY[0..8] OF string[3]; 22 0000 fattrn = ARRAY[0..15] OF string[15]; 23 0000 fsname = PACKED ARRAY[1..19] OF char; 24 0000 ffname = PACKED ARRAY[1..25] OF char; 25 0000 fhname = PACKED ARRAY[1..5] OF char; 26 0000 fstne = PACKED ARRAY[1..34] OF char; 27 0000 fpcode = PACKED ARRAY[1..8] OF char; 28 0000 s_integer = 0..60000; 29 0000 byte = 0..255; 30 0000 {xattr = (sa, sb, sc, sd, se, sf, sg, sh, si, sj, sk, sl, sm, sn, so, sp);} 31 0000 xattr = 1..15; 32 0000 sattr = SET OF xattr; 33 0000 34 0000 vf = RECORD 35 0000 sname: fsname; 36 0000 fname: ffname; 37 0000 hname: fhname; 38 0000 street: s_integer; 39 0000 r_no: s_integer; 40 0000 cvote: byte; 41 0000 pvote: byte; 42 0000 attr: sattr; 43 0000 spare1, spare2: byte; 44 0000 END; 45 0000 46 0000 vfp = ^vf; 47 0000 ntfile = FILE of vf; 48 0000 49 0000 rf = RECORD 50 0000 street: fstne; 51 0000 postcode: fpcode; 52 0000 END; 53 0000 54 0000 rfp = ^rf; 55 0000 rffile = FILE of rf; 56 0000 57 0000 COMMON 58 0000 final: integer; 59 0000 nat: text; 60 0000 party, sparty: fparty; 61 0000 attrn: fattrn; 62 0000 63 0000 64 0000 65 0000 VAR 66 0000 na: nfp; 67 0000 ia: iaf; 68 0000 vv: vfp; 69 0000 dbfile: ntfile; 70 0000 rv: rfp; 71 0000 rdfile: rffile; 72 0000 out, source, temp, outfile: text; {source file} 73 0000 outf, reg, filename, ofn, rfn, name: string[14]; 74 0000 s, this_add, 75 0000 old_street: string[120]; 76 0000 target, count, p1, p2, lno,vkey,row,col,spt,i,flag,dstart,rlen,lflag: integer; 77 0000 max, last_address: integer; 78 0000 adult: adulta; 79 0000 field_size, field_max: fsa; 80 0000 key: char; 81 0000 82 0000 FUNCTION memavail: integer; EXTERNAL; 83 0000 84 0000 PROCEDURE cursor(y,x: integer); EXTERNAL; 85 0000 PROCEDURE clearscreen; EXTERNAL; 86 0000 PROCEDURE Clear_from_Line(n: integer); EXTERNAL; 87 0000 PROCEDURE Clearline(n: integer); EXTERNAL; 88 0000 PROCEDURE set_viewport(n: integer); EXTERNAL; 89 0000 PROCEDURE reset_viewport; EXTERNAL; 90 0000 FUNCTION get: char; EXTERNAL; 91 0000 FUNCTION readint: integer; EXTERNAL; 92 0000 FUNCTION getchar: integer; EXTERNAL; 93 0000 FUNCTION getint(x, y:integer): integer; EXTERNAL; 94 0000 95 0000 PROCEDURE get_address(n: integer); 96 0000 BEGIN 97 0000 if last_address <> n then seek(rdfile, n); 98 002A last_address := n; 99 0038 END; 100 003E 101 003E PROCEDURE show_attributes; EXTERNAL; 102 003E PROCEDURE set_party; EXTERNAL; 103 003E 104 003E FUNCTION new_street(n: integer): BOOLEAN; 105 003E BEGIN 106 003E get_address(dbfile^.street); 107 0062 if rdfile^.street <> old_street then begin 108 007D new_street := true; 109 0086 end else new_street := false; 110 0091 END; 111 009A 112 009A PROCEDURE read_file; 113 009A LABEL 1; 114 009A VAR i, j, n: integer; 115 009A s: string[40]; 116 009A BEGIN 117 009A FOR i := 1 to 5000 do begin 118 00BA seek(dbfile, i); 119 00CC if i <> dbfile^.r_no then goto 1; 120 00F4 s := copy(dbfile^.sname, 1, 4); 121 0119 na^[i].sname := s; 122 014B na^[i].street := dbfile^.street; 123 0185 END; 124 0198 1: max := i; 125 01A6 END; 126 01AC 127 01AC PROCEDURE construct_index; 128 01AC VAR i,j,n: integer; 129 01AC key: char; 130 01AC BEGIN 131 01AC read_file; 132 01BC for i:= 1 to max do ia[i] := i; 133 0211 134 0211 j := max; 135 021F REPEAT 136 0224 j := j-1; 137 0234 count := 0; 138 0244 FOR i := 1 to j do begin 139 0268 if na^[ia[i]].sname > na^[ia[i+1]].sname then begin 140 02CC n := ia[i+1]; ia[i+1] := ia[i]; ia[i] := n; 141 033D count := count+1; 142 0353 end; 143 0353 end; 144 0368 cursor(25,50); write(j:5,count:5,' '); 145 03AF read(nat, key); 146 03CE UNTIL (j=1) or (count=0) or (key<>chr(0)); 147 03FF END; 148 0405 149 0405 PROCEDURE Main_menu; 150 0405 VAR i,j: integer; 151 0405 BEGIN 152 0405 set_viewport(1); 153 041D REPEAT 154 0422 cursor(2,0); writeln('Main Menu'); 155 0456 cursor(4,0); writeln(' 0 - Exit Program'); 156 049B cursor(6,0); writeln(' 1 - Contruct Name Index'); 157 04E7 cursor(8,0); writeln(' 2 - '); 158 0520 159 0520 cursor(22,0); write('Action (0-2)?'); {j := getchar-ord('0');} 160 0558 j := getint(22, 13); 161 0574 clearline(24); 162 0584 CASE j of 163 0590 0: ; 164 0592 1: construct_index; 165 059C 2: ; 166 059E END; 167 05B1 UNTIL j = 0; 168 05BC END; 169 05C2 170 05C2 BEGIN 171 05C2 set_party; 172 05D3 writeln; writeln; 173 05E4 write('Register Name?'); readln(ofn); 174 061A rfn := concat('B:',ofn,'.STR'); 175 0647 ofn := concat('B:',ofn,'.DAT'); 176 0674 177 0674 writeln(memavail); 178 068A new(na); 179 069A writeln(memavail); 180 06B0 i := 0; 181 06C0 REPEAT 182 06C5 write('Output to Printer or File (P or F)?'); readln(s); 183 0710 if s='p' then s := 'P'; if s = 'f' then s := 'F'; 184 073F if (s<>'F') and (s<>'P') then begin 185 076B writeln('P or F please!'); 186 0791 i := 1; 187 07A1 end; 188 07A1 UNTIL i=0; 189 07AD 190 07AD clearscreen; 191 07B5 write('Construct Name Index'); 192 07E1 if s = 'F' then begin 193 07F5 outf := 'm:lpout'; cursor(0, 40); writeln('Output in m:lpout') 194 0844 end else outf := 'LST:'; 195 0861 assign(out, outf); rewrite(out); 196 0882 197 0882 cursor(0,1); lno := 1; row := 1; col := 1; vkey:=0; dstart:=0; 198 08D1 old_street := ''; 199 08DB assign(nat, 'KBD:'); reset(nat); {get at keyboard directly} 200 0901 assign(dbfile, ofn); update(dbfile); 201 0922 assign(rdfile, rfn); update(rdfile); 202 0943 flag := 0; 203 0953 204 0953 cursor(0,1); writeln('Database File:', ofn); 205 0998 206 0998 main_menu; 207 09A0 208 09A0 reset_viewport; clearscreen; 209 09AB END.