`L i=L\Ʃx ? N'i  ͭЅ?0ȱ Ѕ?iȱi lԠԠ͠ԠϠŠͮŠ SYSTEM.APPLE   L$JN^GTEXT{LANDER.CODEvg&EXTgDCCONTROL.CODEgɡDC.CODEr=vg DCCTL.TEXT=vg LANDER.TEXTvg&ASEED.DOC.TEXTg ASEED.DOC.CODEg¢  README.TEXTvg¢ASEED.DOC.CODEg¢ASEED.DOC.CODEg¢README.̡ks MODEDEMO.TEXTvgءs} TEMPLIB1.TEXTvg} TEMPLIB1.CODEvgFLASHDEMO.TEXTgFLASHDEMO.CODEgERASEDEMO.TEXTg DATEDEMO.TEXTvg PROCLIB1.TEXTvg DCCTL.CODE=vgDCCONTROL.TPSCAL11; DIAPLOT.TEXTvgG0 DIABLO.TEXTvg06 MINIPUB.TEXTvgǠ6= MINIPUB.CODEvgǠ=A PLOTTEST.TEXTvgGAWDIABLO-DOC.TEXTYWa PRTPAGE.TEXTvg"ae LOOKIT.TEXTvgek LCPAT1.1.TEXTvg&꽌ɪɖ'*&%&,E'зЮ꽌ɪФ`+*xH&x'8*7Ixix&&  ') + &п x) ++`FG8`0($ p,&") (jJJ>L+ "?I>  N `  ` x V Nx .x- z `V0^*^*>` aI꽌ɪVɭ&Y&&Y& 꽌ɪ\8`&{$S+}   unit diaplot; ${unit to drive the Diablo 1600-series printers as a digital plotter. $80/07/04 PHK Initial Version. $}  interface   var "printer : text;  procedure plot (x, y: integer; c: char);  procedure viewport (x0, y0, xu, required.} $begin {increment} $if x > 0 then $ write (printer, sp) $else &if x < 0 then $ write (printer, chr(bs)); $if y > 0 then $ write (printer, chr(esc), chr(lf)) $else &if y < 0 then $ write (printer, chr(lf)); $if c > sp then $nits per horizontal move} $movey : integer; {units per vertical move} " "procedure increment (x, y: integer; c: char); &{moves one increment in the directions specified by the signs of 'x' &and 'y', then plots the character 'c', if$xa : integer; {horizontal units per major move} $ya : integer; {vertical units per major move} $moves : integer; {number of moves that must be made} $movex : integer; {ul units to move} $err : integer; {straight/diag delta} $erra : integer; {offset error caused by major move} $errb : integer; {offset error caused by minor move} da : integer; {units to move in major direction} $db : integer; {units to move in minor direction} $dx : integer; {horizontal units to move} $dy : integer; {verticae as possible $is drawn from the current position to (x,y) using 'c' as the $plotting mark. This routine is a modification of Breshenham's $algorithm [Algorithm for Computer Control of a Digital Plotter, $IBM Systems Journal, v.4, #1, 1965]} "var " "if v > h then $limit:= h "else $if v < l then &limit:= l $else &limit:= v; "end {limit};   procedure plot {x, y: integer; c: char}; ${positions the printer head to internal coordinates (x,y). $If 'c' collates >= ASCII space, as straight a liner to internal vertical coordinate values} "begin {yint} "yint:= round ((y+origin.y)*scale.y); "end {yint};   function limit (v, l, h: integer): integer; ${returns the value 'v', limited by the low value 'l' and $high value 'h'} "begin {limit} {current plotter position}   function xint (x: real): integer; ${converts from user to internal horizontal coordinate values} "begin {xint} "xint:= round ((x+origin.x)*scale.x); "end {xint};   function yint (y: real): integer; ${converts from us {user origin offset} "posmax : position; {max plotter position} "posmin : position; {min plotter position} "loc : coordinate; {current user coordinate} "pos : position; $y : real; $end {coordinate}; "position = record $x : integer; $y : integer; $end {coordinate};   var "scale : coordinate; {user units/internal unit} "origin : coordinate; r decimal equivalents} "bs = 8; "cr = 13; "esc = 27; "ht = 9; "lf = 10; "sp = ' '; "point = '.';   type "coordinate = record $x : real; = 48; {Diablo vertical resolution} "maxh = 792; {max horiz internal coordinate} "maxv = 32767; {max vert internal coordinate} " "bel = 7; {ASCII characteyu, xmin, ymin, xmax, ymax: real);  procedure initplot;  procedure endplot;  procedure move (x, y: real);  procedure draw (x, y: real);   implementation   const "hmires = 60; {Diablo horizontal resolution} "vmires write (printer, c); $end {increment};  "begin {plot}; "dx:= x - pos.x; "if dx >= 0 then $movex:= 1 "else $movex:= -1; "dy:= y - pos.y; "if dy >= 0 then $movey:= 1 "else $movey:= -1; " "dx:= abs(dx); "dy:= abs(dy); "if dx >= dy then $begin $da:= dx; $db:= dy; $xa:= movex; $ya:= 0; $end "else $begin $da:= dy; $db:= dx; $xa:= 0; $ya:= movey; $end;  "write (printer, chr(esc), '3'); {plot mode on} "if c > sp then $write (printer, c); "erra:= 2*db; "errb:= 2*(db&begin &plot (endpos.x, endpos.y, sp); &endpos:= startpos; &end $else &plot (startpos.x, startpos.y, sp); $end; "plot (endpos.x, endpos.y, point); "loc.x:= x; "loc.y:= y; "end {draw};   end {Diablo plotter unit}.  "if startpos <> pos then $begin $plotloc.x:= pos.x/scale.x - origin.x; $plotloc.y:= pos.y/scale.y - origin.y; " dold:= sqr (plotloc.x - loc.x) + sqr (plotloc.y - loc.y); $dnew:= sqr (plotloc.x - x) + sqr (plotloc.y - y); $if dold > dnew then " dold : real; {dist from plot head to loc} $dnew : real; {dist from plot head to (x,y)} "begin {draw} "endpos.x:= xint (x); "endpos.y:= yint (y); "startpos.x:= xint (loc.x); "startpos.y:= yint (loc.y); real}; ${draws a straight line from current position to (x,y)} "var " plotloc : coordinate; {coord of plot head} $startpos : position; {line starting position} $endpos : position; {line ending position} "write (printer, chr(esc), chr(ht), chr(1)); "close (printer, normal); "end {endplot};   procedure move {x, y: real}; ${moves the plot head to (x,y) without plotting} "begin {move} "loc.x:= x; "loc.y:= y; "end {move};   procedure draw {x, y: "pos.x:= 0; "pos.y:= 0; "viewport (0, 0, 1, 1, 0, 0, 8.5, 11); "end {initplot};   procedure endplot; ${terminates the plotting session; closes the printer file} "begin {endplot} "plot (xint (loc.x), yint (loc.y), sp); ers} "var $msg : packed array [0..3] of char; "begin {initplot} "writeln; "write ('Ready printer -- console when ready '); "readln; "rewrite (printer, 'PRINTER:'); "write (printer, chr(esc), chr(ht), chr(1), chr(bel)); {tab to 0} yint(ymin), -maxv, maxv); "posmin.x:= limit (xint(xmax), 0, maxh); "posmin.y:= limit (yint(ymax), -maxv, maxv); "end {viewport};   procedure initplot; ${initializes the plotting unit; positions the plot head to (0,0); $sets default viewport paramet"scale.x:= hmires/xu; "scale.y:= vmires/yu; "plot (round(x0*hmires), round(y0*vmires), sp); {move to origin} "origin.x:= pos.x/scale.x; "origin.y:= pos.y/scale.y; "loc.x:= 0; "loc.y:= 0; "posmax.x:= limit (xint(xmin), 0, maxh); "posmax.y:= limit (rs: $(x0,y0) is the offset in inches from the physical origin to the $user origin; (xu,yu) are the scalefactors [user units/inch]; $(xmin,ymin) and (xmax,ymax) are the plotting limits. $Moves to the user origin} "begin {viewport} " moves:= moves-1; $end; " "write (printer, chr(esc), '4'); {plot mode off} "pos.x:= x; "pos.y:= y; "end {plot};   procedure viewport {x0, y0, xu, yu, xmin, ymin, xmax, ymax: real};  {sets the plotting viewport, origin, and scale facto - da); "err:= erra - da; "moves:= da; " "while moves > 0 do $begin $if err > 0 then &begin {diagonal move} &increment (movex, movey, c); &err:= err + errb; &end $else &begin {'a' axis move} &increment (xa, ya, c); &err:= err + erra; &end; N^!; {horizontal motion index} "vmi : integer; {vertical motion index} "lastcol : integer; {last known print position} "  Function Diabloack: diabloerr; "Var $c : char; "Begin {Diabloacts} "etx = 3; "ht = 9; "lf = 10; "vt = 11; "ff = 12; "cr = 13; "esc = 27; "rs = 30; "us = 31; "sp = 32; "  Var "hmi : integer"tabsz = 3; "maxtab = 125; "hmiinc = 120; "vmiinc = 48; "defhmi = 10; {12 cpi} "defvmi = 8; {6 lpi} "paritybias = 128; " "{ASCII control character decimal equivalenFunction Diablolpi (Lpi: integer): diabloerr;  Function Diabloprint (var Text: diatext; Margin, Spacing: integer): diabloerr;  Function Diabloformat (var Text: diatext; Margin, Spacing: integer): diabloerr;   Implementation   Const "dfile : interactive; "  Function Diabloopen (Cpi, Lpi: integer): diabloerr;  Function Diabloclose: diabloerr;  Function Diabloattn (Col: integer): diabloerr;  Function Diablopage: diabloerr;  Function Diablocpi (Cpi: integer): diabloerr;  {sound alarm} "bs = 8; {backspace} "ssp = 9; {start shadow printing}   Type "diabloerr = (diaok, diatimeout, diaeof, diabreak); "diatext = string [255]; "  Var "sus = 3; {start underscore} "sbf = 4; {start boldface} "ssu = 5; {start superscript} "ssd = 6; {start subscript} "bel = 7; OLE:, write to PRINTER:, $R-. $}  Interface   Const "{In-line text control characters} "nul = 0; "efc = 1; {end format controls} "sac = 2; {start alternate color} and /abs tab codes to prevent auto linefeed after cr(13) on Apple. $ 80/03/23 $R+; delete diabloattn call on open; col parameter for /diabloattn. $ 80/06/07 Make Diablo an output-only device: inhibit etx/ack protocol, /accept all controls from CONSdiabloformat. &79/08/07 fixed bi-directional positioning problems; allow 'n' response /to diabloattn requests; fix bugs in diabloformat. &80/01/02 added REMIN: for Apple II file system. &80/01/05 added 1640 HMI reset; $R-; added paritybias to HMI, VMI, {$L printer:}  {$S+}  {$R-}   Unit Diablo; ${ A general interface for the Diablo 1620/1640 Hy-Term printer. @P H Kimpel May 1979 &79/07/21 added entry points to change cpi and lpi. &79/08/04 added shadow printing; fixed space counting bug in /k} "diabloack:= diaok; "End {Diabloack}; " !Function Diablotab (Col, Inc: integer): diabloerr; "Var $pos : integer; "Begin {Diablotab} "if col >= 0 then $if col <= maxtab then &pos:= col $else &pos:= maxtab "else $pos:= 0; "write (dfile, chr(esc), chr(ht), chr(pos+1+paritybias)); "while pos < col do $begin $if inc > 0 then &write (dfile, chr(sp)) $else &write (dfile, chr(bs)); $pos:= pos-1; $end; "diablotab:= diaok; "End {Diablotab};   Function Diabloattn {(Collt:= diablotab (margin+x+inc-1, inc); {insure print position} &while (x <> xend) and (rslt = diaok) do (begin (x:= x+inc; (c:= text[x]; (if c > ' ' then *write (dfile, c) (else *if c = ' ' then ,begin ,spcount:= 1; ,while text[x+inc] = ' ' {print forward} (inc:= 1; (x:= xstart-1; (lastcol:= spcount; (end &else (begin {print backward} (write (dfile, chr(esc), '6'); (inc:= -1; (x:= xend+1; (xend:= xstart; (lastcol:= margin + xstart - 1; (end; & &rs$else &spcount:= margin + xend - 1; $end; " "rslt:= diabloack; {wait for printer} "if rslt = diaok then $if xend > 0 then &begin &if abs (lastcol - (margin+xstart-1)) <= abs (spcount - lastcol) then (begin (text); "if xend > 0 then $begin $xstart:= 1; $while (xend > xstart) and (text[xend] = ' ') do &xend:= xend-1; $while (xstart < xend) and (text[xstart] = ' ') do &xstart:= xstart+1; $if (xstart = xend) and (text[xstart] = ' ') then &xend:= 0 integer) (: diabloerr}; "Var $x : integer; $xstart : integer; $xend : integer; $inc : integer; $spcount : integer; $c : char; $rslt : diabloerr; "Begin {Diabloprint} "xend:= lengthgin {Diabloclose} "rslt:= diablotab (0, 1); "write (dfile, chr(esc), 'S'); {reset HMI by switch (1640 only)} "diabloclose:= diabloack; "close (dfile, normal); "End {Diabloclose}; "  Function Diabloprint {(var Text: diatext; Margin, Spacing: &chr(esc), 'B'); {print black} "rslt:= diablotab (0, 1); "rslt:= diablocpi (cpi); "rslt:= diablolpi (lpi); "lastcol:= 0; "diabloopen:= diabloack; "End {Diabloopen};   Function Diabloclose; "Var $rslt : diabloerr; "Beany noise on the line} "rslt:= diabloack; "write (dfile, ' ', {make a little noise} &chr(esc), '4', {graphics off} &chr(esc), '5', {print forward} ritybias)); $end; "diablolpi:= diabloack; "End {Diablolpi}; "  Function Diabloopen {(Cpi, Lpi: integer): diabloerr}; "Var $rslt : diabloerr; "Begin {Diabloopen} "rewrite (dfile, 'PRINTER:'); "write (dfile, chr(0)); {flush ), chr(hmi+1+paritybias)); $end; "diablocpi:= diabloack; "End {Diablocpi}; "  Function Diablolpi {(Lpi: integer): diabloerr}; "Begin {Diablolpi} "if lpi > 0 then $begin $vmi:= (vmiinc+lpi-1) div lpi; $write (dfile, chr(esc), chr(rs), chr(vmi+1+pa"Begin {Diablopage} "write (dfile, chr(ff)); "diablopage:= diabloack; "End {Diablopage};   Function Diablocpi {(Cpi: integer): diabloerr}; "Begin {Diablocpi} "if cpi > 0 then $begin $hmi:= (hmiinc+cpi-1) div cpi; $write (dfile, chr(esc), chr(usttn:= diaeof *else ,if c = chr(cr) then .diabloattn:= diaok ,else .begin .write (dfile, chr(bel)); .done:= false; .end; $ end; $until done; $end "else $diabloattn:= rslt; "End {Diabloattn}; "  Function Diablopage; $repeat &done:= true; &read (c); &if eoln then (diabloattn:= diaok &else (if eof then *diabloattn:= diaeof (else & begin *if ord(c) >= paritybias then ,c:= chr(ord(c) - paritybias); *if (c = 'n') or (c = 'N') or (c = chr(etx)) then ,diabloa: integer): diabloerr}; "Var $c : char; $done : boolean; $rslt : diabloerr; "Begin {Diabloattn} "rslt:= diablotab (col, 1); "lastcol:= col; "write (dfile, chr(bel)); "rslt:= diabloack; "if rslt = diaok then $begin do .begin .spcount:= spcount+1; .x:= x+inc; .end; ,if spcount > tabsz then .rslt:= diablotab (margin+x+inc-1, inc) ,else .repeat 0write (dfile, ' '); 0spcount:= spcount-1; .until 0spcount <= 0; ,end *else ,write (dfile, '?'); (end; &if inc < 0 then (write (dfile, chr(esc), '5') {print forward again} &end; " "if rslt = diaok then $while spacing > 0 do &begin &write (dfile, chr(lf)); &spacing:= spacing-1; &end; "diabloprint:= rslt; "End {Diabloprint}; &  Function Diablle, chr(bs)); 2col:= col - 1; 2end {bs}; 0ssp: 2ctlmask:= ctlmask + [shadow]; 0end {case}; ,x:= x+1; *until ,(x > xend) or (rslt <> diaok); *endcontrols; *lastcol:= col; *end; &end; $end; "if rslt = diaok then $while spacing > 0 do &begin write (dfile, chr(esc), 'U'); {cancel superscript} 4ctlmask:= ctlmask - [superscript]; 4end; 2write (dfile, chr(esc), 'U'); {half line up} 2ctlmask:= ctlmask + [subscript]; 2end {ssd}; 0bel: 2write (dfile, chr(bel)); 0bs: 2begin 2write (dfi4write (dfile, chr(esc), 'D'); {cancel subscript} 4ctlmask:= ctlmask - [subscript]; 4end; 2write (dfile, chr(esc), 'D'); {half line down} 2ctlmask:= ctlmask + [superscript]; 2end {ssu}; 0ssd: 2begin 2if superscript in ctlmask then 4begin 4(dfile, chr(esc), 'A'); {set alt color} 2ctlmask:= ctlmask + [altcolor]; 2end {sac}; 0sus: 2ctlmask:= ctlmask + [underscore]; 0sbf: 2ctlmask:= ctlmask + [boldface]; 0ssu: 2begin 2if subscript in ctlmask then 4begin = x+1; 4end; 2col:= col+spcount; 2if spcount > tabsz then 4rslt:= diablotab (col, 1) 2else 4repeat 6write (dfile, ' '); 6spcount:= spcount-1; 4until 6spcount <= 0; 2end; 0end .else 0case ord(c) of 0efc: 2endcontrols; 0sac: 2begin 2write c); .col:= col + 1; .end {normal character} ,else .if c = ' ' then 0begin 0if underscore in ctlmask then 2begin 2write (dfile, '_'); 2col:= col + 1; 2end 0else 2begin 2spcount:= 1; 2while text[x+1] = ' ' do 4begin 4spcount:= spcount+1; 4x:0write (dfile, chr(esc), chr(us), chr(2), 4' ', c, chr(bs), chr(bs), {offset strike} 4chr(esc), chr(us), chr(hmi+1)); .if shadow in ctlmask then 0write (dfile, chr(esc), '3', {graphics mode} 4' ', c, chr(bs), chr(esc), '4'); .write (dfile, b (col, 1); {insure print position} *repeat ,c:= text[x]; ,if c > ' ' then .begin {normal character} .if underscore in ctlmask then 0write (dfile, '_', chr(bs)); .if boldface in ctlmask then = xend) and (c = ' ') then &xend:= 0 $else &begin &margin:= margin + xstart - 1; &col:= margin; &x:= xstart; & &rslt:= diabloack; {wait for printer} &if rslt = diaok then (if xend > 0 then *begin *ctlmask:= []; *rslt:= diablotadcontrols}; $ "Begin {Diabloformat} "xend:= length (text); "if xend > 0 then $begin $xstart:= 1; $while (xend > xstart) and (text[xend] = ' ') do &xend:= xend-1; $while (xstart < xend) and (text[xstart] = ' ') do &xstart:= xstart+1; $if (xstart &write (dfile, chr(esc), 'B'); {restore print color} $if subscript in ctlmask then &write (dfile, chr(esc), 'D') {half line down} $else &if superscript in ctlmask then (write (dfile, chr(esc), 'U'); {half line up} $ctlmask:= []; $End {Enchar; {current text char} $rslt : diabloerr; {diabloack result} $ctlmask : ctlset; {mask of 'on' format controls} " "Procedure Endcontrols; $Begin {Endcontrols} $if altcolor in ctlmask then $xstart : integer; {printable text start} $xend : integer; {text index limit} $spcount : integer; {nr contiguous spaces} $col : integer; {current column nr} $c : oformat {(var Text: diatext; Margin, Spacing: integer) (: diabloerr}; "Type $controls = (altcolor, underscore, boldface, subscript, 4superscript, shadow); $ctlset = set of controls; "Var $x : integer; {text index}&write (dfile, chr(lf)); &spacing:= spacing-1; &end; "diabloformat:= rslt; "End {Diabloformat}; $  End {Diablo Unit}. N^ǠǠ  ġ}ȡ} ǀɡ"š   r- p  ګB ág F 7ǀġǀnNÍÍ á "" MINIPUB DIABLO readln (doc, line); rslt:= diabloprint (line, margin, 1); left:= left-1; until eof (doc) or (rslt <> diaok); end; end; until done; end; rslt:= diabloclose; End {Minipub}. pagenr:= 1; repeat if left <= 0 then begin {new page} rslt:= diablopage; if not forms then rslt:= diabloattn (40); heading; end; write ('lines/page: '); readln (pagesz); write ('heading: '); readln (head); while length (head) < 90-margin do head:= concat (head, ' '); if diabloattn (40) = diaok then begin left:= pagesz; if length (head) = 0 then head:= 'SYSTEM.WRK.TEXT'; reset (doc, head); write ('continuous forms (y/n)? '); read (c); writeln; forms:= (c = 'Y') or (c = 'y'); write ('margin: '); readln (margin); t:= pagesz-2; End {Heading}; Begin {Minipub} done:= false; if diabloopen (12, 6) = diaok then begin repeat write (chr (ff), 'file to publish: '); readln (head); if eof then done:= true else begin : integer; Begin {Heading} pagenr:= pagenr+1; p:= pagenr; x:= 90-margin; repeat c:= chr(p mod 10 + ord('0')); head[x]:= c; p:= p div 10; x:= x-1; until p <= 0; head[x]:= ' '; rslt:= diabloprint (head, margin, 2); lef : integer; head : string [90]; forms : boolean; c : char; pagenr : integer; done : boolean; Procedure Heading; Var x : integer; c : char; p {$S+} {$U SYSTEM2:DIABLO.CODE} Program Minipub (Input, Output); Uses Diablo; Const ff = 12; Var doc : text; line : diatext; rslt : diabloerr; pagesz : integer; left : integer; marginܡ m   š0xڂچAAǀ Dš00ڂچCCǀ DPRINTER:  45B B   S 4š>߾ Ä޾ Ä޾ Ä߂ áš쩃BނᩃB {$U diaplot.code}   program plottest;   uses diaplot;   var "x : integer; "y : integer;   begin {plottest}  initplot;  y:= 4;  for x:= 1 to 4 do "begin "move (0, x); "draw (x, y); "end;  x:= 4;  for y:= 3 doN^Gצcontinuous forms (y/n)? YéyÍmargin:  צ lines/page:   heading: ZZɡ#Zצ [Z(ágޫȡݩ (0]0]ݩߥ0 ˍݥ0 ) 2/>DZ áצSYSTEM.WRK.TEXTZ0צcontinuous forms (y/n)? YéyÍmargin:  צ lines/page:   heading: ZZɡ#Zצ [Z(ágޫZ 0؛ٿ ȡ؛ ᩂݩ߭> Z0\/ á צfile to publish: Z áצSYSTEM.WRK.TEXTZ0 %  : |<2#ˍ ᫃Báš "$&(@BD`` $ "(rP 4 áY_ @  á   š    ȡ ꥀA   D D U U B6h AF3 4 áY_ @  á ̷cMa v B D U d š߾ Ä޾ Ä Äނ  áš  ݾ š_ȡ ᫃B(6 ނB݂ Äoݾ š R áC á  š݂   ȡ ?ɡ5áš "$wnto 0 do "begin "move (4-y, 4); "draw (x, y); "end;  y:= 0;  for x:= 3 downto 0 do "begin "move (4, x); "draw (x, y); "end;  x:= 0;  for y:= 1 to 4 do "begin "move (4-y, 0); "draw (x, y); "end;  move (2, 2);  draw (2, 2);  move (0, 0);  endplot;  end.   *****************************************************************************    MR. KIMPEL HAS ANOTHER PROGRAM, CALLED MINIPUB (NOT TO BE CONFUSED WITH THE  MINIPUB LISTED ABOVE AND ON THIS DISK), WHICH USES THE DIABLO UNIT TO FORMAT  LETTERS ANMPLETE PROGRAM BUT IT DOES DRAW  "STRAIGHT" LINES AND WILL SCALE TO THE USER'S COORDINATE SYSTEM.    PLOTTEST.TEXT   THIS IS A SAMPLE PROGRAM WHICH USES THE UNIT IN DIAPLOT TO DRAW A  SIMPLE PLOT.  E FILE, BUT IT COULD BE MERGED INTO THE SYSTEM.LIBRARY AS  DESCRIBED IN 4.2 IN THE APPLE PASCAL REFERENCE MANUAL (PAGE 235).    DIAPLOT.TEXT   THIS IS A PRELIMINARY VERSION OF A UNIT WHICH DRIVES THE DIABLO IN  THE PLOTTER MODE. THIS IS NOT A COEEPING THE CODE IN A UNIT TURNS OUT TO BE QUITE HANDY, AS IT REALLY CUTS DOWN  ON THE COMPILE TIME WHEN INTERFACING THE DIABLO TO A USER PROGRAM. THE BOTHER  OF RUNNING THE LINKER AFTER EACH COMPILE IS WELL WORTH THE TROUBLE. THE CODE  IS IN A SEPARAT DESCRIBED IN 1.8.2 IN THE APPLE PASCAL REFERENCE MANUAL (PAGE 94) TO LINK  THE CODE FOR THE DIABLO UNIT.    DIABLO.TEXT   THIS SHOWS THE DIABLO UNIT. THE DOCUMENTATION FOR THIS CONSISTS OF A FEW  NOTES IN APPENDIX A WHICH SHOULD BE USEFUL.  KSO INCLUDED ON THE DISK. IF YOU WISH TO RECOMPILE THE  PROGRAM, YOU MAY NEED TO CHANGE THE FILE NAME IN THE $U COMMAND ON THE SECOND  LINE OF THE LISTING. AFTER COMPILING, YOU WILL NEED TO RUN THE LINKER AS B.TEXT   THIS SHOWS A SMALL PROGRAM WHICH USES THE DIABLO UNIT (DIABLO.TEXT) TO  PRINT A PASCAL TEXT FILE WITH HEADINGS AND PAGE NUMBERS. THIS IS INCLUDED  TO SHOW HOW THE DIABLO UNIT INTERFACES WITH A USER PROGRAM. THE CODE  FOR THIS PROGRAM IS ALTWARE MAY NOT  BE SOLD, OR INCORPORATED INTO ANY OTHER SOFTWARE WHICH IS SOLD, WITHOUT  THE PRIOR PERMISSION OF THE DONATER NAMED ABOVE. AND OBVIOUSLY, HE CAN  TAKE NO RESPONSIBILITY OR LIABILITY FOR THE USE OF ANY OF THE NAMED SOFTWARE.    MINIPUDOCUMENTATION FOR DIABLO PRINTER CONTROL PROGRAMS   THESE PROGRAMS WERE DONATED TO THE APPLESEED COMPUTER CLUB BY  MR. PAUL H. KIMPEL  2284-150 CAMINITO PAJARITO,  SAN DIEGO, CA 92107   THESE PROGRAMS MAY BE USED WITHIN COMPUTER CLUBS BUT THE SOFN^YYD OTHER DOCUMENTS FROM TEXT FILES PREPARED WITH THE PASCAL SCREEN  EDITOR. IT IS FOR SALE ON DISKETTE AT $100.00, INCLUDING SOURCE AND  DOCUMENTATION.   HE WILL BE GLAD TO ANSWER QUESTIONS OR DISCUSS THE SOFTWARE WITH ANYONE WHO'S  INTERESTED. HIS PHONE NUMBER IS 714-222-8434. HE IS INTERESTED IF BUGS  SHOW UP.   ******************************************************************************    APPENDIX A: DIABLO PRINTER UNIT NOTES    THE DIABLO UNIT IS USED TO DRIVE DIABLO 1600-SERIES THIS ROUTINE SENDS AN ASCII FF CHARACTER TO THE DIABLO, CAUSING IT TO ADVANCE  TO THE TOP-OF-FORM POSITION.    FUNCTION DIABLOCPI (CPI: INTEGER): DIABLOERR;   THIS ROUTINE CHANGES THE HORIZONTAL MOTION INDEX ACCORDING TO THE CHARACTERS  PER INCN", IT RETURNS A VALUE OF "DIAEOF". ANY OTHER RESPONSE CAUSES  THE ROUTINE TO SOUND THE DIABLO'S BELL AGAIN AND WAIT FOR ANOTHER RESPONSE.    FUNCTION DIABLOPAGE: DIABLOERR;  MN 40 IS A GOOD CHOICE FOR THE  INSERTION OF LETTER-SIZED SHEETS OF PAPER).    IF THE USER RESPONSE IS A CARRIAGE RETURN, DIABLOATTN RETURNS A VALUE OF  "DIAOK". IF THE RESPONSE IS THE CHARACTER (USUALLY CONTROL/C), AN UPPER  OR LOWER CASE "HEN INTERFACED THROUGH SLOT 1). THE ROUTINE IS USEFUL  FOR SIGNALLING THE USER THAT THE DIABLO MUST BE SERVICED (E.G., TO INSERT A  NEW PIECE OF PAPER). POSITIONING THE CARRIAGE MAY HELP IN ALIGNMENT OF FORMS,  CHANGING RIBBONS, PRINTWHEELS, ETC (COLU THIS ROUTINE IS USED TO REQUEST A REPLY FROM THE USER. IT POSITIONS THE  CARRIAGE TO "COL" AND SOUNDS THE DIABLO'S BELL. IT THEN WAITS FOR A SINGLE  CHARACTER RESPONSE ON THE CONSOLE: KEYBOARD (THE DIABLO KEYBOARD, IF ANY, IS  IGNORED BY THE APPLE W DURING THE SAME RUN. THE ROUTINE RETURNS THE CARRIAGE TO POSITION ZERO,  SETS THE HORIZONTAL MOTION INDEX TO THE SWITCH SETTING (MODELS 1640/1650  ONLY), AND CLOSES THE PRINTER: FILE.    FUNCTION DIABLOATTN (COL: INTEGER): DIABLOERR;  ES THE CARRIAGE AT HORIZONTAL POSITION ZERO.    FUNCTION DIABLOCLOSE: DIABLOERR;   THIS ROUTINE MAY BE CALLED AFTER THE USER PROGRAM IS FINISHED WITH THE DIABLO.  IT'S USE IS OPTIONAL, BUT MUST BE CALLED IF THE PROGRAM WILL CALL DIABLOOPEN  AGAINIT. IT OPENS  A FILE TO THE PRINTER: DEVICE, SETS THE HORIZONTAL AND VERTICAL MOTION INDEXES  TO THE VALUES OF "CPI" (CHARACTERS PER INCH) AND "LPI" (LINES PER INCH),  RESPECTIVELY, WIGGLES THE DIABLO CARRIAGE TO SIGNAL THE PRINTER IS READY, AND  LEAV BY THE DIABLO UNIT. THE INTERNAL ROUTINE DIABLOACK MAY BE MODIFIED TO SEND AN  ETX AND LOOK FOR THE DIABLO'S ACK RESPONSE.    FUNCTION DIABLOOPEN (CPI, LPI: INTEGER): DIABLOERR;   THIS ROUTINE SHOULD BE CALLED BEFORE ANY OTHER ROUTINE IN THE UNOR THE  DATA TERMINAL READY (PIN 20) LINE ON THE RS-232 CONNECTOR. IT MAY ALSO BE  POSSIBLE TO USE THE ETX/ACK PROTOCOL PROVIDED BY THE DIABLO, BUT IN ORDER FOR  THIS TO WORK, THE PRINTER MUST BE INTERFACED THROUGH A SLOT WHICH CAN BE READ APPROPRIATE ACTION.   IF IT IS DESIRED TO DRIVE THE DIABLO AT A SPEED HIGHER THAN 30 CHARACTERS PER  SECOND, SOME PROVISION MUST BE MADE TO PREVENT THE PRINTER'S BUFFER FROM BEING  OVERRUN. SOME SERIAL INTERFACE CARDS PROVIDE THE CAPABILITY TO MONITHE DIABLO. EACH OF THESE ROUTINES IS DESCRIBED BELOW. EACH ROUTINE  RETURNS A VALUE OF TYPE "DIABLOERR". IF THE VALUE RETURNED IS "DIAOK", THE  ROUTINE COMPLETED SUCCESSFULLY; OTHERWISE AN ERROR WAS ENCOUNTERED, AND THE  USER PROGRAM SHOULD TAKE SOME THIS UNIT CAN BE USED WITH THEM AS WELL. THE UNIT ASSUMES THE PRINTER IS  INTERFACED USING AN ASYNCHRONOUS INTERFACE CARD IN SLOT 1 OF THE APPLE  (PRINTER:).   THE UNIT CONSISTS OF EIGHT ROUTINES WHICH CAN BE CALLED BY A USER PROGRAM TO  CONTROL T PRINTERS BI-DIRECTIONALLY  FROM AN APPLE UCSD PASCAL PROGRAM. BESIDES DIABLO PRINTERS, MOST QUME  SPRINT/5 AND SOME MODELS OF THE NEC SPINWRITER USE THE DIABLO COMMAND SET, SO H VALUE IN "CPI". NOTE THAT SINCE THE HORIZONTAL RESOLUTION OF THE  DIABLO IS 120 INCREMENTS PER INCH, NOT ALL VALUES OF "CPI" CAN BE REPRESENTED  EXACTLY. FOR EXAMPLE, A "LPI" VALUE OF 11 WILL ACTUALLY PRINT AT ABOUT 10.9  CHARACTERS PER INCH.    FUNCTION DIABLOLPI (LPI: INTEGER): DIABLOERR;   THIS ROUTINE CHANGES THE VERTICAL MOTION INDEX ACCORDING TO THE LINES  PER INCH VALUE IN "LPI". NOTE THAT SINCE THE VERTICAL RESOLUTION OF THE  DIABLO IS 48 INCREMENTS PER INCH, NOT ALL VALUES OF "LPIN^Ǡ"S DIABLOPRINT.  H. ( (  BY DEFAULT, THE TEXT STRING STARTS WITH ALL FORMATTING COMMANDS RESET. ALL  COMMANDS ARE RESET AUTOMATICALLY AT THE END OF THE LINE (THUS COMMANDS WILL  NOT CARRY OVER FROM LINE TO LINE). IN ALL OTHER RESPECTS THIS ROUTINE WORKS  THE SAME A(THIS CHARACTER CAUSES THE DIABLO TO BACKSPACE ONE COLUMN. IT MAY (BE USED TO PRODUCE OVERSTRUCK CHARACTERS. ( ( %CHR(SSP) (THIS CHARACTER STARTS A STRING OF SHADOW TEXT. EACH CHARACTER IS (PRINTED TWICE, WITH THE TWO IMPRESSIONS OFFSET BY 1/60 INCD) (THIS CHARACTER STARTS A STRING OF SUBSCRIPT TEXT. EACH CHARACTER (IS PRINTED ONE HALF-LINE BELOW THE NORMAL LINE. ( ( %CHR(BEL) (THIS CHARACTER SOUNDS THE DIABLO'S BELL. ( ( %CHR(BS) NG OF BOLD FACE TEXT. EACH CHARACTER (IS PRINTED TWICE, WITH THE TWO IMPRESSIONS OFFSET BY 1/120 INCH. ( ( %CHR(SSU) (THIS CHARACTER STARTS A STRING OF SUPERSCRIPT TEXT. EACH CHARACTER (IS PRINTED ONE HALF-LINE ABOVE THE NORMAL LINE. ( ( %CHR(SS) ) %CHR(SAC) (THIS CHARACTER SHIFTS THE RIBBON TO THE ALTERNATE COLOR (NO RIBBON (FOR STANDARD RIBBONS, RED FOR TWO-COLOR RIBBONS). ( ( %CHR(SUS) (THIS CHARACTER STARTS A STRING OF UNDERSCORED TEXT. ( ( %CHR(SBF) (THIS CHARACTER STARTS A STRI SPECIAL FORMATTING OF PORTIONS OF THE TEXT. CONSTANTS DEFINING THE FORMATTING  COMMANDS ARE PROVIDED IN THE INTERFACE SECTION OF THE DIABLO UNIT. THEY ARE:  %CHR(EFC) )THIS CHARACTER ENDS ANY FORMATTING COMMANDS THAT MAY BE CURRENTLY IN )EFFECT. IATEXT; MARGIN, SPACING: INTEGER): DIABLOERR;   THIS ROUTINE IS SIMILAR TO DIABLOPRINT, BUT DOES NOT PRINT BI-DIRECTIONALLY.  IT EXAMINES THE STRING IN "TEXT" FOR SPECIAL CHARACTERS WHICH CAUSE IT TO DO DIABLO (ANY LEFT AND RIGHT MARGINS SET ON THE DIABLO ARE  IGNORED BY THIS ROUTINE). "SPACING" IS THE NUMBER OF LINES TO SPACE AFTER  PRINTING THE LINE OF TEXT. VALUES LESS THAN ZERO ARE CONSIDERED TO BE ZERO.    FUNCTION DIABLOFORMAT (VAR TEXT: D  "TEXT" IS A UCSD PASCAL STRING CONTAINING THE LINE TO BE PRINTED. ANY  CHARACTERS COLLATING LESS THAN AN ASCII SPACE ARE PRINTED AS A "?". "MARGIN"  IS THE NUMBER OF COLUMNS THE FIRST CHARACTER OF "TEXT" IS TO BE INDENTED FROM  POSITION ZERO ON THE THIS ROUTINE PRINTS LINES OF TEXT BI-DIRECTIONALLY ON THE DIABLO. THE ROUTINE  COMPRESSES ALL STRINGS OF MORE THAN THREE BLANKS, GENERATES ABSOLUTE TAB  COMMANDS, AND SENSES WHICH DIRECTION WILL PRODUCE THE SHORTEST CARRIAGE TRAVEL  FOR EACH LINE.  " CAN BE REPRESENTED  EXACTLY. FOR EXAMPLE, A "LPI" VALUE OF 7 WILL ACTUALLY PRINT AT ABOUT 6.86  LINES PER INCH.    FUNCTION DIABLOPRINT (VAR TEXT: DIATEXT; MARGIN, SPACING: INTEGER): DIABLOERR;  1 end; { for loop } -end; { if M > 0 } (end; { while not eof } &CLOSE(UNTFID,LOCK); $ $END; { multiple copies loop }   WRITELN(FID1,CHR(12));  END. RAY,2); *if M > 0 then -begin 0if M = 2 then M := 1023 else M := 511; 0for J := 0 to M do 3begin 6write(FID1,CHARARRAY[J]); 6if CHARARRAY[J] = chr(13) then 9begin = MAXLNO then PRTPAGE; ');READLN(QUEK>0 THEN )BEGIN +IF K = 2 THEN K := 1023 ELSE K := 511; & FOR J := 0 TO K .DO IF CHARARRAY [J] = CHR (13) 1THEN I := SUCC(I); )END; $END; { while not eof } $ "CLOSE(UNTFID); $ "PAGES := I DIV MAXLNO + 1; " := CONCAT(ANS,'.TEXT'); { so try w/ .text on end } 'RESET(UNTFID,ANS); %END; "(*$I+*) % "if IORESULT > 0 then writeln('That file couldnt be found'); % "I := 0; PGNO := 0; "WHILE NOT EOF(UNTFID) DO $BEGIN &K := BLOCKREAD(UNTFID,CHARARRAY,2); &IF UNT LINES *) "{ Line count routine by Frank Monaco originally $modified for blockreads by Jim Gagne $modified for this program by Lee Meador } $ "(*$I-*) "RESET(UNTFID,ANS); { Try the file name as entered } "IF IORESULT > 0 THEN %BEGIN 'ANS %until length(LEFTSTR)=LEFTMARG; { left margin } " "WRITELN (CHR(12)); "GOTOXY(0,12); "WRITELN('PRINT A FILE ON THE LINE PRINTER'); "WRITELN(''); "WRITELN('WHAT FILE DO YOU WANT? (DEV:FILENAME)'); "READLN(ANS); " "(* READ ALL OF INPUT FILE AND COES*) & &WRITE(FID1,CHR(12)); (* FORM FEED *) &FOR I := 1 TO TOPMARG DO (WRITELN(FID1,''); & &PGNO := PGNO+1; & &I := 1; (* RESET LINE COUNT *) $END;   BEGIN " "LEFTSTR := ' '; "repeat LEFTSTR := concat(LEFTSTR,' ') TRING[LEFTMARG]; $FID1,FID2 : TEXT; (* FILE VAR *) $UNTFID : file; $RAWDATE : STRING [8]; $NICEDATE : STRING [9]; $CHARARRAY : PACKED ARRAY [0..1023] OF CHAR; #   PROCEDURE PRTPAGE; $ $BEGIN & &(* TOP OF FORM THEN SOME BLANK LIN PUT IT TO THE #PRINTER IN PAGED FORM FOR A SPECIFIED #NUMBER OF PRINTOUTS *) #  CONST #MAXLNO = 54; #TOPMARG = 6; #LEFTMARG = 8; #  VAR I,J,K,L,M,N: INTEGER; (* COUNTERS *) $PAGES,PGNO : INTEGER; $ANS,QUES : STRING[80]; $LEFTSTR : S (* FROM THE HARVEST, VOL 2, NO 2 *)  (* BY 'PASCAL PETE', EDITOR DAVE ALPERT*)   (* MODIFIED FOR PAGE HEADS - 7 NOV 80 BY LEE MEADOR *)  (* MODIFIED FOR BLOCKREADS - 18 NOV 80 BY LEE MEADOR *)   PROGRAM PRINTAPAGE;   (* TAKE A Text file AND(**************************************)  (* *)  (* Program to modify the BIOS modules *) (* to work with Dan Paymar's lower *) (* case adapter for both input and *)  (* output. *)  (*N^a̡#TURNTO(0); #MOVE(35*7); #TURN(-90); #MOVE(9*10); #TURN(-90); #MOVE(35*7); #TURN(-90); #MOVE(9*10); #PENCOLOR(NONE); # #J := J-30; #MOVETO(16,J); #WSTRING('Push to exit '); #WCHAR(CHR(127)); # #READLN(A); $ "END. " I:=0 TO 3 DO #BEGIN $ %J:=J-20; %MOVETO(16,J); %WCHAR(CHR( 32)); %FOR K:=0 TO 31 DO WCHAR(CHR(I*32+K)); %WCHAR(CHR( 32)); & #END; % #J:=J-10; #MOVETO(16,J); # #(* FOR I:=0 TO 33 DO WCHAR(CHR(95)); *) $ #MOVETO(16,150); #PENCOLOR(WHITE);  PROGRAM LOOKIT;   (*DISPLAY CHARACTERS IN TURTLEGRAPHICS*)   USES TURTLEGRAPHICS;   VAR I,J,K: INTEGER; & A: STRING [1]; &  BEGIN "J:=150;  "INITTURTLE; "MOVETO(16,J); "CHARTYPE(6); " "(* FOR I:=0 TO 33 DO WCHAR(CHR(95)); *) # "FORN^R *)  (* Author :Craig W. Vaughan *)  (* Date :April 5, 1980 *)  (* Revision :1.0 *)  (* *)  (* REVISED :LEE MEADOR *)  (* DATE :DECEMBER 28, 1980 *)  (* REVISION :1.1 (FOR PASCAL 1.1) *)  (* (NOTE: INPUT IS NOT SUPPORTED HERE *)  (* *)  (*$Copyright 1980 by Craig W. Vaughan *)  (* Permission is hereby granted for *)  PAGE(OUTPUT);(*BLANKS SCREEN*) "GOTOXY(12,12);(*SETS SHORT LINE IN CENTER OF SCREEN*) "WRITELN('MODE USE IN PASCAL'); "WAIT(05000); "WRITELN(HOME,ERASEOS); "WRITELN;WRITELN;WRITELN; "WRITELN('THE VIEWPORT IS ''50,200,30,160'''); "WRITELN;WRITELN$3: PENMODE:=VIOLET; $4: PENMODE:=BLUE; $5: PENMODE:=WHITE1; $6: PENMODE:=WHITE2 "END(*CASE*); "WRITELN;WRITELN('YOU SELECTED PENMODE ',SELECTED); "WAIT(3000); "WRITELN(HOME,ERASEOS);  END(*MODESELECT*); "  PROCEDURE HEADER;  BEGIN ('1) ORANGE'); "WRITELN('2) GREEN '); "WRITELN('3) VIOLET'); "WRITELN('4) BLUE '); "WRITELN('5) WHITE1'); "WRITELN('6) WHITE2'); "WRITELN;WRITE('ENTER YOUR CHOICE '); "READLN(SELECTED); "CASE SELECTED OF $1: PENMODE:=ORANGE; $2: PENMODE:=GREEN; PROCEDURE WAIT(TIME:INTEGER);  VAR DELAY:INTEGER;  BEGIN "FOR DELAY:=1 TO TIME DO;  END; "  PROCEDURE MODESELECT;  VAR SELECTED:INTEGER;  BEGIN "WRITELN(HOME,ERASEOS); "WRITELN('ENTER THE MENU NUMBER SHOWN FOR DESIRED MODE'); "WRITELN; "WRITELNPROGRAM GRAFTEST;   USES APPLESTUFF,TURTLEGRAPHICS;   TYPE INT=INTEGER;   VAR CH:CHAR; "MODE,DELAY:INT; "S:STRING[20]; "A:ARRAY[0..15] OF STRING[2]; "HOME,ERASEOS:CHAR; "PENMODE:SCREENCOLOR;(*TYPE SCREENCOLOR DEFINED IN TURTLEGRAPHICS*) "  N^סء(ptch,S); #block5; #CLOSE (ptch,LOCK);  END. % % ln); END; # %  BEGIN #PAGE(OUTPUT); #GOTOXY(0,10); #WRITE('Name of disk? >> '); #READLN (S); #IF POS (':',S) > 0 THEN %S := CONCAT (S,'SYSTEM.APPLE') #ELSE %S := CONCAT (S,':SYSTEM.APPLE'); #WRITELN; #WRITELN ('Updating ',S,'...'); #RESET #blk: PACKED ARRAY[0..511] OF 0..255; #blt,bln: INTEGER; #ptch : FILE; #S:STRING;  PROCEDURE block5;  #BEGIN %bln := 5; %blt := BLOCKREAD(ptch,blk,1,bln); %blk[171] := 176; %blk[172] := 002; %blk[410] := 000; %blt := BLOCKWRITE(ptch,blk,1,b (* duplication for non-commercial *)  (* purposes. *)  (* All other rights reserved. *)  (* *)  (**************************************)  PROGRAM lcpatch; VAR ('THE DISPLAY IS IN THE SELECTED COLOR '); "WRITELN (' THEN THE INVERSE OF THAT COLOR'); "WRITELN;WRITELN('MODES SHOWN ARE 2,5,10, AND 14'); "WRITELN (' ENTER OTHER DESIRED MODES WHEN ASKED'); "WRITELN;WRITELN('MODES ARE AS DESCRIBED'); "WRITELN(' ON PAGE 180A OF THE MANUAL'); "WAIT(30000); "WRITELN(HOME,ERASEOS);  END;   PROCEDURE MODESHOW(COUNT:INTEGER);  BEGIN 'S:='THIS IS MODE '; &TEXTMODE; &GOTOXY(5,2); &WRITELN(S,COUNT,CHR(16)); &WAIT(2000); &INITTURTLE; &MOVE(STA @2,Y (PUSH RETURN (RTS ;RETURN ( (.FUNC ANDFUNC,2  RETURN .EQU 0 (POPF RETURN (PLA ; LOW ORDER BYTE (STA 2 (PLA ; DISCARD MOST SIGNIFICANT BYTE (PLA ETURN VALUE (LSB) (PHA ;RETURN LSB OR RETURN VALUE (PUSH RETURN (RTS ;RETURN ( (.PROC POKE,2  RETURN .EQU 0 (POP RETURN (PLA (TAX (PLA (PLA (STA 2 (PLA (STA 3 (LDY #0 (TXA .FUNC PEEK,1  RETURN .EQU 0 (POPF RETURN (PLA (STA 2 ;LSB OF ADDRESS (PLA (STA 3 ;MSB OF ADDRESS (LDA #0 (PHA ;STORE MSB OF RETURN VALUE (TAY (LDA @2,Y ;FETCH R ;SAVE RETURN (for functions)  ; SAVE RETURN ADDRESS (functions only) (POP %1 (PLA ;IGNORE SLACK BYTES (PLA (PLA (PLA (.ENDM  ;  ;***************************************************************************  ;  .MACRO POP ;POP 1 WORD(16 bit) ARGUMENT  ; POP 1 WORD (PLA (STA %1 (PLA (STA %1+1 (.ENDM ( (.MACRO PUSH ;PUSH 1 WORD  ; PUSH 1 WORD (LDA %1+1 (PHA (LDA %1 (PHA (.ENDM ( (.MACRO POPF O^ASEOS); 'MODESELECT; 'MODESHOW(MODE); %END; %WRITELN(HOME,ERASEOS); #UNTIL MODE = 0;  END(*MAIN PROGRAM*). THER MODE'); %WRITELN;WRITELN(' ENTER THE MODE NUMBER WHEN PROMPTED'); %WRITELN;WRITELN('IF DONE ENTER 0...'); %GOTOXY(0,15); %WRITE('ENTER MODE NUMBER OR 0, THEN RETURN '); %READLN(MODE); %IF (MODE>0) AND (MODE<16) THEN %BEGIN 'WRITELN(HOME,ER*MOVES CURSOR TO HOME POSITION*) #HEADER; #MODESELECT; #MODE:=2; #MODESHOW(MODE); #MODE:=5; #MODESHOW(MODE); #MODE:=10; #MODESHOW(MODE); #MODE:=14; #MODESHOW(MODE); #REPEAT %WRITELN(HOME,ERASEOS); %WRITELN;WRITELN('IF YOU DESIRE TO ENTER ANY O#A[0]:=' 0';A[1]:=' 1';A[2]:=' 2'; #A[3]:=' 3';A[4]:=' 4';A[5]:=' 5'; #A[6]:=' 6';A[7]:=' 7';A[8]:=' 8'; #A[9]:=' 9';A[10]:='10';A[11]:='11'; #A[12]:='12';A[13]:='13';A[14]:='14'; #A[15]:='15'; #ERASEOS:=(CHR(12));(*ERASES SCREEN*) #HOME:=CHR(25);(TO(72,90); &VIEWPORT(50,200,30,160); &FILLSCREEN(PENMODE); &CHARTYPE(COUNT); &S:=CONCAT(S,A[COUNT]); &WSTRING(S); &WAIT(2700);; &FILLSCREEN(REVERSE); &WAIT(2200); $TEXTMODE; "END(*MODESHOW*);    BEGIN(*MAIN PROGRAM*) ; LOW ORDER BYTE OF ARG 2 (STA 3 (PLA ; DISCARD MOST SIGNIFICANT BYTE (LDA #0 (PHA ; MSB OF RETURNED VALUE (LDA 2 (AND 3 ; ANDFUNC := ARG1 AND ARG2 (8 BITS) (PHA (PUSH RETURN (RTS ; RETURN ( (.FUNC XBYTES,1  RETURN .EQU 0 (POPF RETURN (PLA ; LOW ORDER BYTE OF ARG (STA 2 (PLA ; HIGH ORDER BYTE OF ARG (STA 3 (LDA 2 (PHA PEEK PEEK POKE POKE ANDFUNC ANDFUNC XBYTES XBYTES INVERSE INVERSE FLASH FLASH NORMAL NORMAL  >\hhhhhhhhHHHH`&hhhhhhHH`$hhhhhhhhhhH%HHH`*hhhhhhhhHHHH`&ح`@ح`ح`'II.0 [d.4] PEEK  ;*******************************************************************************   .END  ; SETS BIT 7 FOR NORMAL MODE (LDA 0C088 ; SELECT 1ST BANK & WRITE- (RTS ; PROTECT, THEN RETURN (;................................................................. ( S ; PROTECT, THEN RETURN (;................................................................. ( (.PROC NORMAL (LDA 0C083 ; SELECT 2ND 4K BANK (LDA 0C083 ; AND WRITE-ENABLE (LDA #80 (STA 0D8ED ................... ( (.PROC FLASH (LDA 0C083 ; SELECT 2ND 4K BANK (LDA 0C083 ; AND WRITE-ENABLE (LDA #40 (STA 0D8ED ; SETS BIT 6 FOR FLASH MODE (LDA 0C088 ; SELECT 1ST BANK & WRITE- (RT(LDA 0C083 ; AND WRITE-ENABLE (LDA #00 (STA 0D8ED ; CLEARS BITS 6 & 7 (LDA 0C088 ; SELECT 1ST BANK & WRITE- (RTS ; PROTECT, THEN RETURN (;.............................................. ; RETURN LOW ORDER BYTE AS HIGH ORDER BYTE (LDA 3 (PHA ; RETURN HIGH ORDER BYTE AS LOW ORDER BYTE (PUSH RETURN (RTS ; RETURN ( (.PROC INVERSE (LDA 0C083 ; SELECT 2ND 4K BANK N^ '); #WRITELN(' '); #BOTTOM; #PAUSE;  END(*INFOPAGE*);   BEGIN(*MAIN PROGRAM*) #ERASEOL:=CHR(16);ERASEOS:=CHR(11); #ERASE:=CHR(12);HOME:=CHR(25); #WRITELN(HOME,ERASE); #HEADER; #INFOPAGE '); #WRITELN(' WRITE(''AND THIS SHOULD BE''); '); #WRITELN(' INVERSE; '); #WRITELN(' WRITELN(''INVERSE''); '); #WRITELN(' NORMAL; '); #WRITELN('END. #WRITELN(' GOTOXY(0,10); '); #WRITELN(' WRITE(''THIS SHOULD BE''); '); #WRITELN(' FLASH; '); #WRITELN(' WRITELN(''FLASHING''); '); #WRITELN(' NORMAL; TERNAL; '); #WRITELN('PROCEDURE NORMAL; EXTERNAL; '); #WRITELN('PROCEDURE FLASH; EXTERNAL; '); #WRITELN(' '); #WRITELN('BEGIN '); #WRITELN(' AS THE'); #WRITELN('LIBRARY FILE'); #WRITELN;WRITELN; #BOTTOM; #PAUSE;  END(*HEADER*); #  PROCEDURE INFOPAGE;  BEGIN #WRITELN(HOME);WRITELN; #WRITELN(' THE TEXT OF THE ESSENTIAL FOLLOWS:'); #WRITELN; #WRITELN('PROCEDURE INVERSE; EXIB1: DISK'); #WRITELN;WRITELN('ONCE YOU COMPILE YOUR PROGRAM YOU MUST'); #WRITELN('USE THE LINKER AS IN THE EXAMPLE ON '); #WRITELN('PAGE 106 OF THE PASCAL REFERENCE'); #WRITELN;WRITE('BE SURE TO USE '); #INVERSE; #WRITE('LIB1:TEMPLIB1'); #NORMAL; #WRITELN('THESE PROCEDURES ARE ENTERED AS EXTERNAL '); #WRITELN;WRITELN(' PROCEDURE FLASH; EXTERNAL;'); #WRITELN(' PROCEDURE NORMAL; EXTERNAL;'); #WRITELN; #WRITELN('THESE PROCEDURES ARE CONTAINED IN THE'); #WRITELN(' TEMPLIB1 LIBRARY ON THE LRASE); #WRITELN; #WRITELN('THIS SHORT PROGRAM USES THE LIBRARY '); #WRITE(' ROUTINES '); #FLASH; #WRITE('FLASH');NORMAL;WRITE(', '); #INVERSE; #WRITE('INVERSE'); #NORMAL; #WRITELN(' AND NORMAL'); #WRITELN; UNTIL KEYPRESS;READ(KEYBOARD,CH);  PAGE(OUTPUT);  END(*PAUSE*);   PROCEDURE HEADER;  BEGIN #GOTOXY(12,12); #FLASH; #WRITE('FLASH'); #NORMAL; #WRITE(' '); #INVERSE; #WRITE('INVERSE'); #NORMAL; #WRITELN(' DEMO'); #WAIT(7500); #WRITELN(HOME,E EXTERNAL;  PROCEDURE FLASH ; EXTERNAL;  "  PROCEDURE BOTTOM;  BEGIN #WRITE('***** HIT '); #FLASH; #WRITE('ANY'); #NORMAL; #WRITELN(' KEY TO CONTINUE*****');  END(*BOTTOM*);   PROCEDURE PAUSE;  VAR CH:CHAR;  BEGIN  REPEAT #WAIT(200);  PROGRAM TESTSTUFF;   USES APPLESTUFF;   VAR I,CTR:INTEGER;  ERASEOL,ERASEOS,HOME,ERASE:CHAR;   PROCEDURE WAIT(TIME:INTEGER);  VAR DELAY:INTEGER;  BEGIN "FOR DELAY:=1 TO TIME DO;  END;   PROCEDURE INVERSE; EXTERNAL;  PROCEDURE NORMAL; ; #WRITELN(HOME,ERASE); #GOTOXY(0,10); #WRITE('THIS SHOULD BE '); #FLASH; #WRITELN('FLASHING'); #NORMAL; #WRITELN; #WRITE('AND THIS SHOULD BE '); #INVERSE; #WRITELN('INVERSE'); #NORMAL; #WRITELN;WRITELN;WRITELN('*****HIT ANY KEY TO END*****'); #PAUSE; #PAGE(OUTPUT);  END. צ'       צTHIS SHOULD BE FLASHINGAND THIS SHOULD BS SHOULD BE'); צ' INVERSE; % WRITELN('INVERSE'); צ' NORMAL; 'END. % WRITE('THIS SHOULD BE'); צ' FLASH; % WRITELN('FLASHING'); צ' NORMAL; % WRITE('AND THI צ'PROCEDURE FLASH; EXTERNAL; ' צ'BEGIN $ GOTOXY(0,10); צ LIBRARY FILE% THE TEXT OF THE ESSENTIAL FOLLOWS:צ'PROCEDURE INVERSE; EXTERNAL; 'PROCEDURE NORMAL; EXTERNAL; &ONCE YOU COMPILE YOUR PROGRAM YOU MUST$USE THE LINKER AS IN THE EXAMPLE ON  PAGE 106 OF THE PASCAL REFERENCEBE SURE TO USE צ LIB1:TEMPLIB1 AS THE EXTERNAL  PROCEDURE FLASH; EXTERNAL; PROCEDURE NORMAL; EXTERNAL;%THESE PROCEDURES ARE CONTAINED IN THEצ% TEMPLIB1 LIBRARY ON THE LIB1: DISKLצ&THIS SHORT PROGRAM USES THE LIBRARY צ ROUTINES FLASHצ, צINVERSE AND NORMALצ)THESE PROCEDURES ARE ENTERED ASȡ ***** HIT ANYצ KEY TO CONTINUE*****Z "* צFLASH INVERSEצ DEMO' TESTSTUF E צINVERSE*****HIT ANY KEY TO END*****  * 6ح`@ح`ح`@ p & F f M1 ERROR ^JN^); $WRITELN(' PAGE(OUTPUT);'); $SUBBORDER; $GOTOXY(19,22); $WRITELN('EXIT PROGRAM',ERASEOL,ERASEOS);  END;   PROCEDURE HELLO;  BEGIN  GOTOXY(0,21); $WRITELN(BORDER,BORDER,BORDER,BORDER); $WRITELN('I WILL WRITE SEVERAL LINES ABOVE'); $WASE := CHR(12)...'); $WRITELN;WRITELN('FOR EXAMPLE:'); $WRITELN; $WRITELN(' WRITELN(HOME,''HELLO THERE'');'); $WRITELN(' WRITELN(''HELLO'',ERASEOS);'); $WRITELN(' WRITELN(HOME,ERASE);'); $WRITELN(' WRITELN(HOME,''HI THERE'',ERASEOL);'$WRITELN(BORDER,BORDER,BORDER,BORDER); $WRITELN('HOME':10,' IS CHAR ','25':4); $WRITELN('ERASE':10,' IS CHAR ','12':4); $WRITELN('ERASEOL':10,' IS CHAR ','16':4); $WRITELN('ERASEOS':10,' IS CHAR ','11':4); $WRITELN;WRITELN; $WRITELN('FORMAT...ERHE PROGRAM THE FORMAT WOULD BE: '); #WRITELN;WRITELN(' WRITELN(HOME,''MESSAGE'');'); #WRITELN(' OR WRITELN(''MESSAGE'',ERASEOS);'); #SUBBORDER;  PAUSE;  END;   PROCEDURE TABLE;  BEGIN $PAGE(OUTPUT); $WRITELN('TABLE OF CHARACTERS: '); IABLES');WRITELN; #WRITELN('ERASE := CHR(12); ERASEOL := CHR(16);'); #WRITELN(' HOME := CHR(25); ERASEOS := CHR(11);'); #WRITELN;WRITELN('''OL'' MEANS TO END-OF-LINE'); #WRITELN('''OS'' MEANS TO END-OF-SCREEN'); #WRITELN;WRITELN; #WRITELN('IN TLN(HOME,ERASE); #PAGE(OUTPUT); #WRITELN('TO ERASE IN PASCAL SET UP YOUR VARIABLE'); #WRITELN('SECTION AS SHOWN BELOW: ');WRITELN;WRITELN; #WRITELN(' VAR ERASE,ERASEOS,ERASEOL,HOME:CHAR;'); #WRITELN;WRITELN; #WRITELN('IN THE MAIN SECTION SET THE VAR"PAGE(OUTPUT); "WAIT(3700); "GOTOXY( 2,12); "WRITELN('...THAT''S WHAT ''PAGE(OUTPUT);'' DOES'); "SUBBORDER; "PAUSE;  END;   PROCEDURE TITLE;  BEGIN #PAGE(OUTPUT); #GOTOXY(12,12); #WRITELN('ERASING IN PASCAL'); #CTR:=0; #WAIT(5000); #WRITES TO USE ''PAGE'''); "WRITELN;WRITELN('WHEN STARTING A NEW PAGE IN YOUR PROGRAM PUT:'); "WRITELN;WRITELN(' PAGE(OUTPUT);'); "GOTOXY(0,21); "WRITELN(BORDER,BORDER,BORDER,BORDER); "WRITELN('I WILL DO A ''PAGE(OUTPUT)'' NOW'); "WAIT(14000); E(' HIT '); #FLASH; #WRITE('ANY'); #NORMAL; #WRITELN(' KEY TO CONTINUE PROGRAM ',ERASEOS);  END;   PROCEDURE PAGER;  BEGIN "PAGE(OUTPUT); "GOTOXY(5,10); "WRITELN('AN EXCELLENT WAY TO REMOVE ALL THE '); "WRITELN('TRASH FROM THE SCREEN IEGIN "FOR DELAY:=1 TO TIME DO;  END; "  PROCEDURE PAUSE;  VAR CH:CHAR;  BEGIN  REPEAT #WAIT(200);  UNTIL KEYPRESS;  READ(CH);  END(*PAUSE*);   PROCEDURE SUBBORDER;  BEGIN #GOTOXY(0,21); #WRITELN(BORDER,BORDER,BORDER,BORDER,ERASEOS); #WRIT PROGRAM ERASEDEMO;   USES APPLESTUFF;   CONST BORDER='**********';  VAR I,CTR:INTEGER;  ERASEOL,ERASEOS,HOME,ERASE:CHAR;   PROCEDURE FLASH; EXTERNAL;  PROCEDURE NORMAL; EXTERNAL;   PROCEDURE WAIT(TIME:INTEGER);  VAR DELAY:INTEGER;  BRITE(' THEN ''WRITELN(HOME)'''); $WAIT(7000); $GOTOXY(0,7); $FOR I:= 1 TO 10 DO $BEGIN &WRITELN('HELLO THIS IS A TEST LINE...'); $END; $WRITELN;WRITELN('HERE COMES ''WRITELN(HOME)''...',ERASEOS); $WAIT(9000);  END;   PROCEDURE DEMOHOME;  BEGIN #WRITELN(HOME,ERASE,'THIS IS HOME'); #WRITELN('I GOT TO LINE ABOVE BY USING'); #WRITELN('''WRITELN(HOME)'''); #SUBBORDER; #PAUSE; #PAGE(OUTPUT); #HELLO; #WRITELN(HOME,'TRYING HOME....WELL IT WORKED, I AM HERE'); #GOTOXY(0,21); #WRITELN(*********************************)   (* TEST ... INPUT & DISPLAY BOOT VOLUME AND SYSTEM DATE*)   const months = 'Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec '; !type (date = packed record 3mm : 0..15; 3dd : 0..31; 3yy : 0..127; (end;  * PASCAL SYSTEM (EX: 26-JUL-79). *)  (* *)  (* WHILE INTERESTING IN TEXT FORM *)  (* *)  (* COMPILED CODE NOT INCLUDED HERE. *)  (* *)  (****  (*************************************)  (* *)  (* THIS ROUTINE IF COMPILED WOULD *)  (* *)  (* SIMPLY DISPLAY THE DATE IN THE *)  (* *)  (O^AGER; #ERASEOL:=CHR(16);ERASEOS:=CHR(11); #ERASE:=CHR(12);HOME:=CHR(25); #DEMOHOME; #DEMHOME2; #TABLE;PAUSE; #PAGE(OUTPUT); "END. #WRITELN(BORDER,BORDER,BORDER,BORDER); #WRITELN('NOTE THAT ONLY THE LAST PART OF'); #WRITE('THE FIRST LINE WAS ERASED BY ''ERASEOL'''); #WAIT(12000); #GOTOXY(0,15);WRITELN(ERASEOS); #SUBBORDER; #PAUSE;  END;   BEGIN(*MAIN PROGRAM*) #TITLE; #PERASE THE REST OF A LINE'); #WRITELN('I WILL OVERWRITE THE FIRST LINE ABOVE '); #WRITELN('WITH A SHORTER LINE THEN ''ERASEOL'''); #SUBBORDER; #PAUSE; #WRITELN(HOME,'OOPS.....',ERASEOL); #GOTOXY(0,15);WRITELN(ERASEOS); #GOTOXY(0,21); N('I DID ABOVE BY WRITING THE STATEMENT'); #WRITE('THEN ''WRITELN(ERASEOS);''',ERASEOS); #WAIT(12000); #SUBBORDER; #PAUSE;  END;   PROCEDURE DEMHOME2;  BEGIN #WRITELN(HOME,ERASE); #WRITELN(HOME,'NOW HIT ANY KEY AND I WILL TRY TO'); #WRITELN(' BORDER,BORDER,BORDER,BORDER); #WRITELN('NOTE: AS IN BASIC ''HOME'' ERASES NOTHING'); #WAIT(12000); #SUBBORDER; #PAUSE; #WRITELN(HOME,'NOW I WILL TRY TO ERASE TO END OF SCREEN',ERASEOS); #GOTOXY(0,21); #WRITELN(BORDER,BORDER,BORDER,BORDER); #WRITEL  var inword,unitno,i,j,k :integer; ( (dummy: boolean; ( (monthnames: record 0case dummyaccress: boolean of 0true:(monthwork : packed array [1..48] of char);  false:(monthtable : packed array [1..12] of ( record ;monthname: packed array[1..3] of char ;end); 0end; ; (datablock : record ( header:packed array [0..19] of char; ( voldate: date; 0xxx: packed array[22..511] of char; (end; ( !begin ! ! unitno := 4;,ERASE); $WRITELN(BORDER,BORDER,BORDER,BORDER); $  (*END MAIN PROGRAM*)   (***** ENDS ERASE2 *****) CONT2 *****) & &  (***** STARTS ERASE1 *****) "  CONST BORDER='**********';  VAR I,CTR:INTEGER;  ERASEOL,ERASEOS,HOME,ERASE:CHAR;  BEGIN(*MAIN PROGRAM*) "ERASEOL:=CHR(16);ERASEOS:=CHR(11); "ERASE:=CHR(12);HOME:=CHR(25); $WRITELN(HOME (***** BEGINS CONT1 *****)   PROCEDURE CONTINUE;(*REQUIRES PROCEDURE 8 PAUSE*)  BEGIN #GOTOXY(0,22); #WRITELN(BORDER,BORDER,CHR(11)); #WRITE(' HIT ANY KEY TO CONTINUE... '); #PAUSE;  END(*CONTINUE*);  (***** ENDS  UNTIL KEYPRESS;(*REQUIRES USES APPLESTUFF*)  READ(KEYBOARD,CH);(*NECESSARY TO RESET -KEYPRESS...USE OF KEYBOARD -PREVENTS ECHOING OF "CH" -INPUT...*)  PAGE(OUTPUT);(*SOME PROGRAMS MAY NOT REQUIRE THIS*)?  END(*PAUSE*);  IMER,DELAY:INTEGER;  BEGIN "WHILE TIME > 0 DO "BEGIN $IF TIME > 19 THEN TIMER:= 19 'ELSE TIMER := TIME MOD 19; $FOR DELAY:=1 TO (TIMER * 1600) DO; $TIME := TIME - TIMER; "END(*WHILE*);  END; "  PROCEDURE PAUSE;  VAR CH:CHAR;  BEGIN  REPEAT THAN 1/4 SECOND.)  (* )  (* FOR EXAMPLE: 'WAIT(24)' WILL DELAY )  (* 24 SEC )  (* )  (***************************************)  VAR TPROGRAM PROCLIB;    PROCEDURE WAIT(TIME:INTEGER);  (***************************************)  (* )  (* THE INTEGER TIME SHOULD BE IN )  (* SECONDS. THIS PROCEDURE IS )  (* ACCURATE TO LESSWAIT1 WAIT2 ERASE1 ERASE2 PAUSE1 PAUSE2 CONT1 CONT2 "4O^ % %monthnames.monthwork := months; % %unitread(unitno,datablock,512,2,0); % - ' with datablock.voldate do - 0begin 0 3writeln(dd,'-',monthnames.monthtable[mm].monthname,'-',yy); - 0end; & !end. !  DCCTL PROGRAM DCCONTROL; ${THIS PROGRAM IS THE DRIVER FOR THE MACHINE LANGUAGE PROGRAM DCCTL}  PROCEDURE DCCTL; "EXTERNAL;  BEGIN  DCCTL;  END.  N^DCCTL DCCTL  ɀɂ     aɀɂ     ɀ L(`O2)  ~}snlihfcb^]32(#!  J)`  )  `     `  `)))`  )  `    l`)q    ``0)`x  F  ; Nɀ ɁXH #h  l 8ˆ`! ``)$)  )`) ` `  `)$)  L'II.0 [d.4]  )`  )  `     `  `)))`  )  `    l`)q    ``0)`x  F  ; Nɀ 8ˆ`! ``)$)  )`) ` `  `)$) L' DCCONTRO  #[.GC .צE&Save as :. ? 瓡צSave asצ[š C?/צTEXT#CODE#饀!DCCTL   d66.6.6 65ݪ   p "٪ؓצ *SYSTEM.WRK.,C:[., #[.GC .צE&Save as :. ? 瓡צSave asצ[š C?/צTEXT#CODE#饀! 54=5  d66.6.6 65ݪ   p "٪ؓצ *SYSTEM.WRK.,C:[.," DCCONTRO ɁXH #h  l ɀɂ     aɀɂ     ɀ L(`O2)  ~}snlihfcb^]32(#!  J KBDCLEAR .EQU 0C010 ;KEYBOARD STROBE CLEAR LOCATION   ;ACIA STATUS REGISTER MASK BITS  RDRF .EQU 01 ;RECEIVE REGISTER FULL  TDRE .EQU 02 ;TRANSMIT REGISTER EMPTY  NOTDCD .EQU 04 ;DA50 MILLISEC.  ;---------------------------------------------------------------------   JMP START   ;APPLE KEYBOARD EQUATES  KBDCHAR .EQU 0C000 ;KEYBOARD INPUT REGISTER EMPTY MODEM QUEUE AFTER BREAK.  ; 80/12/13 PHK SHORTENED BREAK TO 67 MILLISEC.  ; ALL CONTROL INPUT FROM APPLE KEYBOARD.  ; 81/01/11 PHK CLEAN UP ACIA REGISTERS AFTER BREAK.  ; BREAK CHANGED TO 1 ENTERED ON THE APPLE  ; KEYBOARD, NOT THE CONSOLE DEVICE.  ;  ; MODIFICATION LOG.  ; 80/08/31 PHK ORIGINAL VERSION.  ; 80/09/07 PHK IMPROVED BREAK AND NOT-READY DETECTION.  ; 80/10/11 PHK FIXED COUNTING BUG IN "DELAY" ROUTINE;  ;  ; [CONTROL/H] (ASCII BS) BY KEYING CONTROL/B (ASCII STX).  ; THE PRINTER IS INITIALLY OFF. IT MAY BE TURNED ON FROM THE  ; APPLE KEYBOARD BY CONTROL/R (ASCII DC2) AND OFF BY CONTROL/T (ASCII T).  ; NOTE THAT ALL OF THESE CONTROL FUNCTIONS AREA CONTROL/W (ASCII ETB)  ; CHARACTER FROM THE APPLE KEYBOARD. THE CODE TRANSMITTED BY CONSOLE  ; BACKSPACE IS KEYED MAY BE CHANGED TO RUBOUT (ASCII DEL) BY KEYING  ; CONTROL/D (ASCII EOT). IT MAY BE CHANGED BACK TO BACKSPACE AUD PRINTER)  ; SLOT 2 -- APPLE COMM CARD (300 BAUD MODEM)  ; SLOT 3 -- CCS 7710A ASYNC SERIAL INTERFACE (9600 BAUD CONSOLE)  ;  ; THE PROGRAM IS CALLED AS A PARAMETERLESS SUBROUTINE FROM A PASCAL  ; MAINLINE. IT EXITS UPON RECEIVING IS PROGRAM IS DESIGNED TO OPERATE AS A DATA COMMUNICATIONS  ; CONCENTRATOR FOR AN APPLE II UCSD PASCAL SYSTEM. THE PROGRAM  ; MAKES THE FOLLOWING ASSUMPTIONS ABOUT PERIPHERAL DEVICES:  ;  ; SLOT 1 -- CCS 7710A ASYNC SERIAL INTERFACE (1200 B .PROC DCCTL  ;---------------------------------------------------------------------  ; DCCTL -- APPLE PASCAL DATA COMMUNICATIONS CONTROL PROGRAM  ;  ; COPYRIGHT (C) 1980, 1981, PAUL H. KIMPEL.  ; ALL RIGHTS RESERVED.  ;  ; THN^CHAR TO MODEM  $25  TA CARRIER DETECT FALSE  NOTCTS .EQU 08 ;CLEAR TO SEND FALSE  FE .EQU 10 ;FRAME ERROR   ;ACIA CONTROL REGISTER VALUES  AC16X .EQU 01 ;16X CLOCK RATE  ACINIT .EQU 03 ;ACIA MASTER RESET   AC8DNP2S .EQU 10 ;8 DATA, NO PARITY, 2 STOP BITS   ACCADI .EQU 00 ;CTS ACTIVE, DISABLE XMT INTERRUPTS  ACBREAK .EQU 60 ;CTS ACTIVE, XMIT BREAK   ;ASCII CHARACTER DEFINES  STXX .EQU (LDA CONSTAT ;GET ACIA STATUS (TAY ;SAVE STATUS (AND #RDRF ;TEST RCV-REG READY (BNE $10 ;YES (LDA #NOCHAR ;LOAD NULL RESULT (BNE $99 ;EXIT (Z RESET BY LDA)  $1ONSTAT ;SET ACIA: 8 DATA, NO PAR, 2 STOP,  RTS ; CLOCK 16X, NO INTERRUPT   READCON (;ATTEMPTS TO READ A CHARACTER FROM THE CONSOLE ACIA. (;RESULT IS RETURNED IN A-REG. BIT 7 INDICATES A CONTROL RESULT. ;FLUSH BUFFER QUEUE (STA CONTAIL (STA CONFES ;ZERO FRAME ERROR COUNTER (LDA #BS ;SET BACKSPACE=BS (STA CONBS (LDA #ACINIT (STA CONSTAT ;INITIALIZE ACIA (LDA #AC16X+AC8DNP2S+ACCADI (STA CNE $30 ;JUMP OUT (LDX RESET Z)  $24  ;RFE...  $30 (RTS ;EXIT   ;--------------- CONSOLE ROUTINES -------------------   INITCON (;INITIALIZES THE CONSOLE PORT (LDA #0 (STA CONHEAD (LDX #BS (STX CONBS ;SET BACKSPACE=BS (BNE $30 ;JUMP OUT (LDX SET Z)  $23 (CMP #EOT ;CHECK FOR BACKSPACE=DEL (BNE $24 ;NO (LDX #DEL (STX CONBS ;SET BACKSPACE=DEL (B CMP #DC4 ;CHECK FOR PRINTER OFF (BNE $22 ;NO (LDX #0 (STX PRON (BEQ $30 ;JUMP OUT (LDX RESET Z)  $22 (CMP #STXX ;CHECK FOR BACKSPACE=BS (BNE $23 ;NO CONTAIN A VALID (;CONTROL CHAR, ROUTINE SIMPLY EXITS. (CMP #DC2 ;CHECK FOR PRINTER ON (BNE $21 ;NO (LDX #1 ;YES--SET PRINTER FLAG (STX PRON (BNE $30 ;JUMP OUT (LDX SET Z)  $21 #194.  $02 (DEY (BNE $02 ;194*5-1 CYCLES (SBC #1 (BNE $01 ;A*(194*5-1+7) CYCLES (RTS (  CTLCHAR (;CHECKS A-REG FOR A SPECIAL CONTROL CHAR AND SETS OPTIONS AS (;APPROPRIATE FOR THE CHAR. IF A-REG DOES NOT  DCDATA .EQU 0C0AF  DCBC .BYTE ;BREAK TIMER COUNTER  DCHEAD .BYTE  DCTAIL .BYTE  DCQ .BLOCK 256.   ;--------------- UTILITIES --------------   DELAY (;DELAYS 976*A + 7 CLOCK CYCLES (APPROX 1 MS) (SEC  $01 (LDY ;PRINTER ON FLAG  PRFES .BYTE ;COUNT OF SUCCESSIVE FRAME ERRORS  PRHEAD .BYTE  PRTAIL .BYTE  PRQ .BLOCK 256.   DCBRK .EQU 3 ;NR CHAR TIMES FOR BREAK TRANSMIT  DCSTAT .EQU 0C0AE ;COUNT OF SUCCESSIVE FRAME ERRORS  CONHEAD .BYTE  CONTAIL .BYTE  CONQ .BLOCK 256.   PRBRK .EQU 10. ;NR CONSECUTIVE FRAME ERRORS FOR BREAK  PRSTAT .EQU 0C090  PRDATA .EQU 0C091  PRON .BYTE ;BREAK RECEIVED   ;PORT CONTROLS AND BUFFERS  CONBRK .EQU 10. ;NR CONSECUTIVE FRAME ERRORS FOR BREAK  CONSTAT .EQU 0C0B0  CONDATA .EQU 0C0B1  CONBS .BYTE ;CONSOLE BACKSPACE CODE  CONFES .BYTE  ETB .EQU 17 ;CONTROL/W  DEL .EQU 7F ;RUBOUT   ;CONTROL RESULT "CHARACTERS"  NOCHAR .EQU 80 ;NO CHARACTER RECEIVED  LOC .EQU 81 ;LOSS OF CARRIER (DCD)  BREAK .EQU 82 02 ;CONTROL/B  EOT .EQU 04 ;CONTROL/D  BS .EQU 08 ;CONTROL/H (BACKSPACE)  DC2 .EQU 12 ;CONTROL/R  DC4 .EQU 14 ;CONTROL/T 0 (TYA ;GET STATUS AGAIN (AND #FE ;CHECK FOR FRAME ERROR (BEQ $20 ;NO (INC CONFES ;YES--BUMP ERROR COUNTER (LDA CONDATA ;EMPTY RCV.REG (LDA #CONBRK ;CHECK AGAINST BREAK LIMIT (CMP CONFES (BNE $15 ;NO (LDA #BREAK ;YES--LOAD BREAK RESULT  BNE $99 ;EXIT (Z RESET BY LDA)  $15 (LDA NOCHAR ;NOT BREAK YET--LOAD NULL RESULT (BNE $99 (LDA PRSTAT ;GET ACIA STATUS (AND #TDRE ;CK XMT-REG EMPTY (BEQ $99 ;XMIT BUSY--EXIT (LDA PRQ,X ;PLUCK CHAR FROM QUEUE (STA PRDATA ;SEND TO ACIA (INX ;BUMP QHEADEPR (;ATTEMPTS TO DEQUEUE A CHARACTER FROM THE PRINTER BUFFER (;AND TRANSMIT IT. NO ACTION IF BUFFER EMPTY OR ACIA IS BUSY. (LDX PRHEAD ;GET QHEAD POINTER (CPX PRTAIL ;CK FOR EMPTY (BEQ $99 ;YES--EXIT ;EXIT (Z RESET BY LDA)  $20 (;WE HAVE A GOOD CHAR IN THE ACIA (LDA #0 (STA PRFES ;CLEAR FRAME ERROR COUNTER (LDA PRDATA ;GET CHARACTER (AND #7F ;STRIP PARITY BIT  $99  RTS   WRITAINST BREAK LIMIT (CMP PRFES (BNE $15 ;NO (LDA #BREAK ;YES--LOAD BREAK RESULT  BNE $99 ;EXIT (Z RESET BY LDA)  $15 (LDA NOCHAR ;NOT BREAK YET--LOAD NULL RESULT (BNE $99  $10 (TYA ;GET STATUS AGAIN (AND #FE ;CHECK FOR FRAME ERROR (BEQ $20 ;NO (INC PRFES ;YES--BUMP ERROR COUNTER (LDA PRDATA ;EMPTY RCV.REG (LDA #PRBRK ;CHECK AG(LDA PRSTAT ;GET ACIA STATUS (TAY ;SAVE STATUS (AND #RDRF ;TEST RCV-REG FULL (BNE $10 ;YES (LDA #NOCHAR ;LOAD NULL RESULT (BNE $99 ;EXIT (Z RESET BY LDA) PRSTAT ;SET ACIA: 8 DATA, NO PAR, 2 STOP,  RTS ; CLOCK 16X, NO INTERRUPT   READPR (;ATTEMPTS TO READ A CHARACTER FROM THE PRINTER ACIA. (;RESULT IS RETURNED IN A-REG. BIT 7 INDICATES A CONTROL RESULT. RHEAD ;FLUSH BUFFER QUEUE (STA PRTAIL (STA PRON ;PRINTER INITIALLY OFF (STA PRFES ;CLEAR FRAME ERROR COUNTER (LDA #ACINIT (STA PRSTAT ;INITIALIZE ACIA (LDA #AC16X+AC8DNP2S+ACCADI (STA (STX CONTAIL ;NO--RESTORE QTAIL POINTER  $99  JSR WRITECON ;ATTEMPT TO TRANSMIT (RTS   ;------------------ PRINTER ROUTINES -------------------   INITPR (;INITIALIZES THE PRINTER PORT (LDA #0 (STA PA CONQ,X ;ENQUEUE CHAR IN A-REG  INX ;BUMP QTAIL POINTER (255 OFLOWS TO 0)  CPX CONHEAD ;CK FOR QUEUE FULL (BEQ $99 ;YES--DON'T RESTORE QTAIL POINTER STX CONHEAD ;RESTORE QHEAD POINTER  $99  RTS   QCON (;ENQUEUES ONE CHARACTER TO THE CONSOLE BUFFER FROM THE A-REG. (;IF THE BUFFER IS FULL, THE LAST CHARACTER QUEUED IS LOST. (LDX CONTAIL ;GET QTAIL POINTER (STONSTAT ;GET ACIA STATUS (AND #TDRE ;CK XMT-REG EMPTY (BEQ $99 ;XMIT BUSY--EXIT (LDA CONQ,X ;PLUCK CHAR FROM QUEUE (STA CONDATA ;SEND TO ACIA (INX ;BUMP QHEAD POINTER ((;ATTEMPTS TO DEQUEUE A CHARACTER FROM THE CONSOLE BUFFER (;AND TRANSMIT IT. NO ACTION IF BUFFER EMPTY OR ACIA IS BUSY. (LDX CONHEAD ;GET QHEAD POINTER (CPX CONTAIL ;CK FOR EMPTY (BEQ $99 ;YES--EXIT (LDA C ;EXIT (Z RESET BY LDA)  $20 (;WE HAVE A GOOD CHAR IN THE ACIA (LDA #0 (STA CONFES ;CLEAR FRAME ERROR COUNTER (LDA CONDATA ;GET CHARACTER (AND #7F ;STRIP PARITY BIT  $99 (RTS   WRITECON POINTER (STX PRHEAD ;RESTORE QHEAD POINTER  $99  RTS   QPR (;ENQUEUES ONE CHARACTER TO THE PRINTER BUFFER FROM THE A-REG. (;IF THE BUFFER IS FULL, THE LAST CHARACTER QUEUED IS LOST. (LDX PRON ;CHECK PRINTER FLAG (BEQ $99 ;OFF--DON'T ENQUEUE (LDX PRTAIL ;GET QTAIL POINTER (STA PRQ,X ;ENQUEUE CHAR IN A-REG  INX ;BUMP QTAIL POINTER (255 OFLOWS TO 0)  CPX PRHEAD ;CK(RTS   ;-------------------- APPLE KEYBOARD ROUTINES ----------------------   INITKBD (;INITIALIZES THE APPLE KEYBOARD (LDA KBDCLEAR ;CLEAR KEYBOARD STROBE (RTS   READKBD (;ATTEMPTS TO READ ONE CHARACTER FROM THE APPLE KEYBOARD. (LAY ;DELAY ANOTHER 250 MS (LDA #ACINIT (STA DCSTAT ;CLEAR ACIA (LDA #AC16X+AC8DNP2S+ACCADI (STA DCSTAT ;RESTORE ACIA STATUS (LDA #0 (STA DCHEAD ;FLUSH MODEM OUTPUT BUFFER (STA DCTAIL  (LDA #AC16X+AC8DNP2S+ACBREAK (STA DCSTAT ;SET ACIA TO XMIT BREAK MODE (LDA #150. (JSR DELAY ;DELAY 150 MS (LDA #AC16X+AC8DNP2S+ACCADI (STA DCSTAT ;RESTORE ACIA STATUS (LDA #250. (JSR DE JSR WRITEDC ;ATTEMPT TO TRANSMIT (RTS   BREAKDC (;TRANSMITS A 150 MS BREAK ON THE MODEM PORT  $10 LDA DCSTAT ;GET MODEM ACIA STATUS (AND #TDRE ;CK XMT-REG EMPTY (BEQ $10 ;NO--LOOP AGAIN  INX ;BUMP QTAIL POINTER (255 OFLOWS TO 0)  CPX DCHEAD ;CK FOR QUEUE FULL (BEQ $99 ;YES--DON'T RESTORE QTAIL POINTER (STX DCTAIL ;NO--RESTORE QTAIL POINTER  $99  R  $99  RTS   QDC (;ENQUEUES ONE CHARACTER TO THE MODEM BUFFER FROM THE A-REG. (;IF THE BUFFER IS FULL, THE LAST CHARACTER QUEUED IS LOST. (LDX DCTAIL ;GET QTAIL POINTER (STA DCQ,X ;ENQUEUE CHAR IN A-REG RE ;CK XMT-REG EMPTY (BEQ $99 ;XMIT BUSY--EXIT (LDA DCQ,X ;PLUCK CHAR FROM QUEUE (STA DCDATA ;SEND TO ACIA (INX ;BUMP QHEAD POINTER (STX DCHEAD ;RESTORE QHEAD POINTE MODEM BUFFER (;AND TRANSMIT IT. NO ACTION IF BUFFER EMPTY OR ACIA IS BUSY. (LDX DCHEAD ;GET QHEAD POINTER (CPX DCTAIL ;CK FOR EMPTY (BEQ $99 ;YES--EXIT (LDA DCSTAT ;GET ACIA STATUS (AND #TD(BNE $99 ;EXIT (Z RESET BY LDA)  $20 (;WE HAVE A GOOD CHAR IN THE ACIA (LDA DCDATA ;GET CHARACTER (AND #7F ;STRIP PARITY BIT  $99  RTS   WRITEDC (;ATTEMPTS TO DEQUEUE A CHARACTER FROM THE(Z RESET BY LDA)  $10 (TYA ;GET STATUS AGAIN (AND #NOTDCD ;CHECK FOR LOSS OF CARRIER (BEQ $20 ;NO (LDA DCDATA ;YES--EMPTY RCV.REG (LDA #LOC ;LOAD LOC RESULT TES A CONTROL RESULT. (LDA DCSTAT ;GET ACIA STATUS (TAY ;SAVE STATUS (AND #RDRF ;TEST RCV-REG FULL (BNE $10 ;YES (LDA #NOCHAR ;LOAD NULL RESULT (BNE $99 ;EXIT AC8DNP2S+ACCADI (STA DCSTAT ;SET ACIA: 8 DATA, NO PAR, 2 STOP,  RTS ; CLOCK 16X, NO INTERRUPT   READDC (;ATTEMPTS TO READ A CHARACTER FROM THE MODEM ACIA. (;RESULT IS RETURNED IN A-REG. BIT 7 INDICA ;------------------- MODEM ROUTINES --------------------   INITDC (;INITIALIZES THE MODEM PORT (LDA #0 (STA DCHEAD ;FLUSH BUFFER QUEUE (STA DCTAIL (LDA #ACINIT (STA DCSTAT ;INITIALIZE ACIA (LDA #AC16X+ FOR QUEUE FULL (BEQ $90 ;YES--DON'T RESTORE QTAIL POINTER (STX PRTAIL ;NO--RESTORE QTAIL POINTER  $90  JSR WRITEPR ;ATTEMPT TO TRANSMIT  $99  RTS  ;RESULT IS RETURNED IN A-REG. BIT 7 INDICATES A CONTROL RESULT. (LDA KBDCHAR ;LOAD FROM KEYBOARD REGISTER (BMI $10 ;BRANCH IF CHAR PRESENT (LDA #NOCHAR ;ELSE LOAD NULL RESULT (BNE $99 ;EXIT (Z SET BY LDA)  $10 (STA KBDCLEAR ;CLEAR KEYBOARD STROBE (AND #7F ;STRIP STROBE BIT FROM CHAR  $99 (RTS ;EXIT   ;------------------- MAINLINE ---------------------   START (PHP ;SAVEGETHRUSTN^ӡ& ;LOOP AGAIN THROUGH PORTS   EXIT PLP ;RESTORE PROCESSOR STATUS  RTS ;RETURN TO PASCAL CALLER  (.END  (CMP #NOCHAR ;ANYTHING THERE? (BEQ $30 ;NO (CMP #ETB ;CHECK FOR TERMINATION (BEQ EXIT ;YES -- JUMP OUT OF LOOP (JSR CTLCHAR ;ELSE PROCESS CONTROL CHAR  $30 (JMP MODEM YES--TRANSLATE  $14  JSR QDC ;QUEUE CHAR TO MODEM  $25  JSR WRITECON ;CHECK FOR CONSOLE OUTPUT (  KEYBOARD (;APPLE KEYBOARD SERVICE ROUTINE (JSR READKBD ;CHECK FOR KEYBOARD INPUT ;NO (JSR BREAKDC ;YES--OUTPUT BREAK ON MODEM (CLC ;FORCE NEXT BRANCH (BCC $25  $12  ;HAVE A CHARACTER TO ROUTE (CMP #BS ;BACKSPACE? (BNE $14 ;NO (LDA CONBS ;PRINTER OUTPUT   CONSOLE (;CONSOLE SERVICE ROUTINE (JSR READCON ;CHECK FOR CONSOLE INPUT (CMP #NOCHAR ;ANYTHING THERE? (BEQ $25 ;NO--TRY FOR OUTPUT (CMP #BREAK ;A BREAK? (BNE $12  ;HAVE A CHARACTER TO ROUTE (CMP #BS ;BACKSPACE? (BNE $14 ;NO (LDA CONBS ;YES--TRANSLATE  $14 (JSR QDC ;QUEUE CHAR TO MODEM  $15  JSR WRITEPR ;CHECK FOR YTHING THERE? (BEQ $15 ;NO--TRY FOR OUTPUT (CMP #BREAK ;A BREAK? (BNE $12 ;NO (JSR BREAKDC ;YES--OUTPUT BREAK ON MODEM (CLC ;FORCE NEXT BRANCH (BCC $15  $12 NPUT CHAR (JSR QCON ;QUEUE CHAR TO CONSOLE  $05  JSR WRITEDC ;CHECK FOR MODEM OUTPUT   PRINTER  ;PRINTER SERVICE ROUTINE (JSR READPR ;CHECK FOR PRINTER INPUT (CMP #NOCHAR ;AN (BEQ $05 ;NO--TRY TO OUTPUT (CMP #LOC ;LOSS OF CARRIER? (BEQ EXIT ;YES--QUIT (PHA ;SAVE INPUT CHAR (JSR QPR ;QUEUE CHAR TO PRINTER (PLA ;RETRIEVE I(JSR INITPR ;INITIALIZE PRINTER PORT (JSR INITDC ;INITIALIZE MODEM PORT   ;MAIN CONTROL LOOP  MODEM (;MODEM SERVICE ROUTINE (JSR READDC ;CHECK FOR MODEM INPUT (CMP #NOCHAR ;ANYTHING THERE? PROCESSOR STATUS (SEI ;DISABLE INTERRUPTS (CLD ;CLEAR DECIMAL MODE (JSR INITKBD ;INITIALIZE APPLE KEYBOARD (JSR INITCON ;INITIALIZE CONSOLE PORT %deltaburn := burnrate*stepsize; %fuelremaining := mass-p; % %GOTOXY(0,21); % %WRITE('enter "run" to start simulation, "end" to abort ');READLN(ctl); %IF NOT((ctl = 'run') OR (ctl = 'RUN')) 5THEN 9EXIT(PROGRAM) ELSE 9WRITE('DEPRESS BUTTON -0 TO Bocity/(2.0 * vthrust) * (1.0 + Rand(0)); %x := vertvelocity/8 + Rand(vertvelocity/2); %p := mass/2; %burnrate := (2 * y + vertvelocity*vertvelocity/g)/(1.0+ vthrust/g); %burnrate := p/(SQRT(burnrate/vthrust)*f*diffact); lse; %mass := 1024 + 1024*Rand(0); %f := g*mass*(4 + 4*Rand(0)); %vertmaxf := f/255; %horizmaxf := 0.05 * f/255; %hthrust := 0.0; %vthrust:= 1.333333*f/mass - g; %vertvelocity := f/mass * Rand(64); %horizvelocity := 0.0; %y := vertvelocity*vertvel.....!........!'); "WRITELN('! ! ! ',f:8:1,' !'); "WRITELN('!.........!.........!..................!'); " "  END; (*Header*)    %  PROCEDURE Setup;   VAR ctl: STRING[5]; # #BEGIN %endoftime := fa"WRITELN('!...................!..................!'); "WRITELN('! ! !'); "WRITELN('!...................!..................!'); "WRITELN('!...FUEL..!.........!....MAX THRUST....!'); "WRITELN('!.........!.........!......VEL..!'); "WRITELN('!.........!.........!.........!........!'); "WRITELN('! !'); "WRITELN('!.........!.........!.........!........!'); "WRITELN('!......THRUST.......!......THRUST......!'); CHR(12)); (*CLEAR SCREEN & HOME CURSOR*) % % "WRITELN('........................................'); "WRITELN('!...................!..................!'); "WRITELN('!......VERTICAL.....!....HORIZONTAL....!'); "WRITELN('!...ALT...!...VEL...!...POS...!.)  (* hi > 0 => 1<=Rand<=hi*)   VAR temp: REAL;    BEGIN  "temp := RANDOM/32767; "IF hi <= 0 THEN Rand := temp &ELSE (BEGIN *Rand := 1.0 + ROUND(temp * hi); (END;  END; (*Rand*)    PROCEDURE Header;   BEGIN  "WRITE(&vvalprevious:INTEGER; (*PREVIOUS VERTICAL THRUST SETTING*) & &endoftime, &abortrequest: BOOLEAN; & &(*END OF DEF*) ! ! ! !  FUNCTION Rand(hi:REAL):REAL;   (*GENERATE A REAL RANDOM NUMBER IN THE RANGE *)  (* hi = 0 => 0 hvalprevious THEN # &BEGIN & (hvalprevious := hval; ( (GOTOXY(25,9); ( (WRITE(hthrust:8:1,CHR(25)); & &END; & #  END;(*Horizontalthrust*)     PROCEDURE Verticalthrust;   BEGIN "vval := PADDLE(0); (*VEPROGRAM LIB1MENU;  TYPE SETOFCHAR = SET OF CHAR;  VAR SELECTION: CHAR;   FUNCTION GETCHAR(OKSET: SETOFCHAR):CHAR;  VAR CH:CHAR; $GOOD:BOOLEAN;  BEGIN $REPEAT 'READ(KEYBOARD,CH); 'IF EOLN(KEYBOARD) THEN CH:=CHR(13); 'GOOD:= CH IN OKSET; 'IF NOTN^LOCITY = ',vertvelocity:7:2); ' 'WRITELN('DISTANCE FROM BASE = ',x:6:1); $ %END; $ $ #END; #  UNTIL ENDOFTIME;   END. !  := x - horizvelocity*stepsize; , *END; & &t := t + stepsize; & $END; $ !END; ! !(*LANDED ... NOW REPORT !!!*) ! #BEGIN # %IF not abortrequest THEN % %BEGIN % 'GOTOXY(0,16); ' 'WRITELN('******* LANDED *******'); ' 'WRITELN('TERMINAL VE,IF mass <= p THEN Fuelexhausted; - *END; -  (*PREDICT NEW POSITION & VELOCITY*) , *BEGIN . ,vertvelocity := vertvelocity + stepsize*(g-vthrust/mass); ,horizvelocity := horizvelocity + stepsize*hthrust/mass; ,y := y - vertvelocity*stepsize; ,x DO & (BEGIN * *IF mass <> p THEN * *BEGIN . ,Horizontalthrust; (*calculate horizontal thrust for pass *) , ,Verticalthrust; (*calculate vertical thrust for pass *) , ,mass := mass-(vthrust+ABS(hthrust))*deltaburn; , 1); & &t := 0.0; (*SIMULATED TIME*) & &fuelremaining := mass-p; & &GOTOXY(0,5); & &WRITE('!',y:9:1,'!',vertvelocity:9:1,'!',x:9:1,'!',horizvelocity:8:1); & &GOTOXY(3,12); & &WRITE(fuelremaining:6:1,CHR(25)); & & &WHILE t < displayinterval *MAIN PROGRAM*)  "REPEAT " "RANDOMIZE; " "Setup; (*INITIALIZE DECENT*) " "(************************ BEGIN DESENT CALCULATIONS ************************) " "WHILE (y > 4.0) AND (NOT abortrequest) DO " $BEGIN $ &abortrequest := BUTTON( BEGIN (* Fuel Exhausted ! *)  "GOTOXY(0,15); "WRITELN('FUEL EXHAUSTED'); "mass := p; "vthrust := 0; "hthrust := 0; "  END; (* Fuel Exhausted ! *) ,   (****************************************************************************)   BEGIN (RTICAL THRUST SETTING*)  "vthrust := vval * vertmaxf; " "IF vval <> vvalprevious THEN " &BEGIN ( (vvalprevious := vval; ( (GOTOXY(5,9); ( (WRITE(vthrust:8:1,CHR(25)); ( &END; &  END;(*verticalthrust*)    PROCEDURE Fuelexhausted;  GOOD THEN WRITE(CHR(7),CHR(7)) *ELSE IF CH IN [' '..'Z'] THEN WRITE(CH); 'UNTIL GOOD; 'GETCHAR := CH;  END(*GETCHAR*);  PROCEDURE PAGEA;  VAR CH: CHAR;   BEGIN #PAGE(OUTPUT); #WRITELN(' PROGRAM ''LANDER'' '); #WRITELN('****************************************'); #GOTOXY(0,9); #WRITELN(' PROGRAM LANDER, WRITTEN BY '); #WRITELN(' MR. ROSENTHAL, IS AN EXCELLENT EXAMPLE '); #WRITELN(' OF PAGE FORMATTING AND GAME APPLICATION'); #WRITELN(' IN PASCAL. THERE ARE NO GRAPHICS IN #WRITELN(' PROCEDURES ARE ''WAIT'' AND ''PAUSE''. '); #WRITELN; #WRITELN('PROGRAM IS SELF DOCUMENTING. CONTRIBUTED'); #WRITELN('BY G. TEAS.'); #GOTOXY(0,22); #WRITELN('****************************************'); #WRITE(' PRESS ANY KEY TO C(ONTINU*************************'); #GOTOXY(0,8); #WRITELN(' PRESENTS POSSIBLE WAYS OF ERASING '); #WRITELN(' PAGES, LINES, PARTS OF THE SCREEN, ETC.'); #WRITELN(' ALSO INCLUDES HOME. OTHER INTERESTING '); *******************************'); #WRITE(' PRESS ANY KEY TO C(ONTINUE'); #READ(CH); #PAGE(OUTPUT);  END(*PAGEOUT*);    PROCEDURE PAGEG;  VAR CH:CHAR;  BEGIN #PAGE(OUTPUT); #WRITELN(' PROGRAM ERASEDEMO'); #WRITELN('***************LOAD THE TEXT '); #WRITELN(' FILE TO SYSTEM.WRK.TEXT WITH A GET FROM'); #WRITELN(' LIB1:FLASHDEMO. NEXT COMPILE THE TEXT '); #WRITELN(' AND USE THE LINKER TO LIB1:TEMPLIB1. '); #GOTOXY(0,22); #WRITELN('*********#WRITELN(' AND ''NORMAL''. BE SURE TO LIST THE '); #WRITELN(' TEXT FILE TO SEE HOW THESE PROCEDURES '); #WRITELN(' WERE DEFINED AS EXTERNAL AND LATER '); #WRITELN(' LINKED TO ''TEMPLIB1''. A GOOD EXPER- '); #WRITELN(' IMENT FOR NOVICES IS TO WRITELN(' PROGRAM FLASHDEMO'); #WRITELN('****************************************'); #GOTOXY(0,7); #WRITELN(' THIS PROGRAM CONTRIBUTED BY G. TEAS,'); #WRITELN(' DEMONSTRATES ''FLASH'',''INVERSE'', '); NVERSE BY CALL A.P.P.L.E. '); #GOTOXY(0,22); #WRITELN('****************************************'); #WRITE(' PRESS ANY KEY TO C(ONTINUE'); #READ(CH); #PAGE(OUTPUT);  END(*PAGEOUT*);    PROCEDURE PAGEF;  VAR CH:CHAR;  BEGIN #PAGE(OUTPUT); #THEN AND USING THE '); #WRITELN(' ''TEMPLIB1'' AS THE ANSWER TO THE '); #WRITELN(' QUESTION ''WHAT LIBRARY''.'); #WRITELN; #WRITELN(' PEEK,POKE AND ALTER WERE CONTRIBUTED BY'); #WRITELN(' MR. ROSENTHAL. FLASH, NORMAL AND '); #WRITELN(' I#WRITELN(' THIS TEMPORY LIBRARY CONTAINS: ''PEEK'','); #WRITELN(' ''POKE'',''ALTER'',''FLASH'',''INVERSE'','); #WRITELN(' AND ''NORMAL''. THESE ASSEMBLED '); #WRITELN(' PROCEDURES ARE USED BY LINKING THE '); #WRITELN(' PROGRAM REQUIRING #PAGE(OUTPUT);  END(*PAGEOUT*);    PROCEDURE PAGEE;  VAR CH:CHAR;  BEGIN #PAGE(OUTPUT); #WRITELN(' LIBRARY ''TEMPLIB1'''); #WRITELN('****************************************'); #GOTOXY(0,6); TRASTING TEXT LINE. '); #WRITELN; #WRITELN(' PROGRAM WRITTEN BY JIM EGERTON AND '); #WRITELN(' EDITED BY GEORGE TEAS.'); #GOTOXY(0,22); #WRITELN('****************************************'); #WRITE(' PRESS ANY KEY TO C(ONTINUE'); #READ(CH); '); #WRITELN(' DIFFERENT MODES SHOWN ON PAGE 180A OF '); #WRITELN(' THE ''APPLE PASCAL REFERENCE MANUAL'' '); #WRITELN(' WILL APPEAR WHEN USED. USER SELECTS '); #WRITELN(' THE COLORS AND MODES WHICH ARE THEN '); #WRITELN(' SHOWN WITH A CON VAR CH:CHAR;  BEGIN #PAGE(OUTPUT); #WRITELN(' PROGRAM ''MODEDEMO'''); #WRITELN('****************************************'); #GOTOXY(0,7); #WRITELN(' THIS PROGRAM, USING THE HIRES COLORS'); #WRITELN(' AVAILABLE, WILL DEMONSTRATE HOW THE'); #WRITELN(' THIS PROGRAM. '); #GOTOXY(0,22); #WRITELN('****************************************'); #WRITE(' PRESS ANY KEY TO C(ONTINUE'); #READ(CH); #PAGE(OUTPUT);  END(*PAGEOUT*);    PROCEDURE PAGED; E'); #READ(CH); #PAGE(OUTPUT);  END(*PAGEOUT*);    PROCEDURE PAGEH;  VAR CH:CHAR;  BEGIN #PAGE(OUTPUT); #WRITELN(' PROGRAM DATEDEMO '); #WRITELN('****************************************'); #GOTOXY(0,9); #WRITELN(' PROGRAM ONLY PRINTS SYSTEM DATE. IS'); #WRITELN(' OF INTEREST ONLY TO THOSE WONDERING HOW'); #WRITELN(' IT WAS FOUND. CONTRIBUTED BY ROSENTHAL'); #GOTOXY(0,22); #WRITELN('****************************************'); #WRITE(' PRESS ANY KEY TO C(ONTINUE'); #READ( צ(****************************************צ PRESS ANY KEY TO C(ONTINUE *  PROGRAM 'MODEDEMO'(*********************************, WRITTEN BY ( MR. ROSENTHAL, IS AN EXCELLENT EXAMPLE ( OF PAGE FORMATTING AND GAME APPLICATION( IN PASCAL. THERE ARE NO GRAPHICS IN ( THIS PROGRAM.    f$ n  PROGRAM 'LANDER' צ(**************************************** ( PROGRAM LANDERBLIB1MENU PROGRAM);  END;   BEGIN (*MAIN*)  REPEAT "MENU1; "CASE SELECTION OF $'A': PAGEA; $'D': PAGED; $'E': PAGEE; $'F': PAGEF; $'G': PAGEG; $'H': PAGEH; $'L': PAGEL; $'Q': THATSALL; !END(*CASE*);  UNTIL FALSE;  END(*MAIN*). *************************'); #WRITE(' PRESS CHOICE TO CONTINUE'); #SELECTION := GETCHAR(['A','D','E','F','G','H', 9'L','Q']);  END(*PAGEOUT*);   PROCEDURE THATSALL;  BEGIN "PAGE(OUTPUT); "GOTOXY(5,12); "WRITE('....THAT''S ALL FOLKS'); "EXIT(#WRITELN(' F: FLASHDEMO '); #WRITELN(' G: ERASEDEMO'); #WRITELN(' H: DATEDEMO');  END(*PART1*);   BEGIN(*PAGEOUT*) #PART1; #WRITELN(' L: PROCLIB1 '); #WRITELN; #WRITELN(' Q: QUIT '); #WRITELN; #WRITELN('***************ITELN('****************************************'); #WRITELN; #WRITELN(' SELECT ONE OF THE FOLLOWING '); #WRITELN; #WRITELN(' A: LANDER '); #WRITELN(' D: MODEDEMO '); #WRITELN(' E: TEMPLIB1 '); ************************'); #WRITE(' PRESS ANY KEY TO C(ONTINUE'); #READ(CH); #PAGE(OUTPUT);  END(*PAGEOUT*);    PROCEDURE MENU1;  VAR CH:CHAR;  PROCEDURE PART1;  BEGIN #PAGE(OUTPUT); #WRITELN(' MENU OF PROGRAMS ON LIB1: DISKETTE'); #WRRAM WERE '); #WRITELN(' CREATED FOR A TEXT PAGE SHELL FOUND '); #WRITELN(' THERE WITH A C(OPY F(ILE'); #WRITELN(' ''LIB1:PROCLIB1[PAGE1,PAGE2]'' '); #WRITELN; #WRITELN(' CONTRIBUTED BY G TEAS '); #GOTOXY(0,22); #WRITELN('****************#WRITELN(' THIS TEXT FILE CONTAINS SEVERAL '); #WRITELN(' HANDY PROCEDURES WHICH CAN BE EASILY '); #WRITELN(' COPIED INTO ANY TEXT FILE USING THE '); #WRITELN(' BUFFER COPY PROCEDURE. THE OUTPUT '); #WRITELN(' PROCEDURES FOR THIS PROGCH); #PAGE(OUTPUT);  END(*PAGEOUT*);    PROCEDURE PAGEL;  VAR CH:CHAR;  BEGIN #PAGE(OUTPUT); #WRITELN(' TEXT FILE ''PROCLIB1'''); #WRITELN('****************************************'); #GOTOXY(0,7);