-CATALOG076-CATALOGACKABSTRACT076 COMPLEX LIB# CRCKLIST076CURSOR COM4CURSOR LIB CURSOR PASEMBLED BY SIG/M, A USERS GROUP IN NEW JERSEY. le compare utility 76.37 ZCOMPAR.COM 7K / 76.38 F1.DAT 1K / 76.39 F2.DAT 1K / THIS VOLUME WAS ASSGFORM.LIB SUBMITTAL FORM (original material from Pascal Z UG volume 6) VOL.# NAME SIZE COMMENTS 76.1 COMPLEX.LIB 5K complex number utility 76.2 CURSOR.LIB 2K cursor control for SD Sales video 76.3 CURSOR.PAS 3K / 76.4 CURSOR.QQSORT COM@rstuvwxyQQSORT LIBz{|e program 76.26 RCPDAT.YYY 1K / 76.27 RCPDAT.MST 1K / 76.28 RECIPE.COM 15K / 76.29 RECIPE.PAS 20K / 76.30 SHELL.PAS 3K Pascal Shell sort 76.31 SHELL.COM 7K / 76.32 SHELL.LIB 1K / 76.33 SNOOPY81.CAL 5KF1 DATF2 DATFINDBAD COM FINDBAD MAC2 !"#$%&LONGLINECOM4'()*+,-LONGLINEPAS ./NAD4 COMF012345678NAD4 PASF9:;<=>?@ATHELLO.PAS 6K Othello - UCSD version 76.12 OTHELL1.PAS 8K / 76.13 OTHELL2.PAS 8K / 76.14 OTHELLIN.PAS 8K / 76.15 PTABLE.PAS 1K table generating demo 76.16 PTABLE.COM 8K / 76.17 PTRS2.PAS 4K pointer demo program 76.1COM 7K / 76.5 FINDBAD.MAC 7K locate bad sectors under CP/M 2.X 76.6 FINDBAD.COM 2K / 76.7 LONGLINE.PAS 2K concatenation demo 76.8 LONGLINE.COM 7K / 76.9 NAD4.PAS 9K name address data entry 76.10 NAD4.COM 9K / 76.11 O 1981 calendar 76.34 XREF.PAS 10K cross reference program 76.35 XREF.COM 14K / 76.36 ZCOMPAR.PAS 2K Pascal file compare utility 76.37 ZCOMPAR.COM 7K / 76.38 F1.DAT 1K / 76.39 F2.DAT 1K / THIS VOLUME WAS ASSCPMUG: VOLUME 76 Miscellaneous Pascal Z utilities. -CATALOG.076 CONTENTS OF CPMUG VOLUME 76 CATALOG.ACK Acknowledgement file CRCKLIST.076 Checksum of files ABSTRACT.076 Descriptive contents of volume 76 SIG/M.LIB SUBMITTAL FORM UOTHELL1 PAS:BCDEFGHIOTHELL2 PAS;JKLMNOPQOTHELLINPAS9RSTUVWXYOTHELLO PAS0Z[\]^_PTABLE COM>`abcdefgPTABLE PAShPTRS2 COM"ijklmPTRS2 PASnopq8 PTRS2.COM 5K / 76.19 QQSORT.PAS 4K Pascal - Quicker Sort 76.20 QQSORT.LIB 3K / 76.21 QQSORT.COM 8K / 76.22 QSORT.COM 7K Pascal - Sort 76.23 QSORT.PAS 3K / 76.24 QSORT.LIB 1K / 76.25 RCPDAT.XXX 2K recipSig/͠ acknowledge th contributio o th Pasca Use Grou for th following material: Ray Penley SHELL.COM/PAS/LIB QSORT.COM/PAS/LIB QQSORT.COM/PAS/LIB RECIPE.COM/PAS NAD4.COM/PAS PTRS2.COM/PAS Bob Harsch ZCOMPAR.COM/PAS these DAT files as a demo, I injected one error into the second copy. So all you have to do is type ZCOMPAR to see it work. 11. CURSOR.COM/PAS I have a SD SALES Video ata entry program. 6. PTRS2.COM/PAS Excellent updated demo for pointers. It has some interesting ideas. I couldn't let Ray do it all so I threw in this little extract. 7. LONGLINE.COM/me through again for us. He F1.DAT was trying to compare some programs but F2.DAT the first error would kill the compare. So he sat down and wrote a Pascal/Z comparascal Shell sort routine. 2. QSORT.COM/PAS/LIB A pascal Quick sort routine. 3. QQSORT.COM/PAS/LIB A pascal Quicker sort routine. 4. RECIPE.COM/PAS Latest version of the recipe program, RCPDAT.MSԠ man change plu i Charlie Foster CURSOR.COM/PAS AS/LIB QSORT.COM/PAS/LIB QQSORT.COM/PAS/LIB RECIPE.COM/PAS NAD4.COM/PAS PTRS2.COM/PAS Bob Harsch ZCOMPAR.COM/PAS generating demo. Generating a table by algorithms is quicker that looking up a table. 9. FINDBAD.COM/MAC The orginal program came from a mag but this has been heavily PAS I extracted this out of Ithaca's manual. I i dem o word bein adde togeather into lines. 8 PTABLE.COM/PAӠ ɠ modifie thi on fo tabl CONTENTS OF VOLUME #6 Ra Penle sen m anothe dis ful o goodies sur wis coul progra lik h can i fact woul b happ i coul typ i a man program a h has Anyway ther ar lot o use堠thacompareAL̠th differences, HEX,DEC,and CHAR. To run, change the two programs to compare to F1.DAT AND F2.DAT and then type ZCOMPAR. I addedmprovement fo RCPDAT.XXX Version 3.2, you will notice it has a RCPDAT.YYY much smaller COM file. 5. NAD4.COM/PAS Ray is proud of this one, it is from COMPUTER.NAD scratch. It is a NAME ADDRESS dmodified to run on CPM 2.2 and to locate the bad sectors completel ou o you way Everyon needs this one. An excellent utility. 10. ZCOMPAR.COM/PAS Bob Harsch caI fil i wha yo ca us t pul i wit you edito a th prope spot Thes thre sor program ar compare wit eac othe t giv yo a ide o their speed.(Look in the front of the PAS file for that info) 1. SHELL.COM/PAS/LIB A pabl program o thi disk Th sor routine alon mak i worth while. Thes sor routine ar se u s tha the ca b par o librar an ye b demonsrate b CO file S th PA fil i th sourc o th CO fil wherea th Lboard and wanted .LIB t us th Xcurso positionin feature. But when I tried to write it in assembly I run into some problems. So I said why not Pascal/Z.plex; var c: complex); { Cosine of a complex } var ep, em, p, m: real; begin ep := exp(z.im); em := 1.0 / ep; p := ep + em; m := em - ep; c.re := 0.5 * p * cos(z.re); c.im := 0.5 * m * sin(z.re); end { ccos }; procedure polar++++++++++++++++++++++++++++++++++++++++++++++} procedure cread(var z: complex); begin read(z.re, z.im); end; procedure cwrite(var z: complex); begin writeln('(', z.re, ',', z.im, ')'); end; function mag(var z: complex): real; { compute in advanced Pascal Programing. It is an OTHELL2.PAS excellent game with a superior algorithm OTHELLIN.PAS But,it is written in UCSD. So we need it converted..414213562373095; { square root of 2 } var vr, vi, a, b, x1, x2, y1, y2, root : real; begin vr := abs(v.re); vi := abs(v.im); root := sqrtwo * sqrt(vr) * sqrt(vi); a := vr + vi + root; b := vr + vi - root; if (a = 0.0) -Product of two complex numbers QUOTIENT -Quotient of two complex numbers CCOS -Cosine of a complex POLAR -Writing a complex into polar form CLN -Natural logarithm of a complex SIGN -Changes the sign of a complex CHECK -Checks to see if the func This is a DEMO to test the Xcontrol an th LI i th subroutine to put in your library. It works. 12. XREF.COM/PAS Ithaca Intersystems donated this to our group. var w: complex); begin w.re := u.re - v.re; w.im := u.im - v.im; end { sub }; procedure mult( a: real; z: complex; var w: complex); { Multiplies a real with a complex } begin w.re := a * z.re; w.im := a * z.im; end { ms the modulus of a complex number } begin mag := sqrt( sqr(z.re) + sqr(z.im) ); end; procedure add( u, v: complex; var w: complex); begin w.re := u.re + v.re; w.im := u.im + v.im; end { add }; procedure sub(u, v: complex; (*************************************************************** * * HERE ARE SOME MORE ITEMS FOR YOUR LIBRARY, FOR THOSE * WHO USE THESE OR ANY OTHER PORTIONS OF OUR LIBRARY ROUTINES * IT WOULD BE GREATLY APPRECIATED IF YOU WOULD SEND US YOUR * Uor (b = 0.0) then HALT('W: dividing by 0 in procedure quotient'); x1 := u.re / a; x2 := v.re / b; y1 := u.im / a; y2 := v.im / b; w.re := x1 * x2 + y1 * y2; w.im := x2 * y1 - x1 * y2; end { quotient }; procedure ccos( z: comtion argument is outside range } {++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} type complex = record re, im : real end; S$255 = string 255; PROCEDURE HALT(message: S$255);EXTERNAL; {++++++++++++++++++It is rough but look it over. 13. SNOOPY81.CAL I thought it would be nice to have a 1981 calendar. So I updated Snoopy. 14. OTHELLO.PAS This is a project for someone interested OTHELL1.PAS ult }; procedure product( u, v: complex; var w: complex); begin w.re := (u.re * v.re) - (u.im * v.im); w.im := (u.re * v.im) + (u.im * v.re); end { product }; procedure quotient( u, v: complex; var w: complex); const sqrtwo = 1nes in this library: CREAD -Enter a complex number CWRITE -Write a complex number MAG -Computes the modulus of a complex number ADD -Adds two complex numbers SUB -Subtracts two complex numbers MULT -Multiplies a real with a complex PRODUCT PDATES OR MOD'S. IN FACT, SINCE WE OFFERED OURS WHY NOT SEND * US YOURS.--editor {++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} {+ COMPLEX LIBRARY +} {++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} { Routi( u: complex; var v: complex); { Writing a complex into polar form } const halfpi = 1.570796326795; { pi / 2.0 } begin if (u.re = 0.0) and (u.im = 0.0) then HALT('W: conversion of 0 in procedure polar'); if (u.re = 0.0) and (u.im SOR .PAS CRC = B8 83 --> FILE: F1 .DAT CRC = 43 3D --> FILE: F2 .DAT CRC = F2 AE --> FILE: FINDBAD .COM CRC = 3A 96 --> FILE: FINDBAD .MAC CRC = 5A 9E --> FILE: LONGLINE.COM CRC = 50 EF --> FILE: LONGLINE.PAS CRC =sign }; procedure check(z: complex); { Checks to see if the function argument is outside range } var a, b: real; begin a := abs(z.re); b := abs(z.im); if ((a < 1.0E-5) and (b < 1.0E-5)) or ((b <> 0.0) and (b < 1.0E-5)) then be --> FILE: RECIPE .COM CRC = F1 5F --> FILE: RECIPE .PAS CRC = 36 8F --> FILE: SHELL .COM CRC = F9 BA --> FILE: SHELL .LIB CRC = D3 04 --> FILE: SHELL .PAS CRC = E6 49 --> FILE: SNOOPY81.CAL CRC = 80 E6 --> FILE: XRE<> 0) then begin v.re := mag(u); v.im := halfpi; {pi / 2.0} end else begin v.re := mag(u); v.im := arctan(u.im / u.re); end; end { polar }; procedure cln( z: complex; var c: complex); { NatLE: PTABLE .COM CRC = 7C 36 --> FILE: PTABLE .PAS CRC = 25 75 --> FILE: PTRS2 .COM CRC = 9C FC --> FILE: PTRS2 .PAS CRC = 7F 1E --> FILE: QQSORT .COM CRC = 52 30 --> FILE: QQSORT .LIB CRC = DA CC --> FILE: QQSORT .PA 44 E3 --> FILE: NAD4 .COM CRC = B2 32 --> FILE: NAD4 .PAS CRC = 33 C3 --> FILE: OTHELL1 .PAS CRC = DB D4 --> FILE: OTHELL2 .PAS CRC = 7F 77 --> FILE: OTHELLIN.PAS CRC = FC EF --> FILE: OTHELLO .PAS CRC = 50 D8 --> FIgin write('W: small argument which causes exponent error = '); cwrite(z); HALT(' '); end; if b > 50.0 then begin write('W: argument with imaginary part outside range = '); cwrite(z); HALT(' '); enF .COM CRC = 73 0A --> FILE: XREF .PAS CRC = D3 F5 --> FILE: ZCOMPAR .COM CRC = 76 2D --> FILE: ZCOMPAR .PAS CRC = 27 87 --> FILE: SIG/M .LIB CRC = C9 BE --> FILE: UGFORM .LIB CRC = DA C4  --> FILE: -CATALOG.076 CRC = 3D 71 --> FILE: -CATALOG.ACK CRC = 54 B1 --> FILE: ABSTRACT.076 CRC = 5C C7 --> FILE: COMPLEX .LIB CRC = E7 92 --> FILE: CURSOR .COM CRC = 70 D6 --> FILE: CURSOR .LIB CRC = 26 51 --> FILE: CURural logarithm of a complex } var p: complex; begin polar(z,p); c.re := ln(p.re); c.im := p.im; end { cln }; procedure sign(u: complex; var v: complex); { Changes the sign of a complex } begin v.re := -u.re; v.im := -u.im; end { S CRC = 31 B0 --> FILE: QSORT .COM CRC = 2E 34 --> FILE: QSORT .LIB CRC = E2 8E --> FILE: QSORT .PAS CRC = EC 99 --> FILE: RCPDAT .MST CRC = A3 92 --> FILE: RCPDAT .XXX CRC = 03 54 --> FILE: RCPDAT .YYY CRC = 14 15 d; end { check }; .0 then begin write('W: argument with imaginary part outside range = '); cwrite(z); HALT(' '); en*+*+w!* w##w!( F##N^ ^H^#V!{!!!!! !!!͇String too lonCall by reference precision erroIndex or value out of rangAttempted divide by zerMultiply overfloStack overfloFlo FfnV go҉| }~^(Vfn>|f(zȯF+c̹s" Nng)))V^G~ (#X(y(8 PG =BN=#F~++( 8 G =F+N=+++ݾ~8 (:0%08!B * ͋:000⯸x/Gy/Oɯ e! ͇ !T]jjZj_ZfnV^p###͖++Fwx+0w+z  z À! uType error on inpuError in input, try again 9V (-(+VV3V0ړ :ғ V3! e3)C lortnoc tih ,tiuq ot(!!9! !͝͝! >--)08 urht 1(rebmun wor RETNE ! !9!F $7$ >--)42 urht 1(rebmun nmuloc RETNE#!#!9!#'++7 >--retcarahc IICSA yna RETN4+~m!  N+! R+ hѯݾ !9#ɯ#ɯw~(4+c 6v +z55ɯݾ c! 9!7x0#fn##|###z!͇dfnpGVEe ,pOG p8xD8s(͋AV (] (Y (U (Q (M#(1_(-$(){8 [8:8 a8A8 0 W zW>( (V3 V*>fn~!9 G_~((GW>__{(+#ܯ>(#> + ٯgk9~fnating point overflow/underflo -- statement 'n f t u n f t u !1u!=1un f 1un f 1ugn1ugn 6+s !gn$!{ !gn$!{ !A(DG~ݦ (GT  DGB !9c c ! !{ Ô !  44d 4P!9w ! bʦ~ݮ w~<ݖ w !9w#+! +8 +#[+z8͋.(7e(;E(708:8> c DM#4 fnr+s+p+q@ H V3͋-(+ V394 ~+.(:e(DE(@ (85T #~0! 6+w+w+w+w hd 66=O~- O+ +~0ڦ ҦG+~ (0ڦ ҦWxGxE!!9!" 7nfnfgne3. 7j({͆gn}&|_!9N#F ~(!V+^++~+ AN+둾OyFwyHB+O#!9!O~82G>+ (<+(~<#_ !,͇/ R0Æ^`i&^&^PY^ *~+L^#~ LPFPIPNIPgi#9A N^+ ^#F ###goQ = =#F ˆ###goQ!9 PY w !!9G ᯼“ ! ͇ %Ó OfnF+p|(D0#wp8GD8BV (; (7(3 x8w+᯼O!{͇ ͆! ͇D0?6 G #qF (“ ! ͇fnqG fnp+qG!DV (- + Vgn$!{!!9  !gne3! M!9!!9Rh!!e3!! e3TSET ROSRUC SEILRAHC!!9!͝!! e3)RC tih,tset taeper ot(!!9! ͝!!x! w#!9~++!9w >ݮ w !9w !b( ! b+~ݖ ( O 8y+! +~(! R ~( !R('yG(!4+~m! 4+~m!4+~m! G!ݾ Afn( ~^(Vfnů|^ ѯݾW z() ,F̮ ̎  6  r+sFfnp|(D0n({(Vp8D8 Vw+6 +VT(t(F(f( (Ó   '!~w!M'! f n Nq! Mɹ (<D8V|pV| c.-? > կNT]F('###͖8C(?͖8:(6+++ (ˆ#w+> ###͖8(G+++ˆ ˎ#Np+y ++Nwy+!uRead beyond EO!PY98 Gy =OAO=TRUEFALSEF~+++N Ő( 8G =( +N=y(G++V^!9 z(6-+goGRw+O'd EG #~-   60 +A~8 ( W = N=++++!9ѯɯr*) C3 := CHR(X); (*integer*) C4 := CHR(Y); (*integer*) C5 := Z; (*any ASCII character*) CODE := C1; (*string it all togeather*) APPEND(CODE,C2); APPEND(CODE,C3); APPEND(CODE,C4); WRITE(CODE); (*write position to Video*) WRITE(C5); |DR?|E7R|D7R?|ERb$ɯ7~/w#~/+~w+ #~wɯ(#~+*^W#~! 0MACRO *MLIST -MOV @ MTLIST/MVI NAME 4NEG DNLIST 'NMLIST,NMTLIS.NOP p ͖ 6w+(˞###8o+++v ~ a###͒+++ˎ˞˦0 ###z+++go0 | }!uToo many open output file!uBad output file nam#}( ##|#(}#70!9G AN^designed to input the proper series of characters to the SD SALES Video Board 8024 to give XY Cursor. It needs ESC=XYZ where Z=character to print. It has a offset to worry about so this subroutine needs to take care everything. X=row, Y=column, Z=charalDirectory fulBad filename *^#~ 84 #6*6O  ^ ͆*6#~P( 4^q5 ^7~O͆#%~#?[f ###4~0#4 #4!4~0#4 #4R0 >0w+ G fnN++I| z   ͆+++~(͆###v###mYͨ>+++###`i###V(f 8###'½½+++(C^(?"!5~< #5 #5'+ ^͐ r+{PY_>_~:(DAG*>_~ > :(*5*+~jxcter *) VAR CODE : STRING 5; (*gets output to video*) C1,C2,C3,C4,C5 : CHAR; (*elements of CODE*) BEGIN Y := Y + 31; (*add offset*) X := X + 31; (*add offset*) C1 := CHR(27); (*ESC character*) C2 := CHR(61); (* = characte![~Q   76<+w_##~ >Yʽ%6#6x$^"xʚz## Ư"w#w#wäˆ++`i(  S_xDM!=()8 )0 0)+} E˸$}($0##0""L$q#s#r!(F!#6!*!!4 #4 #4!!+F&( 6##Nq+'6(***************************************************** * LIBRARY CURSOR CONTROL SUBROUTINE * written by Charlie Foster,Dec 80 ******************************************************) PROCEDURE CURSOR (X,Y : INTEGER; Z : CHAR ); (*This subroutine is 6!'+Fˆ"(w#w#w 44~0#4 #4!!4 #4 #4! 6!!%66ó)~6<(3' " ^##w! ! ! !uDisk erroError in extending filDisk fu8I!͇7L(C jO jN  jS jT  jw j8(.(w#H (#a8{0_ +++f###%(6ͨʞÑy%4³ft###"!5~< #5~< #5'"!(*can call anything here*) END;  togeather*) APPEND(CODE,C2); APPEND(CODE,C3); APPEND(CODE,C4); WRITE(CODE); (*write position to Video*) WRITE(C5); C character*) C2 := CHR(61); (* = character*) C3 := CHR(X); (*integer*) C4 := CHR(Y); (*integer*) C5 := Z; (*any ASCII character*) CODE := C1; (*string it all togeather*) APPEND(CODE,C2); APPEND(CODE,C3); APPEND(CODE,C4); WRITE(CODE): INTEGER; Z : CHAR ); (*This subroutine is designed to input the proper series of characters to the SD SALES Video Board 8024 to give XY Cursor. It needs ESC=XYZ where Z=character to print. It has a offset to worry about so this subroutine needs to test,hit CR)'); WRITELN(' ':20, '(to quit, hit control C)'); WRITELN; WRITE ('ENTER row number(1 thru 80)--> '); READLN(X); WRITE ('ENTER column number(1 thru 24)--> '); READLN(Y); WRITE ('ENTER any ASCII character--> '); READLN(Z); CUR; (*write position to Video*) WRITE(C5); (*can call anything here*) END; BEGIN (* MAIN --This is for demo purposes only *) REPEAT WRITE(CHR(26)); (* clears screen *) WRITELN(' ':20, 'CHARLIES CURSOR TEST'); WRITELN(' ':20, '(to repeat t(***************************************************** * * SD SALES 8024 XY CURSOR CONTROL PROGRAM * * This is a demo of the SD Sales video board * 8024 XY cursor control. The main procedure will * be extracted and put in my library for use in futake care everything. X=row, Y=column, Z=character *) VAR CODE : STRING 5; (*gets output to video*) C1,C2,C3,C4,C5 : CHAR; (*elements of CODE*) BEGIN Y := Y + 31; (*add offset*) X := X + 31; (*add offset*) C1 := CHR(27); (*ESSOR(X,Y,Z); READLN(CR); UNTIL Z = '&'; END. X); WRITE ('ENTER column number(1 thru 24)--> '); READLN(Y); WRITE ('ENTER any ASCII character--> '); READLN(Z); CURood first step. * * Written by Charlie Foster, Dec 80 * Donated to the Pascal/Z Users Group *****************************************************) PROGRAM XYDEMO; VAR X,Y : INTEGER; CR,Z : CHAR; PROCEDURE CURSOR (X,Y ure * programs that I write. But this prgram demonstrates * just how it works. This type of XY cusor positioning * is only good for inserting ASCII characters but the * 8024 has the ability to be programed with graphic * characters so this is a g1>2D>2C͍2B!"@-[@!> #R J!"@>2B2C͍0!0"@>2C͍-K@!0 "#B :D<2DG:@  :?Gco( x2EVERIFICATION ERROR$DISK COPIED AND VERIFIED$͊x8*x|!Ͷ |8,  ***WARNING*** System tracks bad***$͊ x8e ***Bad directory area-halting*** $͗Ͷ h&)))| }8 ]L͔͗͝,}8.$k& ^     *x0_*&:# 2# > :(w>0#w"&*$ |"$[UNUSED]BAD No bad blocks found $0|"x*zp#"z9- Can't create [UNUSED].BAD $!|"z*x| }8!>~"z͑:w<2w2A*z!I2Hw#ɯ2G9*x)))))l&]ʹ |-}Do|/  x2("&2#)))):$1>2D>2C͍2B!"@-[@!> #R J!"@>2B2C͍0!0"@>2C͍-K@!0 "#B :D<2DG:@  :?Gco( x2EVERIFICATION ERROR$DISK COPIED AND VERIFIED$1d.( K͑͞Z  :8_*###|' }(6:(k*|: c}A8^E0Z=_ 28  This version of FINDBAD requiresCP/M 2.0 or higher $ Error in command line Must be 'FINDBAD' or 'FINDBAD X:' $QwŠ:.2'? 2'ڍʍyȷ'wŠ .COMMENT \ *************************************************** * * THIS WAS ORIGINALLY UPGRADED BY RAY PENLEY * TO CPM 2.2 . * DAN LUNSFORD THEN CONVERTED IT TO Z80 AND ADDED * THAT SNEAKY USER 31 LOCATION FOR THE [UNUSED].BAD. * SO NOW WE HAVEret lpmap: defb 1,7,13,19,25,5,11,17,23,3,9,15,21 defb 2,8,14,20,26,6,12,18,24,4,10,16,22 setbd: ld hl,(dmcnt) ld de,block add hl,de ld (dmcnt),hl ld hl,(dmptr) ld (hl),b inc hl ld (dmptr),hl ret openb: ld de,bfcb push de pusdos ret vererr: ld de,vermsg jp pmsg vermsg: defb cr,lf,"This version of FINDBAD requires" defb "CP/M 2.0 or higher",cr,lf,"$" error1: ld de,ermsg1 jp pmsg ermsg1: defb cr,lf,"Error in command line" defb cr,lf,"Must be 'FINDBAD' or 'Fons or an 8080. The reserved file is made totally invisible by being relegated to USER 31, which is not accessible from the CCP, or indeed, to just about anything. Planned enhancements to this program include adaptation to disks other than fl ld de,dbase*256 ld bc,-sects cnvrtc: ld a,h or a jr nz,cnvrtt ld a,l cp sects jr c,cnvrts cnvrtt: add hl,bc inc d jr cnvrtc cnvrts: ld e,l inc e ex de,hl pop bc ret reads: push bc push hl call itoa push hl ld c,h a call bdos jp boot ibios: ld hl,(boot+1) inc hl inc hl inc hl ld de,jpvec ld bc,39 ldir ld c,versf call bdos ld a,l or a jr z,vererr ld a,(tbuff) cp 2 ret c jr z,error1 ld hl,(tbuff+2) ld a,h cp ":" jr nz,erro A SLICK WAY TO STRETCH OUR DISKS. ***************************************************** This is an adaptation of the FINDBAD program appearing in the September, 1980 issue of INTERFACE AGE magazine. This program will read a CP/M disk and isolate cp 2 jr c,chksy1 ret syserr: ld de,ermsg9 ld c,prstrf call bdos ret ermsg9: defb cr,lf,"***WARNING*** System tracks bad***$" chkdir: ld b,0 chkdi1: call readb jr nz,direrr inc b ld a,b cp bbase jr c,chkdi1 ret direrr: ld deINDBAD X:'" defb cr,lf,"$" findb: call chksys call chkdir ld b,bbase findba: call readb call nz,setbd inc b ld a,b cp maxb jr c,findba ld hl,(dmcnt) ld a,h or l ret chksys: ld hl,1 chksy1: call reads jr nz,syserr ld a,h loppys. I want to get it to handle hard disks, etc. This means messing with the disk parameter blocks. \ .z80 boot equ 0 bdos equ 5 tbuff equ 80h tracks equ 77 sects equ 26 dbase equ 2 bbase equ 2 maxb equ 241 block equ 8 deletf call settrk pop bc call setsec call dread or a pop hl pop bc push af inc l ld a,l cp sects+1 jr c,readsr ld l,1 inc h readsr: pop af ret itoa: ex de,hl ld bc,lpmap-1 ld l,e ld h,0 add hl,bc ld e,(hl) ex de,hl r1 ld a,l cp "A" jr c,error1 cp "E" jr nc,error1 and 7 dec a ld e,a ld d,0 ld c,selecf call bdos ld e,0ffh ld c,usrcdf ; save invoking user number call bdos ld (usrcde),a ld e,31 ld c,usrcdf ;set user number to 31 call bany bad sectors in a reserved file, so CP/M doesn't see them any more. The original of this program was written for CP/M V1.4, but failed under V2.0 and above. This version is EXPLICITLY for V2.2 and the Z80 and will not run under earlier versi,ermsg2 jp pmsg ermsg2: defb cr,lf,"***Bad directory area-halting***" defb cr,lf,"$" readb: call cnvrtb ld c,block readba: call reads ret nz dec c jr nz,readba ret cnvrtb: push bc ld l,b ld h,0 add hl,hl add hl,hl add hl,hill nbytes,0 endm start: ld sp,dm+1000 call ibios call findb jr z,nobad call openb call setdm call closeb call setnum nobad: ld de,endmsg pmsg: ld c,prstrf call bdos ld c,usrcdf ;restore invoking user number ld a,(usrcde) ld e,equ 19 makef equ 22 openf equ 15 selecf equ 14 closef equ 16 prstrf equ 9 usrcdf equ 32 versf equ 12 cr equ 0dh lf equ 0ah tab equ 09h fill macro nbytes,fillb .xlist rept nbytes defb fillb endm .list endm defz macro nbytes fh de ld c,deletf call bdos pop de ld c,makef call bdos pop de ld c,openf call bdos cp 255 ret nz ld de,ermsg3 jp pmsg ermsg3: defb cr,lf,"Can't create [UNUSED].BAD",cr,lf,"$" setdm: ld hl,dm ld (dmptr),hl ld hl,(dmcnt) segoR«!P!9_ Q!Q͇>OGV3+!PͥW!P! !͇ :si drow ehT ! !9!Y ͉ PC(ʢÔ :si enil ehT ! !9! [!Q!9 QU͉(dd hl,hl add hl,hl add hl,hl add hl,hl add hl,hl ld de,255 add hl,de ld l,h ld h,0 ld de,numbad call dncv ret dncv: ld b," " ld a,h or a jp p,h3 ld b,"-" ld a,l neg ld l,a ld a,h cpl jr nz,h2 inc a h2: ld h,aating point overflow/underflo -- statement !_9!!9Rh(OMED GNIRTS '!'!9!G'+[[)margorp siht dna emit a ta drow eno epyT(!(!9!() fo senil otni sdrow eht elbmessa lliw (!fz 17 endmsg: defb cr,lf,tab numbad: defb " No bad blocks found",cr,lf,"$" fnum: defb "0" dmcnt: defw 0 dmptr: defw dm dm: defz 256 jpvec: defs 39 const equ jpvec conin equ jpvec+3 conout equ jpvec+6 list equ jpvec+9 punch equ jpvec+12tdm0: ld a,h or a jr nz,gobig ld a,l cp 129 jr c,setdme gobig: ld de,-128 add hl,de push hl ld a,128 call setdme ex de,hl ld (dmptr),hl call closeb ld a,(fnum) inc a ld (fnum),a ld (bfcb+8),a call openb pop hl jr setd h3: ld (dcnvhl),hl ld a," " ld (de),a ld a,b ld (dcnvpm),a ex de,hl ld (dcnvad),hl xor a ld (dcnvfl),a ld bc,-10000 call dfl8 call dstc ld bc,-1000 call dfl8 call dstc ld bc,-100 call dfl8 call dstc ld bc,-10 call df(!9!(!!P .hcae sdrow ! !9! l[[POTS ot, $#"! ,epyT!!9!N[ go go >OGV3+ >OGV3+Pͥҫ >OGV3+$#"!!>OGV3+ reader equ jpvec+15 home equ jpvec+18 seldsk equ jpvec+21 settrk equ jpvec+24 setsec equ jpvec+27 setdma equ jpvec+30 dread equ jpvec+33 dwrite equ jpvec+36 end start m0 setdme: ld hl,(dmptr) ex de,hl ld hl,bfcb+16 ld b,16 ld (bfcb+15),a setdml: ld a,(de) ld (hl),a inc de inc hl djnz setdml ret closeb: xor a ld (bfcb+14),a ld de,bfcb ld c,closef call bdos ret setnum: ld hl,(dmcnt) a*+*+w!* w##w!( F##N .^#V!{!!!!! !!!âString too lonCall by reference precision erroIndex or value out of rangAttempted divide by zerMultiply overfloStack overfloFlol),a ld (dcnvad),hl ret dcnvfl: defb 0 dcnvhl: defw 0 dcnvad: defw 0 dcnvpm: defb 0 dfl8: ld hl,(dcnvhl) ld e,0 df1: add hl,bc bit 7,h ret nz inc e ld (dcnvhl),hl jr df1 usrcde: defb 0 bfcb: defb 0,"[UNUSED]BAD",0,0,0,0 del8 call dstc ld a,(dcnvhl) or "0" ld e,a dstc: ld hl,(dcnvad) ld a,(dcnvfl) or a jr nz,dstc3 dstc1: add a,e ld (dcnvfl),a jr nz,dstc2 ld a," " jr dstc4 dstc2: ld a,(dcnvpm) ld (hl),a dstc3: ld a,"0" or e dstc4: inc hl ld (hʢ >OGV3+$#"!!&>OGV3+goRʌ[!tiuq I ,siht fo derit ma I!!9!L[î!9N#F ~(!V+^++~+ AN+둾OyFwyHB+O#!9!O~82G>+ (<+(~<#_! uToo many open output file!*uBad output file nam#}( ##|#(}#7͈0!9G AN+ ͈ }r+sPYO>( (\3 \0Dfn~!9 G_~((GW>__{(+#ܯ>(#> + ٯgk9~+++~(###v###(rYc>+++###r`i###<^(?"!5~< #5 #5'"xz## Ư"w#w#wˆ++`i(  S_xDM!=()8 )0 0)+} E˸$}($0##0"" !9C C ! ![ t !  44D 4P!9w ! ʆ~ݮ w~<ݖ w !9w#+! +8 +#;+8!! w#!9~ͥ!~w!ͥ! f n Nq! <8\|.\| ͈i.ʢ-̩͈ʢ > կNT]F('###8C(?8:(6+++ (ˆ#w+> ###8(G+++ˆ ˎ#Np+y ++Nwy+!uRead beyond EO!f(zȯF+̟t. Nng)))V^G~ (#X(y(8 PG BN#F~++( 8 G F+N+++ݾ~8 (8 Gy OAOTRUEFALSEF~+++N Ő( 8G  *~+ڶ^#~ ʶúFʺóʺN³úgi#9A͈ N+ #ͬF ͷ###go   #ͬF ͷˆ###go !9 PY FfnV go>| }~^(Vfn>7fnw !!9G ᯼s ! ͈ +s OfnF+.|(0#w.8!8\ ( (( xOw+G #qF (s ! fnqG fnp+qG!D\ (- + \:0%08!" :000⯸"L$q#s#r!(F!#6!*!!4 #4 #4!!+F&( 6##Nq+'6p  6w+(c˞c###h8o+++v ~ ###U+++ˎ˞˦>0 ###+++go>0 | }  !9w >ݮ w !9w !( !  ~ݖ ( Oc 8y !  ~(! ͼ ~( !ͼ('yG(!4+~! 4+~!4+~! 4+~!  . ! PY9G!ݾ Afn( ~^(Vfnů7^ ѯݾ7 z() ,F̎ ̔&̧ <  r+sFfn.|(0n({(\.88 \w+6 +\T(t(F(f( (s ͸( +Ny(G++V^!9 z(6-+goGRw+O'͸͸d͸ ͸EG #~-   60 +A~8 ( W  N++++!9ѯɯR0 >0w+ G fnN++| z Á  M#4 fnr+s+p+q@ H \3-(+ \394 ~+.(:e(DE(@ (854 #~0! 6+w+w+w+w HD 66=O~- O+ +~0چ ҆G+~ (0چ ҆WxGxA(DG~ݦ (G4  DGx/Gy/Oɯ e! ͈ !T]jjZj_ZfnV^.###++Fwx+0w+z  z Æ!y uType error on inpuError in input, try again 9\ (-(+\\3\0s :s \3.(7e(;E(708:8> C D`iGOr6+++6  6 #6#(8:*>_~:(0AG0> :(*55*+Fx8I!z7cL(C O N  S T  cw 8(.(w#H (#͈a8{0_ r+++f###%(6r the Pascal/Z Users Group *****************************************************) PROGRAM longline; CONST linesize = 80; TYPE $string0 = string 0; $string255 = string 255; VAR line : STRING linesize; word : STRING 80; FUNCTION lengtr%~#?fu###<4~0#4 #4!4~0#4 #4!~һ<   76<+w_##~cr c>crcrYcr WRITE ('The word is: '); READLN (word); END; WRITELN ('The line is: '); WRITE (line); UNTIL index (word, '!"#$') <> 0; WRITELN; WRITELN ('I am tired of this, I quit!'); END. cry%4f###<"!5~< #5~< #5'"! 6!'+Fˆ"(w#w#w 44~0#4 #4!!4 #4 #4! 6!!%66)~6<(3<' one word at a time and this program', ' will assemble the words into lines of ', linesize:1,' words each.'); WRITELN; WRITELN ('Type, !"#$ ,to STOP'); setlength (word, 0); (* initialize word to 0 *) REPEAT setlength (line, 0); (* ih (X : $string255) : INTEGER; EXTERNAL; FUNCTION index (X, Y : $string255) : INTEGER; EXTERNAL; PROCEDURE setlength ( VAR X : $string0; Y : INTEGER); EXTERNAL; BEGIN WRITELN (' STRING DEMO'); WRITELN; WRITELN ('Type<'r%6#6<xcr$^r<|R?|7R|7R?|Rb$ɯ7~/w#~/+~w+ #~wɯ(#~+*(***************************************************** * * LONGLINE PROGRAM * * This program was taken out of the Pascal/Z * manual, page 56. It is a demo on using Pascal/Z * STRING functions. * * Typed/edited by Charlie Foster, Oct 1980 * fo " ^##wc!B !L !c !luDisk erroError in extending filDisk fulDirectory fulBad filename r*^#~ 84 c#6r*6O   cr*6#~P( 4^qc5 7c~O#nitialize line to 0 *) WHILE ( length (line) + length (word) < linesize ) and ( index (word, '!"#$') = 0 ) DO BEGIN APPEND (line, word); IF length (line) < linesize THEN APPEND (line, ' '); (* word space word *) ^W#~!D KLDA :LDAI WLDAR _LDAX LDD LDDR LDED [LDI LDIR LEAP LHLD *LIBFIL7LIST (LIXD *LIYD *LOAD LSPD {LXI M 0MACRO *MLIST -MOV @ MTLIST/MVI NAME 4NEG DNLIST 'NMLIST,NMTLIS.NOP *+*+w!;#*w##w!( F##Nͪ  ͪ N ^#V!{!! !!! !!! ÖString too lonCall by reference precision erroIndex or value out of rangAttempted divide by zerMultiply overfloStack overflo --(### 8; 86+++ (ˆ#w+> ### 8(G+++ˆ ˎ#Np+y ++Nwy+!WuRead beyond EO!PY9G!ݾ Afn( ~^(Vfnůo^ ѯݾTz() ,F@̫́p r+s!!9! ͵͵.. :2 ENIL SSERDDA!!9!$ ͵͵............ :YTIC!!9![ ͵͵........... :ETATS!!9! ͵͵............. :PIZ!!9! ͵͵Q!9F Q]͵ gogo!!Q!9 Q]͵ gogo!!Q!9 Q]͵ gogo!͵!Ͳ!!e3!=!e3gn !e3gn!e3! 9! %!!9 :͵!9  ͪ͵ .oN droceR gninnigeb retnE!!9!V++ͷ9 0OGV3+{goR7f n63 f nw &3 &38 ͊ &3 &3 ͊ &3 &3| ͊ &3 &3+ ͊ &3 &3 ͊ &3 statementFloating point overflow/underflo ADM TVI SOROC H19 SOL Ͳ gogo! # DROCER!!9!t!nf͵ gogo!!Q!99 Q]͵ gogo!!Q!9}u6(66666 66 66 6666666!!9!;#!9;#Rc5 !gne3 go͔͵ :ELIF !!9!   ͷ !! $!!9  Y......... :)s(EDOC!!9! ͵!Ͳw!u!u!u!ugnu6jgnu6kgnu6Rgnu6tgnu6)gnͲgn}(b! #e3! #e3ͣ! #PR#&! e3! #e3! #e3ͣޝ! #e3! #e3ͣ!!9 !Ͳ &3 &3 &3 &3 &3 &3!9N#F V+^++~+ AN+둾OyFwyHB+O#!9!O~82G>+ (<+(~<#_Ͳ!~w!Ͳ! f n Nq! f կNQT]F&3 ͊ &3 &3 ͊! Ͳ!gne3!gne3 ͵͵͵͵....... :EMAN LLUF!!9! ͵͵...... :NOITATULAS!!9! ͵͵.. :1 ENIL SSERDDA Q]͵| >OGV3+{gol"e gogo!!Q!9, Q]͵ gogo!͵ gogo!!Q!9 Q]͵ gogo!!Q!9 Q]͵ gogo!! B0!gne3! ! e3!!9 & STSIXE YDAERLA ELIF %!%!9!K %!!9 :͵! ! e3!!9 & ELIF RUOY YORTSED LLIW MARGORP SIHT %!%! 3f n f 3Vgn R)6V!gne3f n!Pgn$!÷ݾҧ!Ͳ! ͣ!!9  # DROCER!!9!!nf!! e3!!9 !͵ &3 &3 &3 &3 &3 &3 &3 &3 &3 &3 &3 &3!Ͳ!#e3! #e3ͣf ngo͔wݾYgnR(( (3 - !6 uDisk erroError in extending filDisk fulDirectory fulBad filename *^#~ 84 I"#6*6O  ͪ  ͚!I"*6#~P( 4^qI"5 ͪ 7I"~O͚!#%R0 >0w+ G fnN++J| z   ͚!>+++###00 ###ͥ ###Y8!8 O8 ( (++q+6++++++ˎ#q####Y8^/"Ͳ!+++ˎ˞˦00 ###ͥ+++go00 | }!uToo ".(7e(;E(708:8> aDM#4 fnr+s+p+q@ H 3"-(+ 394 ~+.(:e(DE(@ (85R#~0! 6+w+w+w+w [b66=O~- O+ +~0ڙ ҙG+~ (0ڙ ҙWxGxA##ݯ`iGO6# 6 #6#͕(8#AG͕0> :(*55*+Fx8 !D 7I"w ͕8(.(w#H (#I"R a8{0_ +++f###%(6I"y%4fof!9 PY FfnV go0| }~^(Vfn>of(zȯF+d̈% Fng)))V^Ny (#>( >F~+++N>+G >++ݾ~8Ëʟfn~!9 G_~((BW>__{(+#ܯ>(#> + ٯgk9~fnw ÐÐOfnF+ B88 ( ( xOw+G #qF (! fnqGfnp+qG!D (- + :hb"hPYX"h *~+ڈ"^#~ ʈ"Ì"Fʌ"Å"ʌ"N…"Ì"gi#9AR Nͪ + ͪ #`i### "^(?"!5~< #5 #5'"x4(  S_xDM!=()8 )0 0)+}many open output file!uBad output file nam#}( ##|#(}#7R 0!9G ANͪ + ͪ R }r+sPYO>xļR 0#fn##|###ĥ! d !, / R0Ú!X"h`ib"(DG~ݦ(GR DG@!9aa! !yÒ!  44b4P!9w ! ͞"ʙ~ݮ w~<ݖ w !9w#+! +8 +#N+Ͷ"8ƨ### ""!5~< #5~< #5'"! 6!'!44~0#4 #4!!4 #4 #4! 6!!%66I")~6<(3 "' " ^##wI"!  !  ! AO>G >TRUEFALSEF~+++N ( +N>y(G++G >V^!9 z(6-+goGRw+O'd EG #~-   60 +A~8 ( W > N>++++!9ѯɯ0%08!?'":000⯸x/Gy/Oɯ e! R !T]jjZj_ZfnV^BQ### ++Fwx+0w+z  z !uType error on inpuError in number, try again 9 (-(+30ڐ:Ґ3 E˸$}($0##0""L$q#s#r!(F!#6!*!!4 #4 #4!!%p   6++w+(I"˞I" >#F ˆ###g!ʹ"! w#!9~!9w >ݮ w !9w !͞"(@! ͞"~( ! ͎" ~( !͎"~ݖ (GO8y! yG(!4+~ͩ"! 4+~ͩ"!4+~ͩ"! 4+~ͩ"! ~#? P~M! "   76<+w_##~I" I">I"I"YI" "%6#6 "6_line, f7_line,f8_line, f1_col,f2_col, f3_col,f4_col, f5_col,f6_col, f7_col,f8_col: BYTE; LineDelete, { Delete line that cursor is on } LineErase, { Erase from cursor to end of line } HintOn, { Half Intensity On } L NAME +} {+ 3 ADDRESS LINE 1 < USED FOR A ONE LINE ADDRESS > +} {+ 4 ADDRESS LINE 2 < LEAVE BLANK IF ONLY 1 LINE > +} {+ 5 CITY +} {+ 6 STATE < USE POST OFFICE 2 CHAR CODES >+} {+ 7 ZIP CODE +} {+ 8 SALUTATION +} {+ 9 CODES < ANewLine = 13; {ASCII carriage return code} TYPE TermType = (ADM, TVI, SOROC, H19, SOL); BYTE = 0..255; dflt_string = string default; FID = string FileIdLength; max_string = string 255; sequence = packed array [1..2] of char; S$0 hat entry. No other editing is available +} {+ while in the program. Extensive editing must be +} {+ done outside the data entry program such as with +} {+ the word processor. +} {+ +} {+ II. TERMINATION. +} {+ When at the FULL NAMExI"$^ "|"R?|"7R|"7R?|"Rb$ɯ7~/w#~/+~w+ #~wɯ(#~+*^W#~!OG F+N ngOG F+N F+n` +} {+ per your specifications. +} {+ +} {+ MODIFICATION RECORD +} {+ SEPT 24, 80 -ADDED LIMITED EDITING CAPABILITY. +} {+ ENTERING AN ESCAPE CHAR WILL ALLOW ONE TO +} {+ REDO THAT LINE OVER AGAIN. +} {+ NOV Y TYPE OF CODES YOU REQUIRE>+} {+ 10 BLANK LINE +} {+ +} {+ +} {+ IV. INPUT/OUTPUT FILES +} {+ INPUT is from a video terminal (must have cursor +} {+ addressing) +} {+ OUTPUT FILE is an ASCII text file with file name PROGRAM NAD_ENTRY_V4; {++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} {+ PROGRAM TITLE: Name and Address Entry +} {+ version #4 +} {+ +} {+ WRITTEN BY: Raymond E. Penley +} {+ DATE WRITTEN: Sept 25, 1980 +} = string 0; S$255 = string 255; VAR bell : char; clear : char; current_record: integer; done : boolean; esc : char; filename : FID; home : char; Terminal : TermType; f1_line,f2_line, f3_line,f4_line, f5_line,f data entry item simply entering +} {+ a carriage return only will end the session, update +} {+ and close the output file. +} {+ +} {+ III. RECORD FORMAT USED. +} {+ LINE # +} {+ 1 RECORD #nn < FILLED IN BY PROGRAM > +} {+ 2 FULOG F+N+~=(ۯOG F+N+~ =(rW+sɯRɯRE 3EҠEC0EƠ ;EOFMRKEΠ 8E̠E xEԠE 6ET_EĠF FĠ -F FĠFɠLTERLFLTMSF iFԠ F /FѠ 9FԠ `F22, 80 -ADDED TELEVIDEO TERMINAL FUNCTIONS. +} {+ +} {++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} CONST Default = 80; { Default length of all strings } FileIdLength = 14; ESC_CODE = 27; {ASCII Escape code} NIES. +} {+ The program has a very limited editing capability. +} {+ Before typing the return key if an entry is not +} {+ correct then just type the ESCAPE key. This will +} {+ erase the entire line just entered. You then have to +} {+ reinput t {+ +} {+ WRITTEN FOR: A Name And Address (NAD) data entry +} {+ program. The output is written +} {+ specifically in the format that the +} {+ word processor Magic Wand uses. +} {+ +} {+ SUMMARY +} {+ I. EDITING ENTR HintOff, { Half Intensity Off } INVON, { Inverse Video On } INVOFF : sequence; { Inverse Video Off } ADDR1, ADDR2, CITY, CODES, FULLNAME, SALUTE, STATE, ZIP : DFLT_STRING; FOUT : TEXT; {$C- <<<<<] := ESC; INVON[2] := 'j'; { inverse video OFF } INVOFF[1] := ESC; INVOFF[2] := 'k'; { delete the line the cursor is on } LineDelete[1] := ESC; LineDelete[2] := 'R'; { erase from the cursor to the end of the line } LineErase[1] := EEND; END {WHILE}; UNTIL ( VALID ); END {OF QUIRY}; PROCEDURE FILLONE(VAR DONE: BOOLEAN); BEGIN PLOT(2,12);WRITELN( INVON, 'RECORD #', CURRENT_RECORD:1, ' ', INVOFF ); QUIRY(f1_line,f1_col,FULLNAME); IF ( LENGTH(FULLNAME) = 0 ) THEELN(FOUT,ADDR2) ELSE WRITELN(FOUT); WRITELN(FOUT,CITY); WRITELN(FOUT,STATE); WRITELN(FOUT,ZIP); WRITELN(FOUT,SALUTE); WRITELN(FOUT,CODES); WRITELN(FOUT); END; PROCEDURE PLOT(row, column: BYTE); { Sequence ESC + "=" + CHRITELN('CODE(s): .........'); END; PROCEDURE INIT; BEGIN Terminal := ADM; { Select the correct terminal type } BELL := CHR(7); HOME := CHR(30); { Home the cursor but do not clear the screen } CLEAR := CHR(26); { Completely clear the termi: DFLT_STRING); VAR CIX : CHAR; DONE, VALID : BOOLEAN; BEGIN PLOT(row, column); REPEAT SETLENGTH(ANSWER,0); DONE := FALSE; WHILE NOT ( DONE ) DO BEGIN KEYIN(CIX); VALID := ( ORD(CIX)<>ESC_CODE ); IF NOT ( VALI<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>} {$F- <<<<<<<<<<<<<>>>>>>>>>>>>>>>>} {$M- <<<<<<<<<<<<<>>>>>>>>>>>>>>>>} FUNCTION LENGTH(X:S$255):INTEGER;EXTERNAL; PROCE,STATE); QUIRY(f7_line,f7_col,ZIP); QUIRY(f8_line,f8_col,CODES) END END {OF FILLONE}; PROCEDURE WRITE_MASK; BEGIN WRITE( CLEAR, HOME ); WRITELN; WRITELN; WRITELN; WRITELN; WRITELN('FULL NAME: .......');WRITELN; N DONE := TRUE {EXIT(FILLONE); } ELSE BEGIN DONE := FALSE; QUIRY(f2_line,f2_col,SALUTE); QUIRY(f3_line,f3_col,ADDR1); QUIRY(f4_line,f4_col,ADDR2); QUIRY(f5_line,f5_col,CITY); QUIRY(f6_line,f6_col( LINE+31 ) + CHR( COLUMN+31 ) } BEGIN WRITE(CHR(27), CHR(61), CHR(31+row), CHR(31+column)); END; PROCEDURE EraseLine(VAR row,column: BYTE); { Erase current line from cursor to end of line } BEGIN CASE Terminal OF ADM, SOROC: BEGIN nal screen } ESC := CHR(27); {+++++++++++++++++++++++++++++++++++++++++++++++++++} {+ These string sequences pertain to the Televideo +} {+ terminal. +} {+++++++++++++++++++++++++++++++++++++++++++++++++++} { inverse video ON } INVON[1D ) THEN {REDO FROM START} BEGIN DONE := TRUE; SETLENGTH(ANSWER,0); EraseLine(row,column); END ELSE IF ( ORD(cix)=NewLine ) THEN DONE := TRUE ELSE BEGIN WRITE(CIX); APPEND(ANSWER,CIX); DURE SETLENGTH(VAR X:S$0; Y:INTEGER);EXTERNAL; PROCEDURE KEYIN(VAR C:CHAR);EXTERNAL; PROCEDURE WRITEONE; BEGIN WRITELN(FOUT,'RECORD #',CURRENT_RECORD:1); WRITELN(FOUT,FULLNAME); WRITELN(FOUT,ADDR1); IF ( LENGTH(ADDR2)>0 ) THEN WRIT WRITELN('SALUTATION: ......');WRITELN; WRITELN('ADDRESS LINE 1: ..');WRITELN; WRITELN('ADDRESS LINE 2: ..');WRITELN; WRITELN('CITY: ............');WRITELN; WRITELN('STATE: ...........');WRITELN; WRITELN('ZIP: .............');WRITELN; WR_line,f2_col); EraseLine(f3_line,f3_col); EraseLine(f4_line,f4_col); EraseLine(f5_line,f5_col); EraseLine(f6_line,f6_col); EraseLine(f7_line,f7_col); EraseLine(f8_line,f8_col); END; PROCEDURE QUIRY(VAR row, column: BYTE; VAR ANSWER PLOT(row,column); WRITE( ' ':(80-column+1) ); PLOT(row,column) END; TVI: BEGIN PLOT(row,column); WRITE( LineErase ) END END {CASE} END; PROCEDURE CLEAR_ALL; BEGIN EraseLine(f1_line,f1_col); EraseLine(f2SC; LineErase[2] := 't'; { half intensity ON } HintOn[1] := ESC; HintOn[2] := ')'; { half intensity OFF } HintOff[1] := ESC; HintOff[2] := '('; { f?_line = starting line for field n in the MASK } { f?_col = starting column for fiel].occupied AND board[square.row,square.col].adjacentsq[direc].onboard DO BEGIN square := board[square.row,square.col].adjacentsq[direc]; showpiece(square); END; (*WHILE...*) END; (*FOR direc...*) GOTOXY(9,2); WRITE(score[white]:2); GOTO flipof := black ELSE flipof := white; END; (*flipof*) PROCEDURE updatecrt(*VAR oldstatus,newstatus: gamestatus*); VAR x,y: coordinate; direc: direction; square: squareloc; PROCEDURE showpiece(square: squarE: '); READLN(FILENAME); APPEND(FILENAME,CHR(13)); RESET(FILENAME,FOUT); {++++++++++++++++++++++++++++++++++++++++++++++++++++++} {+ IF FILE ALREADY EXISTS THEN INFORM OPERATOR THAT +} {+ HE WILL DESTROY EXISTING FILE, AND TERMINATE. +} END; (*changecrtsq*) BEGIN (*showpiece*) WITH square DO IF newstatus.boardstatus[row,col].occupied THEN IF NOT oldstatus.boardstatus[row,col].occupied THEN changecrtsq(square) ELSE IF oldstatus.boardstatus[row,col].occupier <> newstatus.bld n in the MASK } f1_line := 5; f1_col := 20;{ FIELD #1 } f2_line := 7; f2_col := 20;{ FIELD #2 } f3_line := 9; f3_col := 20;{ FIELD #3 } f4_line := 11; f4_col := 20;{ FIELD #4 } f5_line := 13; f5_col := 20;{ FIELD #5 } f6_line := 15; REAL; BEGIN WITH square DO BEGIN IF newstatus.boardstatus[row,col].occupier = white THEN c := CHR(whiteascii) ELSE c := CHR(blackascii); FILLCHAR(s,3,c); crtline := (3*row) - 3; crtcol := 26 + (6*col); END; REPEAT Teloc); PROCEDURE changecrtsq(square: squareloc); CONST bell = 7; VAR s: PACKED ARRAY[1..3] OF CHAR; c: CHAR; crtline,crtcol: INTEGER; h,l: INTEGER; now: {++++++++++++++++++++++++++++++++++++++++++++++++++++++} IF NOT ( EOF(FOUT) ) THEN BEGIN WRITE( BELL ); WRITELN ( ' ':12,INVON,' FILE ALREADY EXISTS ', INVOFF ); WRITELN ( ' ':12,INVON,' THIS PROGRAM WILoardstatus[row,col].occupier THEN changecrtsq(square); END; (*showpiece*) BEGIN (*updatecrt*) WITH newstatus DO BEGIN showpiece(lastmoveloc); FOR direc := north to nw DO BEGIN square := lastmoveloc; WHILE boardstatus[square.row,square.co(************************************************************* * PART OF OTHELLO.PAS see file for details **************************************************************) FUNCTION flipof(*oldcolor: color): color*); BEGIN IF oldcolor = white THEN f6_col := 20;{ FIELD #6 } f7_line := 17; f7_col := 20;{ FIELD #7 } f8_line := 19; f8_col := 20;{ FIELD #8 } END; BEGIN{ Main program NAD entry } INIT; WRITE( CLEAR ); { OPEN FILES } SETLENGTH(FILENAME,0); WRITELN; WRITE(' FILIME(h,l); now := l; IF now < 0.0 THEN now := now + 65536.0; now := (h*65536.0) + now; UNTIL (now - lastchange) > minticks; GOTOXY(crtcol,crtline); WRITE(s); GOTOXY(crtcol,crtline+1); WRITE(s,CHR(bell)); lastchange := now; EN BEGIN CLEAR_ALL; WRITEONE; END; CURRENT_RECORD := CURRENT_RECORD + 1 UNTIL ( DONE ); WRITE( CLEAR ); END; END.{ Program NAD Entry } L DESTROY YOUR FILE ', INVOFF ); END ELSE BEGIN REWRITE( FILENAME, FOUT); WRITELN; WRITE('Enter beginning Record No. '); READLN(CURRENT_RECORD); WRITE_MASK; REPEAT FILLONE(DONE); IF NOT ( DONE ) THXY(9,3); write(score[black]:2); END; (*WITH newstatus...*) GOTOXY(0,0); END; (*updatecrt*) PROCEDURE findlegalmoves(VAR status: gamestatus; VAR legallist: movelist); VAR w DO IF direc IN dirsflipped THEN BEGIN sq := board[moveloc.row,moveloc.col].adjacentsq[direc]; REPEAT IF updateadjacent THEN FOR direc2 := north TO nw DO IF NOT (direc2 IN [direc,opposdir[direc]]) THEN BEGIN sq2 := board[sq.row,sq.col].adove(mover: color; legallist: movelist; VAR move: movedesc); VAR x,y: coordinate; xch,ych: CHAR; i,listindex: INTEGER; c: CHAR; BEGIN listindex := 0; REPEAT REPEAT GOTOXY(0,2 possible := FALSE; WITH boardstatus[x,y] DO IF NOT occupied THEN IF adjacentpieces[oppcolor] <> [] THEN BEGIN possible := TRUE; trydirs := adjacentpieces[oppcolor]; END; IF possible THEN BEGIN gooddirs := []; flips := 0; BOOLEAN*); VAR direc,direc2: direction; sq,sq2: squareloc; oppcolor: color; flips: INTEGER; emptyneighbors: SET of direction; BEGIN WITH status, move DO BEGIN lastmoveloc := moveloc; WITH borderflips + direcflips; END; END; (*IF sq.onboard...*) END; (*IF direc IN...*) IF flips > 0 THEN BEGIN movecount := movecount + 1; WITH okmove[movecount] DO BEGIN moveloc.onboard := TRUE; moveloc.row := x; moveloc.col := y; poi x,y: coordinate; sq: squareloc; flips,direcflips: INTEGER; borderflips: INTEGER; stopdirec: BOOLEAN; oppcolor: color; direc: direction; 32); UNTIL ((xch IN ['1'..'8']) AND (ych IN ['A'..'H'])); x := ORD(xch) - ORD('1') + 1; y := ORD(ych) - ORD('A') + 1; i := 1; REPEAT IF legallist.okmove[i].moveloc.row = x THEN IF legallist.okmove[i].moveloc.col = y THEN listindex := i; 3); WRITE('Enter move for ',colorword[mover],': '); GOTOXY(22,23); READ(xch,ych); IF ych IN ['1'..'8'] THEN BEGIN (*Want xy but we'll accept yx*) c := ych; ych := xch; xch := c; END; IF ych IN ['a'..'h'] THEN ych := CHR(ORD(ych)-borderflips := 0; FOR direc := north TO nw DO IF direc IN trydirs THEN BEGIN sq := board[x,y].adjacentsq[direc]; sq := board[sq.row,sq.col].adjacentsq[direc]; IF sq.onboard THEN BEGIN direcflips := 1; stopdirec := FALSE; REPEAT sqstaboardstatus[moveloc.row,moveloc.col] DO BEGIN emptyneighbors := [north..nw] - adjacentpieces[white] - adjacentpieces[black]; occupied := TRUE; occupier := nextmover; END; oppcolor := flipof(nextmover); flips := 0; FOR direc := north TO nnts := flips; dirsflipped := gooddirs; bordrsqsflipped := borderflips; END; END; END; (*IF possible...*) END; (*FOR x :=...FOR y :=...*) END; (*WITH status, legallist...*) END; (*findlegalmoves*) PROCEDURE inputmtrydirs,gooddirs: SET OF direction; possible: BOOLEAN; sqstatus: squarestatus; BEGIN WITH status, legallist DO BEGIN oppcolor := flipof(nextmover); movecount := 0; FOR x := 1 TO 8 DO FOR y := 1 TO 8 DO BEGIN i := i+1; UNTIL ((i>legallist.movecount) OR (listindex <> 0)); UNTIL listindex <> 0; move := legallist.okmove[listindex]; END; (*inputmove*) PROCEDURE makemove(*VAR status: gamestatus; VAR move: movedesc; updateadjacent: topdirec := TRUE; END; UNTIL ( stopdirec OR (NOT sq.onboard) ); IF (stopdirec AND (direcflips>0)) THEN BEGIN flips := flips + direcflips; gooddirs := gooddirs + [direc]; IF board[x,y].border AND board[sq.row,sq.col].border THEN borderflips :=tus := boardstatus[sq.row,sq.col]; IF sqstatus.occupied THEN IF sqstatus.occupier = oppcolor THEN BEGIN direcflips := direcflips + 1; sq := board[sq.row,sq.col].adjacentsq[direc]; END ELSE stopdirec := TRUE ELSE BEGIN direcflips := 0; sjacentsq[direc2]; IF sq2.onboard THEN WITH boardstatus[sq2.row,sq2.col] DO IF NOT occupied THEN BEGIN adjacentpieces[nextmover]:=adjacentpieces[nextmover] + [opposdir[direc2]]; adjacentpieces[oppcolor]:=adjacentpieces[oppcolor] - [op j := j-1; IF i <= j THEN BEGIN movetemp := okmove[i]; okmove[i] := okmove[j]; okmove[j] := movetemp; i := i+1; j := j-1; END; UNTIL i > j; IF l < j THEN sortmoves(okmove, l, j ); IF i < r THEN sortmoves(okmove, i, r ) END (* sortmoAR legallist: movelist; VAR bestmove: movedesc); TYPE movearray = ARRAY[1..30] OF movedesc; VAR bestsofar,cornmoves,m,respcornmoves: INTEGER; move,movetemp: movedesc; aftermove: score[nextmover] := score[nextmover] + flips + 1; score[oppcolor] := score[oppcolor] - flips; nextmover := oppcolor; END; END; (*makemove*) OR m := 1 TO legallist.movecount...*) movetemp := legallist.okmove[1]; legallist.okmove[1] := legallist.okmove[bestm]; legallist.okmove[bestm] := movetemp; END; (*checkposition*) PROCEDURE sortmoves(VAR okmove: movearray; posdir[direc2]]; END; END; boardstatus[sq.row,sq.col].occupier := nextmover; flips := flips + 1; sq := board[sq.row,sq.col].adjacentsq[direc]; UNTIL boardstatus[sq.row,sq.col].occupier = nextmover; END ELSE IF updateadjaallist.movecount DO WITH legallist.okmove[m], board[moveloc.row,moveloc.col] DO BEGIN bordnoncorn := FALSE; IF incenter4by4 THEN points := points + 10 ELSE BEGIN IF corner THEN BEGIN points := points + 60; cornmoves := cornmoves + 1; gamestatus; responses: movelist; PROCEDURE checkposition(VAR legallist: movelist; VAR cornmoves: INTEGER); VAR m,bestm,bestyet: INTEGER; BEGIN bestyet := -MAXINT; cornmoves := 0; FOR m := 1 TO leg  l,r: INTEGER) (*into descending order by points*) ; VAR i,j,baseval: INTEGER; BEGIN i := l; j := r; baseval := okmove[(i+j) DIV 2].points; REPEAT WHILE okmove[i].points > baseval DO i := i+1; WHILE okmove[j].points < baseval DO(************************************************************ * PART OF OTHELLO.PAS see file for details **************************************************************) PROCEDURE calcmove( mover: color; VAR status: gamestatus; Vcent THEN IF direc IN emptyneighbors THEN BEGIN sq := board[moveloc.row,moveloc.col].adjacentsq[direc]; IF sq.onboard THEN WITH boardstatus[sq.row,sq.col] DO adjacentpieces[nextmover] := adjacentpieces[nextmover] + [opposdir[direc]]; END; END ELSE IF border THEN BEGIN bordnoncorn := TRUE; points := points + 25; END ELSE IF diagnexttocorner THEN points := points - 50; END; IF points > bestyet THEN BEGIN bestyet := points; bestm := m; end; END; (*Fves *) ; PROCEDURE checkresponses(mover: color; VAR move: movedesc; VAR responses: movelist; bestsofar: INTEGER); (*$G+*) LABEL 0; VAR contingent,c,r: INTEGER; x,y: es,bestsofar); END; IF points > bestsofar THEN BEGIN bestsofar := points; bestmove := move; END; END; (*WITH move...*) END; (*FOR m := 1 TO legallist.movecount...*) END; (*calcmove*) PROCEDURE play(mover: color); BEGIN GOTOXY counterresp DO WHILE ( (c <= movecount) AND (NOT cornercounter) ) DO BEGIN WITH okmove[c].moveloc DO IF board[row,col].corner THEN cornercounter := TRUE; c := c + 1; END; IF NOT cornercounter THEN BEGIN points := points -190; l].incenter4by4 THEN FOR direc := north TO nw DO WITH respondmove DO IF direc IN dirsflipped THEN WITH moveloc DO IF board[row,col].adjacentsq[direc] = move.moveloc THEN BEGIN move.points := move.points - 5; IF move.points <= bestsofar THEN Eition(legallist,cornmoves); IF legallist.movecount > 2 THEN sortmoves(legallist.okmove,2,legallist.movecount); bestsofar := -MAXINT; FOR m := 1 TO legallist.movecount DO BEGIN move := legallist.okmove[m]; aftermove := status; makemove(aftestatus[x,y] DO IF occupied THEN IF occupier = mover THEN FOR direc := north TO nw DO WITH afterresp DO BEGIN sq.row := x; sq.col := y; REPEAT sq := board[sq.row,sq.col].adjacentsq[direc]; IF NOT sq.onboard THEN GOTO 0; IF NOT boardstatu coordinate; sq: squareloc; direc: direction; oppcolor: color; afterresp: gamestatus; cornercounter: BOOLEAN; respondmo IF bordnoncorn THEN BEGIN points := points - contingent; WITH board[moveloc.row,moveloc.col] DO IF specialbordersq THEN WITH otherofpair, status.boardstatus[row,col] DO IF occupied THEN IF occupier = mover THEN WITH status.boardstatus[betw IF points <= bestsofar THEN EXIT(checkresponses); END; 0: IF afterresp.score[mover] = 0 THEN BEGIN points := -MAXINT+1; (*might be our only choice, so +1*) EXIT(checkresponses); END; r := r + 1; UNTIL r > responses.movecount;XIT(checkresponses); END; afterresp := aftermove; makemove(afterresp,respondmove,FALSE); IF bordnoncorn THEN WITH moveloc DO IF afterresp.boardstatus[row,col].occupier = oppcolor THEN BEGIN bordnoncorn :=rmove,move,TRUE); findlegalmoves(aftermove,responses); WITH move DO BEGIN IF responses.movecount = 0 THEN points := points + 100 ELSE IF points > bestsofar THEN BEGIN checkposition(responses,respcornmoves); checkresponses(mover,move,responss[sq.row,sq.col].occupied THEN GOTO 0 UNTIL boardstatus[sq.row,sq.col].occupier = oppcolor; END; makemove(afterresp,respondmove,TRUE); findlegalmoves(afterresp,counterresp); cornercounter := FALSE; c := 1; WITHve: movedesc; counterresp: movelist; BEGIN oppcolor := flipof(mover); WITH move DO BEGIN contingent := 0; r := 1; REPEAT respondmove := responses.okmove[r]; IF NOT board[moveloc.row,moveloc.coeen.row,between.col] DO IF NOT occupied THEN points := points - 90; END; END; (*WITH move...*) END; (*checkresponses*) BEGIN (*calcmove*) GOTOXY(0,23); WRITE('Calculating move for ',colorword[mover],'...'); checkposcorner THEN BEGIN points := points - 55; IF cornmoves > 1 THEN IF board[moveloc.row,moveloc.col].corner THEN points := points -20; IF points <= bestsofar THEN EXIT(checkresponses); END; FOR x:=1 TO 8 DO FOR y:=1 TO 8 DO WITH afterresp.board FALSE; points := points - 65; (*40, plus the 25 given in checkposition*) IF points <= bestsofar THEN EXIT(checkresponses); END ELSE contingent := contingent + 8*respondmove.bordrsqsflipped; WITH respondmove.moveloc DO IF board[row,col].(0,20+ORD(mover)); IF legalmoves[mover] > 0 THEN BEGIN WRITE(spaces); IF mover = usercolor THEN inputmove(mover,legallist,move) ELSE calcmove(mover,status,legallist,move); makemove(status,move,TRUE); updatecrt(EN BEGIN otherofpair.row := x; between.row := x; IF y IN [2,5] THEN BEGIN otherofpair.col := y+2; between.col := y+1; END ELSE BEGIN otherofpair.col := y-2; between.col := y-1; END; END ELSE BEGIN otherofpair.col := y; between.ctatus: gamestatus); FORWARD; FUNCTION flipof(oldcolor: color): color; FORWARD; PROCEDURE makemove(VAR status: gamestatus; VAR move: movedesc; updateadjacent: BOOLEAN); FORWARD; SEGMENT PROCEDURE initgame; CONST backspace = 8; VAR x (x>1) AND (y>1); END; (*CASE*) IF onboard THEN BEGIN CASE direc OF north,ne,nw: row := x-1; east,west: row := x; south,se,sw: row := x+1; END; CASE direc OF nw,west,sw: col := y-1; north,south: col := y; ne,east,se: col := y+1; crtstatus,status); crtstatus := status; END ELSE BEGIN WRITE('(No legal moves for ',colorword[mover],')'); status.nextmover := flipof(mover); END; END; (*play*) FUNCTION userquits: BOOLEAN; VAR playagain: CHAR; BEGIN GOTOX1,8]) OR (y IN [1,8]); corner := (x IN [1,8]) AND (y IN [1,8]); incenter4by4 := (x IN [3..6]) AND (y IN [3..6]); diagnexttocorner := (x IN [2,7]) AND (y IN [2,7]); FOR direc := north TO nw DO WITH adjacentsq[direc] DO BEGIN CASE direc OF nort,y: coordinate; direc: direction; answer: CHAR; h,l,h0,l0: INTEGER; (*for testing whether clock is on*) PROCEDURE defineboard; BEGIN FOR x := 1 TO 8 DO FOR y := 1 TO 8 DO WITH board[x,y] DO BEGIN border := (x IN [ END; END; END; (*FOR direc...WITH adjacentsq...*) specialbordersq := border AND (NOT corner) AND ( (x IN [2,4,5,7]) OR (y IN [2,4,5,7]) ); IF specialbordersq THEN BEGIN otherofpair.onboard := TRUE; between.onboard := TRUE; IF x IN [1,8] TH (********************************************************** * PART OF OTHELLO.PAS so see that file for details. ************************************************************) (* included file for OTHELLO *) PROCEDURE updatecrt(VAR oldstatus,newsY(0,20); WRITELN(spaces); WRITELN(spaces); WRITELN; WRITE(spaces); GOTOXY(0,23); WRITE('Start a new game? (y/n): '); READ(playagain); userquits := NOT (playagain IN ['Y','y']); END; (*userquits*) h: onboard := x>1; ne: onboard := (x>1) AND (y<8); east: onboard := y<8; se: onboard := (x<8) AND (y<8); south: onboard := x<8; sw: onboard := (x<8) AND (y>1); west: onboard := y>1; nw: onboard :=  ol := y; IF x IN [2,5] THEN BEGIN otherofpair.row := x+2; between.row := x+1; END ELSE BEGIN otherofpair.row := x-2; between.row := x-1; END; END; END; (*IF specialbordersq...*) END; (*FOR x:= ... FOR y:= ... WITH board[x,y].END; END; crtstatus := status; move.dirsflipped := []; move.points := 0; WITH status DO BEGIN FOR x := 4 TO 5 DO FOR y := 4 TO 5 DO BEGIN move.moveloc.row := x; move.moveloc.col := y; IF x=y THEN nextmover := white ELSE nextmover :ou have no legal move, '); WRITELN('you must pass. The object '); WRITELN('of the game is to end up '); WRITELN('occupying more squares than '); WRITELN('does your opponent. '); WRITELN('Hints on strategy: Usually '); WRITELN('th(blanks:29,gamerow,vertdivs); writeln(blanks,vertdivs); END; write(blanks,colnames); GOTOXY(4,0); WRITELN('Score'); WRITELN('-----------'); WRITELN(CHR(whiteascii),'/White:'); WRITELN(CHR(blackascii),'/Black:'); END; (*showemptyboard*) rec := north TO NW DO IF odd(ORD(direc)) THEN opposdir[direc] := pred(direc) ELSE opposdir[direc] := succ(direc); TIME(h,l); IF (h=h0) AND (l=l0) THEN BEGIN GOTOXY(20,11); WRITE('Please turn on the clock.'); WHILE l=l0 DO TIME(h,l'to become your pieces. Thus'); WRITELN('each move "flips" at least '); WRITELN('one opposing piece. '); WRITE (' (Tap space bar for more...)'); END; (*page1*) PROCEDURE page2; BEGIN WRITELN('Example: a legal move for '); WR..*) END; (*defineboard*) PROCEDURE showemptyboard; CONST vertdivs = '| | | | | | | | |'; horzdivs = '|-----|-----|-----|-----|-----|-----|-----|-----|'; colnames = ' A B C D E F G opponent. (Tap space bar...)'); END; (*page2*) BEGIN (*instructions*) GOTOXY(0,5); WRITE('Want instructions? (y/n): '); READ(answer); IF NOT (answer IN ['N','n']) THEN BEGIN GOTOXY(0,5); page1; READ(answer); GOTOXY(0,5); page2; Re board position of a move'); WRITELN('is more important than the '); WRITELN('number of pieces it "flips".'); WRITELN('Try to occupy the borders '); WRITELN('(especially corners!) and '); WRITELN('avoid giving them to your '); WRITE (' PROCEDURE instructions; VAR i: INTEGER; PROCEDURE page1; BEGIN WRITELN('A move consists of placing '); WRITELN('one of your pieces on an '); WRITELN('unoccupied square which is '); WRITELN('adja); END; showemptyboard; WITH status DO BEGIN score[white] := 0; score[black] := 0; FOR x := 1 TO 8 DO FOR y := 1 TO 8 DO WITH boardstatus[x,y] DO BEGIN occupied := FALSE; adjacentpieces[white] := []; adjacentpieces[black] := []; ITELN('white on the first play '); WRITELN('would be 3E, 4F, 6D, or 5C. '); WRITELN('To make a move at, e.g., 3E '); WRITELN('you may type any of: 3E, 3e,'); WRITELN('E3, or e3. '); WRITELN('If y H '; blanks = ' '; VAR gamerow : coordinate; BEGIN GOTOXY(0,0); FOR gamerow := 1 TO 8 DO BEGIN IF gamerow>1 THEN (* "IF" because no room for topmost border line *) writeln(blanks,horzdivs); writelnEAD(answer); GOTOXY(0,5); FOR i := 5 TO 22 DO WRITELN(spaces); WRITE(spaces); END ELSE BEGIN GOTOXY(0,5); WRITE(spaces); END; END; (*instructions*) BEGIN (*initgame*) lastchange := 0; TIME(h0,l0); defineboard; FOR dion of the adjacent oppon- '); WRITELN('ent hits one of your other '); WRITELN('pieces before hitting an un-'); WRITELN('occupied square. All of the'); WRITELN('opponent''s pieces which that'); WRITELN('line crosses are converted '); WRITELN(cent (vertically, hori- '); WRITELN('zontally, or diagonally) to '); WRITELN('a square occupied by your '); WRITELN('opponent so that a straight '); WRITELN('line starting at your piece '); WRITELN('and continuing in the direc-'); WRITELN('ti= black; makemove(status,move,TRUE); updatecrt(crtstatus,status); crtstatus := status; END; (*FOR...FOR...*) nextmover := white; END; (*WITH status...*) instructions; GOTOXY(0,6); WRITELN('White goes first -- Which'); aracter dot matrix; try to maximize the *) (* difference in intensity between the black and white pieces while maxi- *) (* mizing the absolute intensity of the black piece. Avoid n I * realized that it did not make any difference. It is about time * we devoted some time to learning how to convert from UCSD to * Z. So that is why I included this program. I want someone to * convert it. It also is a good guide to some adv The game pieces are shown on the screen as 2 rows of 3 characters, e.g. *) (* OOO *) (* OOO *) (* If your crt has WRITELN('color do you want to play:'); REPEAT GOTOXY(3,8); WRITE('W)hite or B)lack? ',CHR(backspace)); READ(answer); UNTIL answer IN ['W','w','B','b']; IF answer IN ['W','w'] THEN usercolor := white ELSE usercolor := black; GOT) * (for us non-commercials. It was originally donated by a ) * (Company who thought kindly of us.) ***************************************************************) (*$S+*) (* UCSD Pascal *) PROGRAM OTHELLO; (* Steve Brecher 16-Jun-79 *) anced Pascal * programing. * Othello units: * Othello.pas * Othell1.pas * Othell2.pas * Othellin.pas * * Donated by the now defunct UCSD PASCAL USERS GROUP * (To the best of my knowledge this software is to be used only  a "block" character (like the cursor on some crts), that*) (* is good for the white piece, and capital letter O is good for black, *) (* especially if it has a rectangular shape. Otherwise, choose characters *) (* that are centered within the ch (************************************************************** * It was about time I included something for the game freaks * so I looked around for something good. The best I could come * up with was Othello. Unfortunately it is in UCSD but theOXY (0,6); WRITELN(spaces); WRITELN(spaces); WRITELN(spaces); colorword[white] := 'white'; colorword[black] := 'black'; END; (*initgame*) (* The position evaluation weights were derived from a FORTRAN program *) (* headed "from Creative Computing/Klaus E Liebold/4-26-78". *) (* This program provides playing instructions to the user on request. *) CONST (*characters with*) (* semantic content, e.g. "W" and "B" are not so good. *) whiteascii = 96; (*ascii value of char making up piece of first mover*) blackascii = 79; (* " " " " " " " " 2nd " *)  legallist: movelist; move: movedesc; opposdir: ARRAY[direction] OF direction; legalmoves: ARRAY[color] OF INTEGER; colorword: ARRAY[color] OF STRING[5]squarestatus = RECORD CASE occupied: BOOLEAN OF TRUE: (occupier: color ); FALSE: (adjacentpieces: ARRAY[color] OF SET of direction); END; gamestatus = RECORD boardstatus: ARRAY[coordinate,coordinate] OF s airs of such squares on each border. Sample pair: *) (* (1,2) and (1,4); for each we want a pointer to the other *) (* and to the border square between them (1,3). *) CASE speminticks = 22.0; (*min # clock ticks between crt square updates *) (*--should be long enough for a distinct, separate *) (*terminal bell sound on each square updated *) spaces = ' ); legalmoves[white] := legallist.movecount; REPEAT play(white); findlegalmoves(status,legallist); legalmoves[black] := legallist.movecount; play(black); findlegalmoves(status,legallist); legalmoves[white] := legallist.movecount;; usercolor: color; lastchange: REAL; (*time of last square change on crt*) (*$I OTHELLINIT*) (*$I OTHELL1*) (*$I OTHELL2*) BEGIN (*PROGRAM OTHELLO*) REPEAT initgame; findlegalmoves(status,legallistquarestatus; nextmover: color; lastmoveloc: squareloc; score: ARRAY[color] OF INTEGER; END; movedesc = RECORD moveloc: squareloc; points: INTEGER; dirsflipped: SET OF direction; 4bordrsqsfli cialbordersq: BOOLEAN OF TRUE: (otherofpair,between: squareloc); END; VAR board: ARRAY[coordinate,coordinate] OF position; status,crtstatus: gamestatus; square: squareloc; '; TYPE coordinate = 1..8; color = (white,black); squareloc = RECORD CASE onboard: BOOLEAN OF TRUE: (row,col: coordinate); END; direction = (north,south,east,west,sw,ne,se,nw); (*pairs of opposites*) UNTIL (legalmoves[white]=0) and (legalmoves[black]=0); UNTIL userquits; END. diagnexttocorner: BOOLEAN; incenter4by4: BOOLEAN; adjacentsq: ARRAY[direction] OF squareloc; (* "special" border squares are those border squares *) (* adjacent to a corner or adjacent to board midline; there *) (* are 2 ppped: INTEGER; bordnoncorn: BOOLEAN; END; movelist = RECORD movecount: INTEGER; okmove: ARRAY[1..30] OF movedesc; END; position = RECORD border: BOOLEAN; corner: BOOLEAN; *+*+w!* w##w!( F##NJ J.^#V!{!!!!! !!!s$String too lonCall by reference precision erroIndex or value out of rangAttempted divide by zerMultiply overfloStack overfloFlo8 +*!d5 ! ! H0; ('# ! ^ 6 s^+>0w6.@ +ow+C6E+x(-xDGq(<'w>0owow!9@B'd (?͂8:(6+++ (ˆ#w+> ###͂8(G+++ˆ ˎ#Np+y ++Nwy+!T uRead beyond EO!PY9G!ݾ Afn( ~^(Vfnů͹^ ѯݾ  z() ,FC   ̏ ̥  r+sFm! }gů͋! 9!! e3nfs !s Rm! }gů͋! 9!! e3nfs !s Rm! }gů͋! 9{V(g$r4# 40'w! ͓u66put, try again 9 (-(+  3 0 :  3w.(7e(;E(708:8> ͬDM#4 fnr+s+p+q@ H  3w-(+ 394 ~+.(:e(DE(@ (85*#~0! 6+w+w+w+w Uf nR#W^!W^s4nfP gn#!W^>4zP ! ͓#f n swgnRf nR#W^!9#ѯR: gnRf nR#60gn#ugnRf nR#W^{.zgn#ugnRf nR#W^{ z gnRf nR#ating point overflow/underflo -- statement !9!!9Rh/ >--?etalubat ot tnaw uoy od srebmun ynam woH.!.!9!M.2  ͨ !! e3ELBAT!!9!w6nfV+^( 3  Ù ʭ fn~!9 G_~((GW>__{(+#ܯ>(#> + ٯgk9~fnw !!9G ᯼ ! s  Ô OfnF+ͰN |(̈́0#wͰ8!̈́8 ( (( xOw+G #qF . fnͰN |(̈́0n({( Ͱ8̈́8 w+6 + T(t(F(f( ( y y fnpG Ee ,ͰOG Ͱ8ẍ́8s(wð (] (Y (U (Q (M#(1_(-$(){8 [8:8x a8A8 0x Wx zW>( nff nR#W^s! ͓ ! ͓!0 Rtu! ͓}-|lnf}/o|/g#tu6+++!W^Ҙgn!604{nfW_nf##W^ 6! ͓unfT6+++! W^gn+++!Q66=O~- O+ +~0ړ ғG+~ (0ړ ғWxGxA(DG~ݦf(G* DG!9ͬͬ!9 ~(-q !9w#w!Nu6~ >ݾ8*54~0Oy( !W !617 gnRf nR#gnRf nR#W^s`gnW^RP gn#ugn R##f nR#W^s! MDx怴g3!39 Uѯc կNN T]F('###͂8Cnftunf^Vtunftu!nf!! e3!nf!! e3!nf!! e3!nf!! e3nfs !s Rm! }gů͋! 9!! e3nfs !s R( ! sfnqG. fnp+qG!D (- +  :0%08!͋ s w:000⯸x/Gy/Oɯ e! s  !T]jjZj_ZfnV^ͰN ###͂++Fwx+0w+z  z ! uType error on inpuError in in |{6nf##!! ͓s6+++!W^sgnnf!W^f nR#W^s47wwݾm nf##!6.6+++!W^gnf nR#6 4¡nf##W^u6+++gnW^!gnW^! R##W^f nR#W^s46+++nfW^Ogn#!60416+++nf#W^Ҙgn!W^f nR#W^s4gnf###u+++!W^gn!W^f nR#W^s4²nfW_'{gn##^V}P! !Qj!  44Q4P!9w ! Nʓ~ݮ w~<ݖ w !9w#+! +8 +#H+f8!d! w#!9~ J͐  }r+sPYO>_~:(0AGV0> :(*55*+Fx8I!s7L((0|rx( jrygoRxL 0#fn##|###f!sxdx xx!,s/ R0r *~+8^#~ 8<F<5<N5<gi#9A  NJ+ J#.F 9###go͎ z ;   76<+w_##~ >Y;ʩ%6#6;x$^;"xʗz## Ư"w#w#wáˆ++`i(  S_xDM!=()8 )0 0)+} E˸$}($0##0""L$q#s#r!(F!#6!*!!4 #4 #4!!+F&( 6##Nq+'6p|goR˹T]!9w >ݮ w !9w !N( ! N~ݖ ( Op8y! ~(! > ~( !>('yG(!4+~Y! 4+~Y!4+~Y! 4+~Y! ˆ"(w#w#w 44~0#4 #4!!4 #4 #4! 6!!%66ß)~6<(3;' " ^##w! ! ! !uDisk erroError in extending filDisk fulDirectory fulBad C VO VN  VS VT  Vw V8(.(w#H (# a8{0_ +++f###%(6͔ʊ}y%4Ÿf`###;"!5~< #5~< #5'"! 6!'+Fz#.F 9ˆ###Sgo͎!9 PY FfnV go҆| }~^(Vfn>͹f(zȯF+!̠̰_ Nng)))V^G~ (#X(y(8 PG zBNz#F~+|0R?|17R|07R?|1Rb$ɯ7~/w#~/+~w+ #~wɯ(#~+*^W#~!OG F+N ngOG F+N F+n`OG F+N+~=(ۯOG F+N+~ =(rW+sɯRɯRӠàō ͂ 6w+(˞###8o+++v ~ ^###~+++ˎ˞˦0 ###f+++go0 | }!uToo many open output file!uBad output file nam#}( ##|#(}#7 0!9G ANJ+ ;! > Uѯݾ !9#ɯ#ɯw~(4+O 6v +f55ɯݾ c! 9!7(  SxDM!=)#0 |z(z/W{/_|(|/g}/o#  -# z"BKgofilename *^#~ 84 #6*6O  J r*6#~P( 4^q5 J7~Or#%~#?Gf###;4~0#4 #4!4~0#4 #4!G~= 60 +A~8 ( W z Nz++++!9ѯɯR0 >0w+ G fnN++͆| z   r+++~(r###v###ʪY͔>+++###`i###;^(?"!5~< #5 #5'+( 8 G zF+Nz+++ݾ~V8 (8 Gy zOAOzTRUEFALSEF~+++N Ő( 8G z( +Nzy(G++V^!9 z(6-+goGRw+O'::d: :EBG #~-   (****************************************************** * * POWER TABLE PROGRAM * * This program was extracted from the book PROGRAMMING * IN PASCAL by Peter Grogono during a self-study effort. * It is a simple enough program but it shows how to b!%p ͂ 6++w+(˞ :(*55*+Fx8 !s++7\++?(ʃ .Î 8w*!9N#F V+^++~+ AN+둾OyFwyHB+O#!9!O~82G>+ (<+(~<#_F !~w!l F ! f n Nq! l DF square := sqr (base); cube := base * square; quad := sqr (square); WRITELN (base:2,' ',square:4,' ',cube:5,' ', quad:6,' ',1/base:12,' ',1/square:12, ' ',1/cube:12,' ',1/quad:12) END (* for loop *) END. (* MAIN *) le! uBad output file nam#}( ##|#(}#70!9G AN>+ >ͮ  }r+sPYO>xĩ 0#fn##|###9 !s d   !,s/ R0.h`ihhPYaVVnf#tuf n!Pgn$!@ a(ʃ .! l F wݾ!!?e3!  >OGV3+ͻgoRʹ6 >POGV3+H(ʃ .g!l F wuild * tables very easily. I had to modify it of course, so that * it would run with Pascal/Z. * * Adaptation by Charlie Foster, Oct 1980 * Donated to the Pascal/Z Users Group *******************************************************) PROGRAM poF~+++N| +G | ++ݾ~Z8 AO| G | TRUEFALSEF~+++N ( +N| y(G++G | V^!9 z(6-+goGRw+O'< < d<  < ED G #~-  O###goͤ |  | #DF Oˆ###U goͤ!9 PY FfnV go | }~^(Vfn> f(zȯF+)̢c Fng)))V^Ny (#| ( | *+*+w!*w##w!( F##N> >Ï^#V!{!! !!! !!!sà String too lonCall by reference precision erroIndex or value out of rangAttempted divide by zerMultiply overfloStack overflo --h`i###͞^(?"!5~< #5 #5'"x (  S_xDM!=()8 )0 0)+} E˸$}($0##0""L$q#s#r!(F!#6!*!!4 #4 #4!wڃnf#tu!nf :!!9!# ! !Q!9 QU(ʃ .!l !9!!9Rcw6 !V+^(ʃ .4# 4ù.w*wwwertable; VAR tablesize, base, square, cube, quad : INTEGER; BEGIN WRITELN; WRITE ('How many numbers do you want to tabulate?--> '); READ (tablesize); WRITELN; WRITELN (' ':30,'TABLE'); WRITELN; FOR base := 1 TO tablesize DO BEGIN  60 +A~8 ( W |  N| ++++!9ѯɯR0 >0w+ G fnN++͈ | z   .s >+++###ͻ ###F 8^F+++ˎ˞˦ 0 ###9 +++go 0 | }! uToo many open output fi[nftufnP>POf nQ! F+n` F+n`tunfW_R[ww! l F f n-!! Ge3!! G R POfnQfn w+wnfW_R¡nftuõnffn r+snftu!Yl F nfW_R Y͞ʅ%6#6͞x$^͞|R?|7RIL; end {of InitializeQueue}; Procedure Queue( currentline : items ); VAR new_ptr : P_pointer; begin NEW(new_ptr); {reserve a new queuecell } new_ptr^.line := currentline; new_ptr^.next := NIL; If FrntPtr = NIL then FrntPtr := n!4 #4 #4! 6!!%66)~6<(3͞' " ^##w! ! ! !uDisk erroError in extending filDisk fulDirectory fulBad filename *^ next : P_pointer end; S$0 = string 0; S$255 = string 255; VAR charcount : integer; currentline : items; {the current line} FrntPtr, RearPtr : P_pointer; ch : char; linecount : integer; EndOfLine, EndOfFile, don++++++++++++++++++++++++++++++++++++++++} PROGRAM CopyWithPrefixedCharCount; CONST default = 80; input = 0; {Pascal/Z needs this crutch} TYPE items = string default; P_pointer = ^queuecell; queuecell = record line : items; |7R?|Rb$ɯ7r+s!9RYr+sV+^OG F+N ngOG F+N F+n`OG F+N+~=(ۯOG F+N+~ =(rW+sɯRɯR>*>#>+ɯ2t82E8*|8"~8~(($*,*8|(a*~8"|8̈́,*8|( ( !.}2E8*|8~#(+"|8*,*8|~+ew_ptr Else RearPtr^.next := new_ptr; RearPtr := new_ptr; {complete the circular queue} end {of Queue}; Function QueueIsEmpty : BOOLEAN; begin QueueIsEmpty := (FrntPtr = NIL); end {of queueIsEmpty}; Procedure Serve(var current: item{++++++++++++++++++++++++++++++++++++++++++++++++++++++++} {+ +} {+ PROGRAM TITLE: Copy With Prefixed Char Count +} {+ +} {+ WRITTEN BY: George W. Cherry [1] +} {+ +} {+ Modified by Raymond E. Penley, 7 Oct 1980 +} {+ The pro#~ 84 #6*6O  > .*6#~P( 4^q5 >7~O.#%~#? P~͞   76<+w_##~e : boolean; ix : integer; Function length(x: S$255): integer; external; Procedure setlength(var x: S$0; y: integer); external; Procedure KEYIN(VAR cix: char); EXTERNAL; Procedure InitializeQueue; begin FrntPtr := NIL; RearPtr := N= NIL; end; end {of serve}; Procedure Read_a_chunck; VAR done_reading_lines : BOOLEAN; Procedure GetC(VAR ch: char); { Recognizes "control-E" as End of File on the console. } begin KEYIN(ch);write(ch); endofline := ( 8 ^V!'l)!8 V+^r+snf+tunf'{)!8 V+^nfnf#'{)!8 ^Vr+s4# 4Ånf+tunfW_nf{)!0 V+^rsnf{)!0 V+^rs6ݾ! P! statementFloating point overflow/underflo *w6nfV+^Ҷnf'{)!8 ! V+^ͬnf̀mW_R–~(4# 4F~!P*n f tunf tuwwnftuwnfetL(currentline);Writeln; If (length(currentline)=0) OR ( EndOfFile ) then done_reading_lines := TRUE Else Queue(currentline) end; end;{of Read_a_chunck} Procedure Process_chunck; begin linecount := 0; whilenf'{)!8 V+^rsnf'{)!8 ^V!'l)!8 V+^r+snf'{)!8 ^Vr+sÇ6ݾ҃nf^VR^VnfRnf{)!0 ^Vr+snf{)!0 ^Vr+snford(ch)=13 ); endoffile := ( ord(ch)=5 ); If ( endofline ) OR ( endoffile ) then ch := ' '; end; Procedure GetL(var LINE: items); begin setlength(LINE,0); GetC(ch); while not( EndOfLine OR EndOfFile ) DO 8 ^Vr+snf'{)!8 V+^rsnf'{)!8 V+^nfҀnf'{)!8 ^V!'l)!8 V+^r+snf'{)!8 ^Vr+snf'{)!8 V+^rsnf'{)!8 V+^nfҀ^VR 5nf^VRhnf^Vhnf^Vtunf'{)!8 V+^rsnftunftunf'{)!8 V+^nf0nf'{)!8 ^V!'l)!8 V+^r+snf'{)! not QueueIsEmpty do begin linecount := linecount + 1; write(linecount:3, ': '); Serve(currentline); Writeln(currentline); end;{while not queueisempty} Writeln; end;{of Process_chunck} BEGIN {Main Program} fotuXnf{)!0 ^Vr+snf{)!0 ^Vr+snftunf#tunf#tu nfV+^Ҋnf'{)!8 V+^rsnf+tunf'{)!8 V+^nf}nf#'{)!*+*+w!@ *w##w!( F##N" "^#V!{!! !!! !!!WString too lonCall by reference precision erroIndex or value out of rangAttempted divide by zerMultiply overfloStack overflo --begin charcount := charcount + 1; append(line,ch); GetC(ch); end; end; {GetLine} begin {of Read_a_chunck} done_reading_lines := FALSE; while not done_reading_lines do begin write('?'); Gnf'{)!8 ^V!'l)!8 V+^r+snf'{)!8 ^Vr+snf'{)!8 V+^rswnf+tunf'{)!8 V+^nf҃nf#tunf'{)!8 V+^nfҹnf^V҃); end;{while not EndOfFile} END.  { INITIALIZE } charcount := 0; MARK(chunck); Read_a_chunck; Process_c