PACKET apple laser writer printer (**************************************************************************) (* Stand : 24.02.88 *) (* APPLE LaswerWriter (PostScript) Verison : 4 *) (* Autor : Rudolf Ruland *) (**************************************************************************) DEFINES open, close, execute, paper size, paper x size, paper y size, load positioning procs, load underline procs, load italics procs, load encoding, read ps input, box commands, insert box command, delete box command, print error, : LET (* underline = 1, bold = 2, italics = 4, reverse = 8, *) underline linetype = 1, c document = 1, c page = 2, c write text = 1, c write cmd = 2, c carriage return = 3, c move = 4, c draw = 5, c on = 6, c off = 7, c type = 8, ps input name = "PostScript.input", ps error = 999, tag type = 1; INT VAR paper length, font no, underline no, symbol type; REAL VAR x size, y size; BOOL VAR is landscape; TEXT VAR record, char, command, symbol; FILE VAR ps input; THESAURUS VAR box cmds := empty thesaurus; (*********************************************************************) paper size (21.0, 29.7); PROC paper size (REAL CONST x, y) : x size := x; y size := y; END PROC paper size; PROC paper size : line; putline ("Papierbreite = " + text (x size, 5, 2) + " cm = " + text (x size / 2.54, 5, 2) + " Zoll"); putline ("Papierlaenge = " + text (y size, 5, 2) + " cm = " + text (y size / 2.54, 5, 2) + " Zoll"); END PROC paper size; REAL PROC paper x size : x size END PROC paper x size; REAL PROC paper y size : y size END PROC paper y size; THESAURUS PROC box commands : box cmds END PROC box commands; PROC insert box command (TEXT CONST new command) : command := new command; change all (command, " ", ""); insert (box cmds, command) END PROC insert box command; PROC delete box command (TEXT CONST old command) : INT VAR dummy; command := old command; change all (command, " ", ""); delete (box cmds, command, dummy) END PROC delete box command; (*********************************************************************) PROC open (INT CONST op code, INT VAR param1, param2) : SELECT op code OF CASE c document : open document CASE c page : open page END SELECT; . x steps : param1 . y steps : param2 . open document : IF pos (material, "landscape") > 0 OR pos (material, "quer") > 0 THEN is landscape := TRUE; x steps := x step conversion ( y size ); y steps := y step conversion ( x size ); ELSE is landscape := FALSE; x steps := x step conversion ( x size ); y steps := y step conversion ( y size ); FI; forget (ps input name, quiet); ps input := sequential file (output, ps input name); paper length := y steps; font no := 0; underline no := 0; disable stop; out (""4""); read ps input (ps input, 18000, ""4""); clear error; enable stop; out ("initgraphics erasepage statusdict /waittimeout 3000 put "); load positioning procs; load underline procs; load italics procs; load encoding; read ps input (ps input, 0, ""); . x start : param1 . y start : param2 . open page : x start := 0; y start := 0; IF pos (material, "tray") > 0 THEN out ("statusdict /manualfeed false put "); ELIF pos (material, "manual") > 0 THEN out ("statusdict /manualfeed true put statusdict /manualfeedtimeout 3600 put "); FI; IF material contains a number THEN out ("/#copies "); out (number); out ("def "); FI; IF is landscape THEN out (paper length); out ("ys 0 translate 90 rotate "); FI; read ps input (ps input, 0, ""); . material contains a number : INT VAR number := pos (material, "0", "9", 1); IF number = 0 THEN FALSE ELSE number := max (1, int (subtext (material, number, number + 1))); TRUE FI END PROC open; PROC close (INT CONST op code, INT CONST param1) : SELECT op code OF CASE c document : close document CASE c page : close page OTHERWISE : put (param1) END SELECT; . close document : disable stop; out (""4""); read ps input (ps input, 18000, ""4""); (*. remaining y steps : param1*) . close page : outline ("showpage"); read ps input (ps input, 0, ""); END PROC close; PROC execute (INT CONST op code, TEXT CONST string, INT CONST param1, param2) : SELECT op code OF CASE c write text : write text CASE c write cmd : write cmd CASE c carriage return : carriage return CASE c move : move CASE c draw : draw CASE c on : on CASE c off : off CASE c type : type END SELECT . from : param1 . to : param2 . write text : out ("("); out subtext (string, from, to); out (") show "); . write cmd : command := subtext (string, from, to); IF is box cmd THEN disable stop; do (command); clear error; ELSE out (command); out (" "); FI; . is box cmd : scan (command); next symbol (symbol, symbol type); (symbol type = tag type) CAND (box cmds CONTAINS symbol) (*. x steps to left margin : param1*) . carriage return : move to (0, y pos); line; read ps input (ps input, 0, ""); . x steps : param1 . y steps : param2 . move : move to (x pos, y pos); . draw : IF y steps <> 0 COR x steps < 0 COR linetype <> underline linetype THEN stop ELSE IF underline no <> font no THEN out ("lu ") FI; out (x steps); out ("ul "); FI; . modification : param1 . on : IF on string (modification) <> "" THEN out (on string (modification)); out (" "); ELSE stop FI . off : IF off string (modification) <> "" THEN out (off string (modification)); out (" "); ELSE stop FI . font nr : param1 . type : font no := font nr; out (fontstring (font nr)); out (" /af exch def af setfont "); END PROC execute; PROC move to (INT CONST x, y) : out (x); out ("xs "); out (paper length - y); out ("ys moveto "); END PROC move to; PROC line : out (""13""10"") END PROC line; PROC outline (TEXT CONST string) : out (string); out (""13""10"") END PROC outline; PROC out (INT CONST value) : out (text (value)); out (" ") END PROC out; PROC out (REAL CONST value) : out (text (value)); out (" ") END PROC out; PROC load positioning procs : out ("/xs {"); out (72.0 / 2.54 * x step conversion (1)); out ("mul} def "); out ("/ys {"); out (72.0 / 2.54 * y step conversion (1)); out ("mul} def "); END PROC load positioning procs; PROC load underline procs : out ("/ul {xs ut setlinewidth 0 up rmoveto dup gsave 0 rlineto stroke grestore up neg rmoveto} def "); out ("/lu {af /FontMatrix get 3 get af /FontInfo get 2 copy /up 3 1 roll /UnderlinePosition get mul 3 mul def /ut 3 1 roll /UnderlineThickness get mul def} def "); END PROC load underline procs; PROC load italics procs : out ("/iton {/m matrix def m 2 12 sin 12 cos div put af m makefont setfont} def "); out ("/itoff {af setfont} def "); END PROC load italics procs; PROC load encoding : out ("/reencsmalldict 12 dict def "); out ("/ReEncodeSmall {reencsmalldict begin "); out ("/newcodesandnames exch def /newfontname exch def /basefontname exch def "); out ("/basefontdict basefontname findfont def /newfont basefontdict maxlength dict def "); out ("basefontdict {exch dup /FID ne {dup /Encoding eq {exch dup length array copy newfont 3 1 roll put} {exch newfont 3 1 roll put} ifelse} {pop pop} ifelse} forall "); out ("newfont /FontName newfontname put newcodesandnames aload pop newcodesandnames length 2 idiv {newfont /Encoding get 3 1 roll put} repeat "); out ("newfontname newfont definefont pop "); out ("end} def "); out ("/eumelencoding[10#128 /Ccedilla 10#129 /udieresis 10#128 /Ccedilla 10#129 /udieresis "); out ("10#130 /eacute 10#131 /acircumflex 10#132 /adieresis 10#133 /agrave 10#134 /aring 10#135 /ccedilla 10#136 /ecircumflex 10#137 /edieresis 10#138 /egrave 10#139 /idieresis "); out ("10#140 /icircumflex 10#141 /igrave 10#142 /Adieresis 10#143 /Aring 10#144 /Eacute 10#145 /ae 10#146 /AE 10#147 /ocircumflex 10#148 /odieresis 10#149 /ograve "); out ("10#150 /ucircumflex 10#151 /ugrave 10#152 /ydieresis 10#153 /Odieresis 10#154 /Udieresis 10#155 /cent 10#156 /sterling 10#157 /yen 10#158 /currency 10#159 /florin "); out ("10#160 /aacute 10#161 /iacute 10#162 /oacute 10#163 /uacute 10#164 /ntilde 10#165 /Ntilde 10#166 /ordfeminine 10#167 /ordmasculine 10#168 /questiondown 10#169 /quotedblleft "); out ("10#170 /quotedblright 10#171 /guilsinglleft 10#172 /guilsinglright 10#173 /exclamdown 10#174 /guillemotleft 10#175 /guillemotright 10#176 /atilde 10#177 /otilde 10#178 /Oslash 10#179 /oslash "); out ("10#180 /oe 10#181 /OE 10#182 /Agrave 10#183 /Atilde 10#184 /Otilde 10#185 /section 10#186 /daggerdbl 10#187 /dagger 10#188 /paragraph 10#189 /space "); out ("10#190 /space 10#191 /space 10#192 /quotedblbase 10#193 /ellipsis 10#194 /perthousand 10#195 /bullet 10#196 /endash 10#197 /emdash 10#198 /space 10#199 /Aacute "); out ("10#200 /Acircumflex 10#201 /Egrave 10#202 /Ecircumflex 10#203 /Edieresis 10#204 /Igrave 10#205 /Iacute 10#206 /Icircumflex 10#207 /Idieresis 10#208 /Ograve 10#209 /Oacute "); out ("10#210 /Ocircumflex 10#211 /Scaron 10#212 /scaron 10#213 /Ugrave 10#214 /Adieresis 10#215 /Odieresis 10#216 /Udieresis 10#217 /adieresis 10#218 /odieresis 10#219 /udieresis "); out ("10#220 /k 10#221 /hyphen 10#222 /numbersign 10#223 /space 10#224 /grave 10#225 /acute 10#226 /circumflex 10#227 /tilde 10#228 /dieresis 10#229 /ring "); out ("10#230 /cedilla 10#231 /caron 10#232 /Lslash 10#233 /Oslash 10#234 /OE 10#235 /ordmasculine 10#236 /Uacute 10#237 /Ucircumflex 10#238 /Ydieresis 10#239 /germandbls "); out ("10#240 /Zcaron 10#241 /zcaron 10#242 /fraction 10#243 /ae "); out ("10#251 /germandbls 10#252 /section] def "); out ("/Helvetica /EHelvetica eumelencoding ReEncodeSmall "); out ("/Helvetica-Bold /EHelvetica-Bold eumelencoding ReEncodeSmall "); out ("/Helvetica-Oblique /EHelvetica-Oblique eumelencoding ReEncodeSmall "); out ("/Helvetica-BoldOblique /EHelvetica-BoldOblique eumelencoding ReEncodeSmall "); out ("/Times-Roman /ETimes-Roman eumelencoding ReEncodeSmall "); out ("/Times-Bold /ETimes-Bold eumelencoding ReEncodeSmall "); out ("/Times-Italic /ETimes-Italic eumelencoding ReEncodeSmall "); out ("/Times-BoldItalic /ETimes-BoldItalic eumelencoding ReEncodeSmall "); out ("/Courier /ECourier eumelencoding ReEncodeSmall "); out ("/Courier-Oblique /ECourier-Oblique eumelencoding ReEncodeSmall "); out ("/Courier-BoldOblique /ECourier-BoldOblique eumelencoding ReEncodeSmall "); out ("/Courier-Bold /ECourier-Bold eumelencoding ReEncodeSmall "); line; END PROC load encoding; PROC read ps input (FILE VAR input file, INT CONST timeout, TEXT CONST ok) : BOOL VAR was cr; record := ""; was cr := FALSE; char := incharety (timeout); REP IF char = ""10"" CAND was cr THEN put record; was cr := FALSE; ELIF char = ""13"" CAND NOT was cr THEN was cr := TRUE; ELSE IF was cr THEN record CAT """13"""; was cr := FALSE; FI; IF char = ""4"" THEN IF record <> "" THEN put record FI; putline (input file, "-- EOF --"); line (input file); ELIF char >= " " THEN record CAT char ELIF char >= ""0"" THEN record CAT """"; record CAT text (code (char)); record CAT """"; ELSE IF record <> "" THEN put record FI; LEAVE read ps input; FI; FI; IF pos (ok, char) > 0 THEN IF record <> "" THEN put record FI; LEAVE read ps input; FI; cat input (record, char); IF char = "" THEN char := incharety (min (5, time out)) FI; PER; . put record : putline (input file, record); IF NOT is error CAND pos (record, "%%[ Error:") > 0 THEN errorstop (ps error, record) FI; record := ""; END PROC read ps input; PROC print error (TEXT CONST error message, INT CONST error line) : REAL CONST pl := y size * 72.0 / 2.54, ys := 56.69291, xs := 51.02362, h := 12.0; REAL VAR x := xs, y := ys + h; outline ("/Courier findfont 10 scalefont setfont"); move to x and y; out ("(FEHLER : "); out (error message); IF error line > 0 THEN out (" in Zeile "); out (error line); FI; outline (") show"); IF exists (ps input name) THEN ps input := sequential file (input, ps input name); y INCR 3.0 * h; move to x and y; outline ("(PostScript - Input :) show"); y INCR h; WHILE NOT eof (ps input) REP getline (ps input, record); y INCR h; move to x and y; out ("("); out (record); outline (") show"); PER; output (ps input); FI; outline ("showpage"); out (""4""); read ps input (ps input, 18000, ""4""); . move to x and y : out (x); out (pl - y); out ("moveto "); END PROC print error; END PACKET apple laser writer printer; PACKET apple laserwriter box commands (**************************************************************************) (* *) (* Kommandos zum Zeichen von Boxen, Linien und Schraffuren *) (* für den Apple LaserWriter *) (* *) (* Autor : Rudolf Ruland *) (* Stand : 24.02.88 *) (**************************************************************************) DEFINES line, x line, y line, box, box frame, box shade, cake, cake frame, cake shade, : INT VAR x, y, h, w; WHILE highest entry (box commands) > 0 REP delete box command (name (box commands, highest entry (box commands))) PER; insert box command ("line"); insert box command ("xline"); insert box command ("yline"); insert box command ("box"); insert box command ("boxshade"); insert box command ("boxframe"); insert box command ("cake"); insert box command ("cakeshade"); insert box command ("cakeframe"); PROC line (REAL CONST x offset, y offset, width, height, line width) : IF line width > 0.0 THEN graph on (x offset, y offset, width, height); out (text (line width / 300.0 * 72.0)); out (" setlinewidth "); out (text (w)); out (" xs "); out (text (-h)); out (" ys rlineto stroke "); graph off; FI; END PROC line; PROC x line (REAL CONST x offset, y offset, width, line width) : line (x offset, y offset, width, 0.0, line width); END PROC x line; PROC y line (REAL CONST x offset, y offset, height, line width) : line (x offset, y offset, 0.0, height, line width); END PROC y line; PROC box (REAL CONST x offset, y offset, width, height, line width, pattern): box shade (x offset, y offset, width, height, pattern); box frame (x offset, y offset, width, height, line width); END PROC box; PROC box shade (REAL CONST x offset, y offset, width, height, pattern) : graph on (x offset, y offset, width, height); box path; out (text (pattern)); out (" setgray fill "); graph off; END PROC box shade; PROC box frame (REAL CONST x offset, y offset, width, height, line width) : IF line width <> 0.0 THEN graph on (x offset, y offset, width, height); box path; out (text (line width / 300.0 * 72.0)); out (" setlinewidth stroke "); graph off; FI; END PROC box frame; PROC box path : out (text (w)); out (" xs 0 rlineto 0 "); out (text (-h)); out (" ys rlineto "); out (text (-w)); out (" xs 0 rlineto closepath "); END PROC box path; PROC cake (REAL CONST x offset, y offset, radius, start angle, sweep angle, line width, pattern) : cake shade (x offset, y offset, radius, start angle, sweep angle, pattern); cake frame (x offset, y offset, radius, start angle, sweep angle, line width); END PROC cake; PROC cake shade (REAL CONST x offset, y offset, radius, start angle, sweep angle, pattern) : graph on (x offset, y offset, radius, 0.0); cake path (start angle, sweep angle); out (text (pattern)); out (" setgray fill "); graph off; END PROC cake shade; PROC cake frame (REAL CONST x offset, y offset, radius, start angle, sweep angle, line width) : IF line width <> 0.0 THEN graph on (x offset, y offset, radius, 0.0); cake path (start angle, sweep angle); out (text (line width / 300.0 * 72.0)); out (" setlinewidth stroke "); graph off; FI; END PROC cake frame; PROC cake path (REAL CONST start angle, sweep angle) : out (text (start angle)); out (" rotate "); out ("currentpoint "); out (text (w)); out (" xs 0 "); out (text (sweep angle)); out (" "); IF sweep angle < 360.0 THEN out ("2 setlinejoin arc closepath "); ELSE out (text (w)); out (" xs 0 rmoveto arc "); FI; END PROC cake path; PROC graph on (REAL CONST x offset, y offset, width, height) : x := x step conversion (x offset); y := y step conversion (y offset); w := x step conversion (width); h := y step conversion (height); out ("gsave "); out (text (x)); out (" xs "); out (text (-y)); out (" ys rmoveto "); END PROC graph on; PROC graph off : out ("grestore "); END PROC graph off; END PACKET apple laserwriter box commands; #page# (******************************************************************) (*** ***) (*** Generierung des Printers ***) (*** ***) (******************************************************************) (* LET up = ""3""13""5""; *) LET printer name = "printer.apple.laserwriter"; TEXT VAR fonttab name := "fonttab.apple.laserwriter"; BOOL CONST multi user := (pcb (9) AND 255) <> 1; INT VAR pr channel; TEXT VAR buffer; command dialogue (TRUE); IF NOT multi user THEN errorstop ("Dieser Treiber arbeitet nur mit Multi-Tasking-EUMEL") FI; ask for print channel; load font table; forget (printer name, quiet); IF multi user THEN generate printer spool FI; command dialogue (TRUE); check on; . ask for print channel : line; put ("gib Druckerkanal:"); get (pr channel); do ("serverchannel(" + text (pr channel) + ")" ) ; line; . load font table : IF NOT exists (fonttab name) THEN REP line (2); putline ("Bitte Archiv mit der Fonttabelle """ + fonttab name + """ einlegen!"); line; UNTIL yes ("Archiv eingelegt") PER; reserve archive; fetch (fonttab name, archive); release (archive); FI; font table (fonttab name); IF multi user THEN command dialogue (FALSE); do ("save(""" + font tab name + """,task(""configurator""))") FI; forget (fonttab name, quiet); . reserve archive : INT VAR p1, p2; archive (" "31" "); disable stop; list (archive); IF is error THEN buffer := errormessage; p1 := pos (buffer, """", 1 ) + 1; p2 := pos (buffer, """", p1) - 1; IF p1 > 0 AND p2 > 0 THEN clear error; buffer := subtext (buffer, p1, p2); archive (buffer); FI; FI; enable stop; . generate printer spool : eumel must advertise; cursor (1, 12); putline ("In allen bestehenden Tasks - insbesondere in der Task ""PUBLIC"" - muß"); putline ("die Fonttabelle mit dem Kommando"); line; putline (" font table (""" + font tab name + """)"); line; putline ("eingestellt werden!!!"); line (4); putline ("Generierung beendet, weiter mit 'SV'"); generate printer server; do (buffer); . generate printer server : buffer := "break (quiet);"; buffer CAT "spool manager (PROC printer);"; buffer CAT "INT VAR reply; DATASPACE VAR ds; FILE VAR file;"; buffer CAT "PROC printer:"; buffer CAT " disable stop;"; buffer CAT " continue (server channel);"; buffer CAT " check error (error message);"; buffer CAT " ds := nilspace;"; buffer CAT " REP forget (ds);"; buffer CAT " execute print;"; buffer CAT " IF is error AND online THEN clear error; print error (error message, 0); clear error FI;"; buffer CAT " PER;"; buffer CAT "END PROC printer;"; buffer CAT "PROC execute print:"; buffer CAT " LET ack = 0, fetch code = 11, file type = 1003;"; buffer CAT " enable stop;"; buffer CAT " ds := nilspace;"; buffer CAT " call (father, fetch code, ds, reply);"; buffer CAT " IF reply = ack CAND type (ds) = file type"; buffer CAT " THEN file := sequential file (input, ds);"; buffer CAT " print (file,"; buffer CAT " PROC (INT CONST, INT VAR, INT VAR) open,"; buffer CAT " PROC (INT CONST, INT CONST) close,"; buffer CAT " PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);"; buffer CAT " FI;"; buffer CAT "END PROC execute print;"; buffer CAT "PROC check error(TEXT CONST message):"; buffer CAT " IF is error"; buffer CAT " THEN clear error; rename myself (message);"; buffer CAT " IF is error THEN end(myself) FI;"; buffer CAT " pause (9000); end(myself);"; buffer CAT " FI;"; buffer CAT "END PROC check error;";