!PROGRAMS LEVEL1,CANON
%begin

 %include "TeX:util"
!%include "inc:util.imp"
 %include "inc:region.imp"

{*****************************************************************************}

   %constinteger VUPI=300, HUPI=300;  !vertical/horizontal units per inch
   %constinteger PRINTHEIGHT=3500, PRINTWIDTH=2400
!$IF LEVEL1
!%include "TeX:mouse"
!%include "TeX:frame.imp"
!$IF CANON
!%include "TeX:laser"
!ALL

%option  "-low"

   %constant %string (6) default dvi directory name = "T_tek:"
   %constant %string(255) database = "TeX:fontdb"

!$IF CANON
!  %const %string(60) banner = "This is RGS/DMB DVI Canon driver, Vers. 1.85"
!$IF LEVEL1
!  %const %string(60) banner = "This is RGS/DMB APM/DVIpreview, version 1.85"
!ALL

   %own %integer max fonts,
                 store space,
                 copies,
                 control flags,
                 left margin,
                 top margin,
                 new mag

   %constant %integer name length = 12,
                      terminal channel=0,
                      dvi channel = 1,
                      tfm channel = 2,
                      no parm = -123456789,
                      infinity = (-1)>>1,
                      invalid width = infinity,
                      safety margin = 10000,
                      static  = 1,
                      dynamic = 2,
                      true = 1,
                      false= 0,
                      dbchannel = 3

   %constant %byte id byte = 2

   %constant %integer debug flag = 1<<31,
                      error flag = 1<<30,
                      phase flag = 1<<29,
                      fonts flag = 1<<28,
                      pages flag = 1<<27,
                      info  flag = 1<<26,
                      pause flag = 1<<25,
                      quiet flag = 1<<24,
                      backd flag = 1<<23,
                      vcent flag = 1<<22,
                      hcent flag = 1<<21,
                      dynld flag = 1<<20,
                      nodb  flag = 1<<19

   %constant %integer  text flag mask = error flag ! %c
                                        phase flag ! %c
                                        fonts flag ! %c
                                        pages flag ! %c
                                        info  flag
                                        
   %own %string (255) dvi file name, print sets

   %integer cur loc=0,
            max widths,
            nf=0, showing=0,
            loading,
            numerator, denominator, mag,
            doc width, doc height,
            doc left margin, doc top margin,
            total pages,
            stack size,
            back pointer, post pointer

   %real conv, true conv, resolution

{*****************************************************************************}

%predicate control flag(%integer n)
   %if n & text flag mask # 0 %start
      %false %if control flags & quiet flag = quiet flag
      %true  %if control flags & debug flag = debug flag
   %finish
   %false %if control flags & n=0
   %true
%end

%routine abort(%string(255) why)
   %if control flag(error flag) %start
      print string (why); newline
   %finish
   %signal %event 15
%end

%routine capacity(%string (127) overflow)
   abort("---DVItype capacity exceeded (".overflow.")!")
%end

%routine bad dvi(%string (127) error)
   abort("Bad DVI file: ".error."!")
%end

{*****************************************************************************}

%predicate open input channel(%string(127) file name, %integer channel)
   %on %event 3,9 %start
      %false
   %finish
   %false %unless exists(file name)
   open input (channel, file name)
   %true
%end

{*****************************************************************************}

%routine dialog
   dvi file name = "TEXPUT.DVI"
   define param("INPUT --- dvi file", dvi file name, 0)
   print sets = ""
   define param("DO --- print which pages", print sets, 0)
   copies = 1
   define int param("COPIES", copies, 0)
   store space=10000
   define int param("SYMBOLS", store space, 0)
   new mag   =    0
   define int param("MAGnification", new mag, 0)
   left margin =  0
   define int param("LEFT margin", left margin, 0)
   top margin  =  0
   define int param("TOP margin", top margin, 0)
!$IF LEVEL1
!  control flags     =  phase flag + error flag + info flag
!$IF CANON
!  control flags     =  error flag + phase flag + info flag
!ALL
   define boolean params("DEBUG,ERRORS,PHASE,FONTS,PAGES,INFO,PAUSE,QUIET," %c
                        ."BACK,VCENTre,HCENTre,DYNamic,NODB", control flags, 0)
   process parameters(cli param)
   %if control flag(info flag) %start
      print string (banner); newlines(2)
   %finish
   %if control flag(nodb flag) %start
     printstring("Database update suppressed");newline
   %finish
   copies = |copies|
   %if copies#1 %and control flag(info flag) %start
     print string("- doing"); write(copies,1); print string(" copies.")
     newline
   %finish
   dvi file name = dvi file name .".DVI" %unless dvi file name -> (".")
   %unless exists(dvi file name) %start
      %unless dvi file name -> (":") %start
         dvi file name = default dvi directory name . dvi file name
         -> file ok %if exists(dvi file name)
      %else
         bad dvi(dvi file name." doesn't exist!")
      %finish
   %finish
file ok:
   bad dvi("Can't open ".dvi file name."!") %unless %c
      open input channel(dvi file name, dvi channel)
   resolution = vupi
%end

{*****************************************************************************}

%routine read byte(%byte %name byte)
   %on %event 9 %start
      byte=0
      %return
   %finish
   read symbol(byte)
%end

%integer %function get byte
   %byte b
   %integer c
   read byte(b)
   cur loc = cur loc+1
   c <- b&255
   %result = c
%end

%integer %function signed byte
   %byte b
   read byte(b)
   cur loc = cur loc+1
   %result = b %if b<128
   %result = b-256
%end

%integer %function get two bytes
   %byte a,b
   read byte(a); read byte(b)
   cur loc = cur loc+2
   %result = a*256 + b
%end

%integer %function signed pair
   %byte a,b
   read byte(a); read byte(b)
   cur loc = cur loc+2
   %result = a*256+b %if a<128
   %result = (a-256)*256+b
%end

%integer %function get three bytes
   %byte a,b,c
   read byte(a); read byte(b); read byte(c)
   cur loc = cur loc+3
   %result = (a*256+b)*256+c
%end

%integer %function signed trio
   %byte a,b,c
   read byte(a); read byte(b); read byte(c)
   cur loc = cur loc+3
   %result = (a*256+b)*256+c %if a<128
   %result = ((a-256)*256+b)*256+c
%end

%integer %function signed quad
   %byte a,b,c,d
   read byte(a); read byte(b); read byte(c); read byte(d)
   cur loc = cur loc + 4
   %result = ((a*256+b)*256+c)*256+d %if a<128
   %result = (((a-256)*256+b)*256+c)*256+d
%end


%routine print real(%real number, %integer int len, frac len)
   print string(rtos(number, int len, frac len))
%end

%routine skip font
   %integer dud,count,i
   dud=signed quad
   dud=signed quad
   dud=signed quad
   count=get byte+get byte
   dud=getbyte %for i=1,1,count
%end


%routine skip bytes(%integer bytes)

  %integer loop
  %byte x

  %for loop=1,1,bytes %cycle
    readsymbol(x)
  %repeat
%end   { skip bytes }


%routine getstring(%string(10) %name s,%integer len)

  %integer loop

  s = ""
  %for loop = 1,1,len %cycle
    s = s.tostring(getbyte)
  %repeat
%end   { getstring }

{*****************************************************************************}

%routine read preamble
   %integer p,k,i
   p = get byte
   %unless p=247 %start
      bad dvi("First byte isn't start of preamble!")
   %finish
   p = get byte
   %unless p=id byte %start
      bad dvi("identification in byte 1 should be ".itos(id byte,1)."!")
   %finish
   numerator = signed quad
   denominator = signed quad
   bad dvi("numerator is not positive") %unless numerator>0
   bad dvi("denominator is not positive") %unless denominator>0
   conv = (numerator/254000.0)*(resolution/denominator)
   mag = signed quad
   mag = new mag %if new mag > 0
   bad dvi("magnification is not positive") %unless mag>0
   true conv = conv
   conv = true conv*(mag/1000.0)
   p=get byte
   %if control flag(info flag) %start
      print string ("File: "); print string (dvi file name)
      print string(" --- '")
      print symbol(get byte) %for k=1,1,p
      print symbol('''')
      newline
      print string("magnification="); write(mag,1)
      print string("; "); print real(conv,16,8)
      print string(" pixels per DVI unit"); newline
   %else
      i = get byte %for k=1,1,p
   %finish
%end

%routine read postamble
   %byte %array buffer (0:1023)
   %byte pad symbol
   %integer p,k,q,a,l
   %byte %name pointer

   access file(dvi file name, 0, k, p)
   q=0
   pointer == buffer(0)
   pad symbol = 0
   %cycle
      %if q<5 %start
         p=p+q
         q=1024
         q=p %if q>p
         p=p-q
         bad dvi("null file") %if q<5
         read region(k, p, q, pointer)
      %finish
      q=q-1
      pad symbol = 16_DF %if buffer(q)#0
   %repeat %until buffer(q)#pad symbol
   deaccess file(k)
   %unless buffer(q)=id byte %start
      bad dvi("id byte in post-post-amble should be".itos(id byte,1)."!")
   %finish
   p = (buffer(q-4)<<24) ! (buffer(q-3)<<16) ! (buffer(q-2)<<8) ! buffer(q-1)
   post pointer = p+29
   set input(p+1)

   back pointer = signed quad
   %if signed quad # numerator %and control flag(error flag) %start
      print string("postamble numerator doesn't match the preamble!")
      newline
   %finish
   %if signed quad # denominator %and control flag(error flag) %start
      print string("postamble denominator doesn't match the preamble!")
      newline
   %finish
   %if signed quad # mag %start
      %if new mag#0 %and control flag(error flag) %start
         print string("postamble magnification doesn't match the preamble!")
         newline
      %finish
   %finish
   doc height = signed quad
   doc width  = signed quad
   %if control flag (hcent flag) %start
      doc left margin = print width//2 - int(conv*doc width/2)-49 + left margin
   %else
      doc left margin = left margin + 300-84
   %finish
   %if control flag (vcent flag) %start
      doc top margin = print height//2 - int(conv*doc height/2)-75 + top margin
   %else
      doc top margin = top margin + 300-67
   %finish
   stack size = get two bytes
   total pages = get two bytes
   max fonts = 0
   %cycle
      k = get byte
      %if 243 <= k <= 246 %start
         p=get byte %and k=k-1 %until k=242
         max fonts = max fonts+1
         skip font
         k=138
      %finish
   %repeat %until k#138
%end

{*****************************************************************************}

%on %event 2, 15 %start
   %if event_event=2 %start
      %if control flag(error flag) %start
         print string(" --- Sorry, not enough memory.");newline
      %finish
   %finish
   -> jump out
%finish

select output(terminal channel)
!$IF LEVEL1
!set up
!ALL
dialog
read preamble
read postamble
max widths = 128*max fonts

{*****************************************************************************}

%begin

   %constant %string  (4) root="T_", sep sym=":", fil typ=".PX"
   %constant %integer number of directories = 9
   %constant %integer %array directory names(1:number of directories) =
              1200, 1500, 1643, 1800, 2160, 2592, 3110, 3732, 4479

   %string(name length)%array font name (0:max fonts)
   %integer %array font num,
                   font check sum,
                   font scaled size,
                   font design size,
                   font space (0:max fonts),
                   width,
                   pixel width (0:max widths),
                   page pointer(1:total pages),
                   count (1:total pages, 0:9)

   %string(4)%array font directory(0:max fonts)

   %string(10) %array myfontname(0:max fonts)
   %byte %array fonts(0:max fonts)
   %integer %array fontsize(0:max fonts)


   %integer current page, copy,
            h,v,w,x,y,z,hh,vv,
            next page, start page,
            pixel space,
            fontcount = 0

!$IF CANON
!  %byte %array output mode(1:total pages)
!  %byte %array copies reqd(1:total pages)
!
!  %byte output mode flag
!ALL

!$IF LEVEL1
!
!  %constant %integer mouse working = 1,
!                     mouse silent  = 0,
!                     mouse dead    =-1
!
!  %integer mouse present
!
!     %routine initialise level 1
!        %integer %name b
!
!        %if check for mouse %start
!           mouse present = mouse silent
!        %else
!           mouse present = mouse dead
!        %finish
!
!        sys read font ("tex:symbols", b)
!
!        mode (bottom half ,bottom half ,1)
!        disable(black)
!        colour(blue)
!        box(0,0,320,450)
!
!        box(500,  0,60,60); box(560,  0,60,60); box(620,  0,60,60)
!        box(500, 60,60,60); box(560, 60,60,60); box(620, 60,60,60)
!        box(500,120,60,60); box(560,120,60,60); box(620,120,60,60)
!        box(500,180,60,60); box(560,180,60,60); box(620,180,60,60)
!               box(500,240,90,60);   box(590,240,90,60)
!
!        box(500,310,180,200)
!
!        l1ps (b, 400, 20, green, "KEY PAD")
!        l1ps (0, 412, 40, cyan,  "+ Convert")
!        l1ps (0, 416, 50, cyan,  "Function")
!        l1ps (0, 404, 65, cyan,  "(fast move)")
!        l1ps (b, 400,330, green, "MOUSE")
!
!        l1ps (b, 516, 30, green, "ab")
!        l1ps (b, 576, 30, green, "cd")
!        l1ps (b, 636, 30, green, "ef")
!        l1ps (b, 516, 50, green, "gh")
!        l1ps (b, 576, 50, green, "ij")
!        l1ps (b, 636, 50, green, "kl")
!        l1ps (b, 516, 90, green, "mn")
!        l1ps (b, 636, 90, green, "op")
!        l1ps (b, 516,110, green, "qr")
!        l1ps (b, 636,110, green, "st")
!        l1ps (b, 516,150, green, "uv")
!        l1ps (b, 576,150, green, "wx")
!        l1ps (b, 636,150, green, "yz")
!        l1ps (b, 516,170, green, "12")
!        l1ps (b, 576,170, green, "34")
!        l1ps (b, 636,170, green, "56")
!
!        l1ps (0, 575, 95, green, "Draw")
!        l1ps (0, 516,205, green, "Prev")
!        l1ps (0, 512,225, cyan,  "First")
!        l1ps (0, 576,215, green, "Pick")
!        l1ps (0, 636,207, green, "Next")
!        l1ps (0, 636,225, cyan,  "Last")
!        l1ps (0, 515,275, green, "Zoom out")
!        l1ps (0, 608,275, green, "Zoom in")
!
!        l1ps (0, 520,334, green, "* . .   Zoom out")
!        l1ps (0, 520,358, green, ". * .   Draw")
!        l1ps (0, 520,382, green, ". . *   Zoom in")
!        l1ps (0, 520,412, green, "* * .   Previous")
!        l1ps (0, 520,436, green, ". * *   Next")
!        l1ps (0, 520,460, green, "* . *   Pick")
!        l1ps (0, 520,490, green, "* * *   Quit")
!
!        l1ps (0,  50,476, cyan,  banner)
!        l1ps (0,  50,500, green, "Please report bugs to DMB on ECSVAX")
!
!        heap put(b)
!     %end
!ALL


{*****************************************************************************}
   
   %predicate read in page number
      %integer i, j, flags, spec
      %integer %array start(0:9)

      %routine skip spaces
         skip symbol %while next symbol =' '
      %end

      %integer %function read integer
         %constant %integer max int= ((-1)>>1)//10
         %integer number, sign

         number=0; sign=1
         %if next symbol='-' %start
            skip symbol
            sign = -1
         %finish
         %while '0'<=next symbol<='9' %cycle
            number=number*10 - '0' + nextsymbol %unless number>=max int
            skip symbol
         %repeat
         %result = number*sign
      %end

      %on %event 3,4,9 %start
         %false
      %finish

      spec =-1; flags = 0
      %cycle
         skip symbol %while next symbol <=' '
         %if next symbol = '-' %or '0'<=next symbol<='9' %start
            i = read integer
            %unless spec=9 %start
               spec = spec+1
               start(spec)=i
               flags = flags ! (1<<spec)
            %finish
         %else %if next symbol='*'
            skip symbol
            spec = spec+1 %unless spec=9
         %else
            write(next symbol,0); newline
            %exit
         %finish
         skip spaces
         %exit %unless next symbol='.'
         skip symbol
      %repeat
      skip spaces
      %if next symbol='#' %or next symbol=',' %start
         skip symbol
         start page = read integer
         %false %if start page<=0
         skip spaces
      %else
         start page = 1
      %finish

      %if control flag(debug flag) %start
         %for i=0,1,spec %cycle
            print symbol('.') %unless i=0
            write(start(i),0)
         %repeat
         print symbol('#'); write(start page,0); newline
      %finish

      read symbol(i) %until i=nl

      %if spec=-1 %start
         %true %if start page<=total pages
         %false
      %finish
      
      %for i=1,1,total pages %cycle
         %for j=0,1,spec %cycle
            %exit %if flags & (1<<j) # 0 %and start(j)#count(i,j)
            %if j=spec %start
               start page = start page-1
               %if start page=0 %start
                  start page=i
                  %true
               %finish
            %finish
         %repeat
      %repeat
      %false
   %end

      %routine print font(%integer f)
         %if f=nf %start
            print string("Undefined!")
         %else
            print string (font name(f))
         %finish
      %end

      %routine display font(%integer f)
         %own %integer last printed=-1
         %integer k,n
         %if last printed=f %then spaces(3) %else %start
            last printed=f
            font num(nf)=f
            n=0
            n=n+1 %while font num(n)#f
            print string("Font")
            write(f,4)
            print string(": ")
            %if n=nf %start
               print string("Undefined!")
            %else %if font name(n)=""
               print string("null font name!")
            %else
               print string(font name(n))
            %finish
         %finish
      %end

%integer %function first par(%byte o)
   %switch case of(128:255)
   %result=o %if o<128
   -> case of(o)
!  set 1, put 1, fnt 1, xxx 1, fnt def 1
case of(128):case of(133):case of(235):case of(239):case of(243):
   %result=get byte

!  set 2, put 2, fnt 2, xxx 2, fnt def 2
case of(129):case of(134):case of(236):case of(240):case of(244):
   %result=get two bytes

!  set 3, put 3, fnt 3, xxx 3, fnt def 3
case of(130):case of(135):case of(237):case of(241):case of(245):
   %result=get three bytes

!  right 1, w1, x1, down1, y1, z1
case of(143):case of(148):case of(153):case of(157):case of(162):case of(167):
   %result=signed byte

!  right 2, w2, x2, down2, y2, z2
case of(144):case of(149):case of(154):case of(158):case of(163):case of(168):
   %result=signed pair

!  right 3, w3, x3, down3, y3, z3
case of(145):case of(150):case of(155):case of(159):case of(164):case of(169):
   %result=signed trio

!  set4,put4,fnt4,xxx4,fnt def4; right4,w4,x4,down4,y4,z4; set rule,put rule
case of(131):case of(136):case of(238):case of(242):case of(246):
case of(146):case of(151):case of(156):case of(160):case of(165):case of(170):
case of(132):case of(137):
   %result=signed quad

!  w0
case of(147):  %result=w
!  x0
case of(152):  %result=x
!  y0
case of(161):  %result=y
!  z0
case of(166):  %result=z

!  nop, bop, eop; push, pop, pre, post, post-post
case of(138):case of(139):case of(140):
case of(141):case of(142):case of(247):case of(248):case of(249):
   %result=0

!  fnt num 0 ... fnt num 63
case of(171):case of(172):case of(173):case of(174):case of(175):case of(176):
case of(177):case of(178):case of(179):case of(180):case of(181):case of(182):
case of(183):case of(184):case of(185):case of(186):case of(187):case of(188):
case of(189):case of(190):case of(191):case of(192):case of(193):case of(194):
case of(195):case of(196):case of(197):case of(198):case of(199):case of(200):
case of(201):case of(202):case of(203):case of(204):case of(205):case of(206):
case of(207):case of(208):case of(209):case of(210):case of(211):case of(212):
case of(213):case of(214):case of(215):case of(216):case of(217):case of(218):
case of(219):case of(220):case of(221):case of(222):case of(223):case of(224):
case of(225):case of(226):case of(227):case of(228):case of(229):case of(230):
case of(231):case of(232):case of(233):case of(234):
   %result=o-171

case of(*): 
   %result=0
%end

%predicate open append channel(%string(127) filename, %integer channel)

  %on %event 3,9 %start
    %false
  %finish

  %false %unless exists(filename)
  open append(channel,filename)
  %true
%end


%routine append database

  %integer loop

  %on %event 9,2 %start
    select output(terminal channel)
    printstring("Error writing database file");newline
    -> out
  %finish

  select output(terminal channel)
  printstring("Writing out database");newline
  select output(dbchannel)
  printstring(dvi filename);newline
  write(fontcount,0);newline
  %for loop=0,1,fontcount-1 %cycle
    write(fonts(loop),0)
    printsymbol(9)
    printstring(myfontname(loop))
    printsymbol(9)
    write(fontsize(loop),0)
    newline
  %repeat
  close output
out:
%end   { append database }

{*****************************************************************************}

      %routine finish reading post amble
         %integer k,p, error

         %routine examine font(%integer e)
            %constant %integer file name length = 2+4+1+name length+4
            %integer f,c,d,k,n,p,q,mismatch
            %string(file name length) file name

            %predicate best font(%string(file name length)%name file,
                                 %integer %name error,
                                 %integer q, d)

               %real %array ratio (1:number of directories)
               %integer %array dir(1:number of directories)

               %string(name length) base
               %real reqd, rtemp
               %integer i,j, itemp

               base = file
               reqd = resolution*5 * q/d * conv/true conv

               %for i=1,1,number of directories %cycle
                  dir(i) = directory names(i)
                  rtemp = float(dir(i))
                  %if reqd > rtemp %then ratio(i)=reqd/rtemp %elsec
                                         ratio(i)=rtemp/reqd
               %repeat

               %for i=1,1,number of directories %cycle
                  %for j=i+1,1,number of directories %cycle
                     %if ratio(j)<ratio(i) %start
                        rtemp=ratio(i); ratio(i)=ratio(j); ratio(j)=rtemp
                        itemp = dir(i);  dir (i)= dir (j); dir (j) =itemp
                     %finish
                  %repeat
                  file=""
                  error = int(100 * ratio(i))
                  %for j=1,1,4 %cycle
                     itemp = dir(i)//10
                     file = to string('0'-10*itemp+dir(i)).file
                     dir(i) = itemp
                  %repeat
                  font directory(nf) = file
                  file = root.file.sep sym.base.fil typ
                  %true %if exists(file)
               %repeat
               font directory(nf)="none"
               %false
            %end


            capacity("max fonts") %if nf = max fonts
            font num(nf)=e
            fonts(fontcount) = e
            f=0
            f=f+1 %while font num(f)#e
            c=signed quad; font check sum(nf)=c
            q=signed quad; font scaled size(nf)=q
            d=signed quad; font design size(nf)=d
            p=get byte; n=get byte
            file name = ""
            n=n+p
            capacity("max font name length") %if n > name length
            %for k=0,1,n-1 %cycle
               p = get byte
               p = p-'a'+'A' %if 'a' <= p <= 'z'
               file name = file name. to string(p)
            %repeat
            %if f=nf %start
               font name(f) = file name
               myfontname(fontcount) = file name
               %unless best font (filename, error, q,d) %start
                  %if control flag(fonts flag + error flag) %start
                     nf = nf+1; display font(e); nf=nf-1
                     print string("---not loaded, PXL file can't be opened!")
                     newline
                  %finish
               %else %if q<0 %or q>1<<27
                  %if control flag(fonts flag + error flag) %start
                     nf = nf+1; display font(e); nf=nf-1
                     print string("---not loaded, bad scale")
                     newline
                  %finish
               %else %if d<0 %or d>1<<27
                  %if control flag(fonts flag + error flag) %start
                     nf = nf+1; display font(e); nf=nf-1
                     print string("---not loaded, bad design size!")
                     newline
                  %finish
               %else
                  font space(nf) = q//6
                  k = file size(file name)//4 - 517
                  pixel space = pixel space + k
                  nf=nf+1; font space(nf)=0
                  fontsize(fontcount) = q
                  fontcount = fontcount+1
                  %if control flag(fonts flag) %start
                     display font(e)
                     d = int((100.0*conv*q)/(true conv*d))
                     print string("---to be loaded at size "); write(q,1)
                     print string(" DVI units; (");
                     write(k*4,1); print string("ish bytes)")
                     %if d#100 %start
                        newline
                        print string (" (this font is magnified ")
                        write(d-100,1)
                        print string ("%)")
                     %finish
                     %if error#100 %start
                        newline
                        print string(" (this pixel file is magnified ")
                        write(error-100,1)
                        print string ("%)")
                     %finish
                     newline
                  %finish
               %finish
            %else %if control flag(fonts flag + error flag)
               display font(e)
               print string("---this font was already defined!"); newline
               %if font check sum(f)#c %start
                  print string("---check sum doesn't match previous definition!")
                  newline
               %finish
               %if font scaled size(f)#q %start
                  print string("---scaled size doesn't match previous definition!")
                  newline
               %finish
               %if font design size(f)#d %start
                  print string("---design size doesn't match previous definition!")
                  newline
               %finish
               mismatch=false
               %for k=1,1,n+p %cycle
                  mismatch=true %unless char no(font name(f),k)=get byte
               %repeat
               %if mismatch=true %start
                  print string("---font name doesn't match previous definition!")
                  newline
               %finish
            %finish
         %end


         cur loc=post pointer; set input(post pointer)
         %cycle
            k = get byte
            %if 243 <= k <= 246 %start
               p = first par(k)
               examine font(p)
               k=138
            %finish
         %repeat %until k#138

         %unless control flag(nodb flag) %start
           %if open append channel(database,dbchannel) %then %start
             append database
             select output(terminal channel)
           %finish %else %start
             select output(terminal channel)
             printstring(database. " not found. (Don't Panic)")
             newline
           %finish
         %finish
      %end

   w=0; x=0; y=0; z=0
   pixel space = 0
   font name(0)=""
   font space(0)=0
   set terminal mode(no page)
   finish reading postamble
   %begin

{*****************************************************************************}

   %integer stored
   %integer  k,p

   %record %format char info ((%short pwidth, pheight,
                                      xoffset, yoffset,
                               %integer file, load) %orc
                              (%byte bc,bd,be,bf, b8,b9,ba,bb,
                                   reqd,b5,b6,b7, b0,b1,b2,b3))

   %record (char info) %array char dir(0:max widths+2)

   %record %format entry (%short type, code, x, y)
 
   %record (entry) %array store(0:store space)


   %routine pass bops setting count
      %integer page count, k
      %for page count = total pages, -1, 1 %cycle
         set input(back pointer+1)
         page pointer(page count) = back pointer
         count(page count, k)=signed quad %for k=0,1,9
         %if control flag(pages flag) %start
            print string("#");write(pagecount,4);printstring("@")
            write(back pointer,6); print string(" :")
            write(count(pagecount,k),1) %for k=0,1,9
            newline
         %finish
         back pointer = signed quad
      %repeat
   %end

   %routine define fonts
      %integer pixel size, pixel base
      %integer f,p,n,c,q,d,j,k,mismatch, width ptr, tfm checksum
      %string(255) current file name, name

      %predicate block load info(%string(255) file name)
         %integer size, split, ref
         %bytename buffer
         %integer %array temp (0:127)

         %false %unless exists(file name)

         access file (file name, 0, ref, size)
         buffer == byte integer(addr(temp))
         %cycle
            %false %if size < (1+512+5)*4
            split=128
            size = size-512
            read region(ref, size, 512, buffer)
            split=split-1 %until split=0 %or temp(split)=1001
         %repeat %until temp(split)=1001
         size = size + split*4 + 4
         pixel size = size - (1+512+5)*4
         %if loading=static %start
            pixel base = heap get(pixel size)
            buffer == byte integer(pixel base)
     { grab pixel size bytes from heap, put address into pixel base & buffer}
            read region(ref, 4, pixel size, buffer)
         %else
     {      display font(font num(f))
     {      print string(" --- (not actually loaded)."); newline
            pixel base = -1
         %finish
         buffer == byte integer(addr(char dir) +16*width ptr)
         read region(ref, pixel size+4, (512+5)*4, buffer)
         pixel size = pixel size//4
         deaccess file(ref)
         %true
      %end

      %predicate in pxl(%integer z)

         %constant %integer chars = 128
         %integer k, wp, alpha, beta, pixel, in width
         %record (char info) %name this

         alpha = 16*z; beta = 4
         %while z >= 1<<23 %cycle
            z = z>>1
            beta = beta - 1
         %repeat

         %if width ptr + chars > max widths %start
            %if control flag(error flag + fonts flag) %start
               display font(font num(f))
               print string ("---not loaded, DVItype needs larger width table")
               newline
            %finish
            %false
         %finish
         wp = width ptr + chars
         tfm check sum = integer(addr(char dir)+16*wp)
         %for k=width ptr,1,wp-1 %cycle
            this == char dir(k)
            in width = (((z*this_b3)>>8 + z*this_b2)>>8 + z*this_b1)>> beta
            %if this_b0 # 0 %start
               -> bad tfm %unless this_b0 = 255
               in width = in width-alpha
            %finish
            %if this_load=0 %start
               %if control flag(debug flag) %start
                  print string("Warning - null metric:")
                  write(font num(f),5);write(k-width ptr,4);newline
               %finish
               width(k)= 0          { 1<<22-1 !!!!!!!!!!!!!!!!!!!!!!!?
               pixel width(k) =0
            %else
               width(k)=in width
               pixel width(k)=int(conv*width(k))
            %finish
            %if pixel base<0 %then this_load=-1 %elsec
               this_load = this_file*4 + pixel base-4
         %repeat
         width ptr = wp
         %true
      bad tfm:
          %if control flag(error flag + fonts flag) %start
             display font(font num(f))
             print string("---not loaded, PXL file is bad"); newline
             %if control flag(debug flag) %start
                write(k,3);printstring(": ")
                write(char dir(k)_pwidth,0);printsymbol('x');write(char dir(k)_pheight,0)
                print string(" + ")
                write(char dir(k)_x offset,0);print symbol('x')
                write(char dir(k)_y offset,0); print string(" @ ")
                write(char dir(k)_file,0); print string("; ")
                write(char dir(k)_b0,0); print string(", ")
                write(char dir(k)_b1,0); print string(", ")
                write(char dir(k)_b2,0); print string(", ")
                write(char dir(k)_b3,0); newline
             %finish
         %finish
         %false
      %end


      width ptr=0
      %for f=0,1,nf-1 %cycle
         q = font scaled size(f)
         d = font design size(f)
         c = font checksum(f)
         name=font name(f)
         current file name = root.font directory(f).sep sym. name.fil typ
         %unless block load info(current file name) %start
            %if control flag(error flag + fonts flag) %start
               display font(font num(f))
               print string("---not loaded, PXL file can't be opened!")
               newline
            %finish
         %else %if in pxl(q)
            %if control flag(error flag + fonts flag) %start
               %if c#0 %and tfm check sum#0 %and c#tfm check sum %start
                  display font(font num(f))
                  print string("---beware: check sums do not agree")
                  newline
                  print string("     ("); write(c,1); print string(" vs. ")
                  write(tfm check sum,1); print symbol(')')
                  newline
               %finish
            %finish
            %if control flag(fonts flag) %start
               display font(font num(f))
               print string("---loaded at size "); write(q,1)
               print string(" DVI units; (");
               write(4*pixel size,1); print string(" bytes)")
               newline
            %finish
         %finish
      %repeat
      width(c) = invalid width %for c=nf*128,1,max fonts*128 {invalid fonts}
      pixel width(c) = 0       %for c=nf*128,1,max fonts*128 {invalid chars}
   %end

   %routine read in page

      %predicate do page
         %integer a,o,p,q,k, bad char, cur font,s
         %switch option (128:255)

         %integer %array h stack,
                         v stack,
                         w stack,
                         x stack,
                         y stack,
                         z stack,
                         hh stack,
                         vv stack (0:stack size)

         %on %event 15 %start
            print symbol('!')
            newline
            %false
         %finish

         %routine abortion(%string(127) reason)
            print string(reason)
            new line
            %signal %event 15
         %end

         %routine overflow(%string(31) name, %integer value)
            print string("DVItype capacity exceeded (")
            print string(name)
            print symbol('=')
            write(value,1)
            print string(")!")
            new line
            %signal %event 15
         %end

         %routine out text(%integer c,f,x,y)
            char dir(f*128+c)_reqd = 0
            store(stored)_type=-1
            store(stored)_code=128*f+c
            store(stored)_x=x
            store(stored)_y=y
            stored = stored+1
         %end


         %routine out rule(%integer dx,dy,x,y)
            %return %if dx<=0 %or dy<=0
            store(stored)_type= dx
            store(stored)_code=-dy
            store(stored)_x=x
            store(stored)_y=y
            stored = stored+1
         %end

         %routine show(%string (255) text, %integer which, value)
            print symbol('@'); write(a,1); print string(": ")
            print string(text)
            write(which,1) %unless which = no parm
            space %and write(value,1) %unless value = no parm
            newline
         %end

         %integer %function pixel round(%integer px)
            %result = int(conv * float(px))
         %end

         %integer %function rule pixels(%integer x)
            %integer n
            n = int(conv*x)
            %result=n
         %end


         cur font = nf
         s=0; h=0; v=0; w=0; x=0; y=0; z=0; hh=0; vv=0
         stored = 0

         %cycle
            a = cur loc
            o = get byte
            p = first par(o)
            -> fin set %if o<128
            -> option(o)
            
            !  set 1,2,3,4
            option(128):
            option(129):
            option(130):
            option(131):    -> fin set
            
            !  set rule
            option(132):    -> fin rule
            
            !  put 1,2,3,4
            option(133):
            option(134):
            option(135):
            option(136):    -> fin set
            
            !  put rule
            option(137):    -> fin rule
            
            !  nop
            option(138):    -> done
            
            !  bop
            option(139):   show("bop occured before eop", no parm, no parm); %false
            
            !  eop
            option(140):
               show("stack not empty at end of page!", no parm, s) %unless s=0
               %true
            
            !  push
            option(141):
               overflow("stack size", stack size) %if s = stack size
               hstack(s)=h; vstack(s)=v; wstack(s)=w; hhstack(s)=hh
               xstack(s)=x; ystack(s)=y; zstack(s)=z; vvstack(s)=vv
               s=s+1
               -> show state
            
            !  pull
            option(142):
               %if s=0 %start
                  show("(illegal at level zero)!", no parm, no parm)
               %else
                  s=s-1
                  hh=hhstack(s); h=hstack(s); w=wstack(s); x=xstack(s)
                  vv=vvstack(s); v=vstack(s); y=ystack(s); z=zstack(s)
               %finish
               -> show state
            
            !  right 1,2,3,4
            option(143):
            option(144):
            option(145):
            option(146):    -> move right
            
            !  w0,1,2,3,4
            option(147):
            option(148):
            option(149):
            option(150):
            option(151):   w=p; -> move right
            
            !  x0,1,2,3,4
            option(152):
            option(153):
            option(154):
            option(155):
            option(156):   x=p; -> move right
            
            !  down 1,2,3,4
            option(157):
            option(158):
            option(159):
            option(160):    -> move down
            
            !  y0,1,2,3,4
            option(161):
            option(162):
            option(163):
            option(164):
            option(165):   y=p; -> move down
            
            !  z0,1,2,3,4
            option(166):
            option(167):
            option(168):
            option(169):
            option(170):   z=p; -> move down
            
            ! fnt num 0..63
            option(171):option(172):option(173):option(174):option(175):option(176):
            option(177):option(178):option(179):option(180):option(181):option(182):
            option(183):option(184):option(185):option(186):option(187):option(188):
            option(189):option(190):option(191):option(192):option(193):option(194):
            option(195):option(196):option(197):option(198):option(199):option(200):
            option(201):option(202):option(203):option(204):option(205):option(206):
            option(207):option(208):option(209):option(210):option(211):option(212):
            option(213):option(214):option(215):option(216):option(217):option(218):
            option(219):option(220):option(221):option(222):option(223):option(224):
            option(225):option(226):option(227):option(228):option(229):option(230):
            option(231):option(232):option(233):option(234):          -> change font
            
            ! fnt 1,2,3,4
            option(235):
            option(236):
            option(237):
            option(238):   -> change font
            
            ! xxx special
            option(239):
            option(240):
            option(241):
            option(242):
               print string ("xxx'")
               bad char = false
               %for k=1,1,p %cycle
                  q = get byte
                  %if ' ' <= q <= '~' %start
                     print symbol(q)
                  %else
                     bad char = true
                  %finish
               %repeat
               print symbol('''')
               show("non-ASCII character in xxx command!", no parm, no parm) %if bad char=true
               -> done
            
            ! fnt def 1,2,3,4
            option(243):
            option(244):
            option(245):
            option(246):   skip font; -> change font
            
            !  pre
            option(247):   abortion("preamble command within a page")
            
            !  post, post post
            option(248):
            option(249):   abortion("postamble command within page!")
            
            option(*):     show("undefined command ",o, no parm); -> done

      fin set:
            %if 0 <= p <= 127 %start
               q = width(128*cur font + p)
            %else
               q = invalid width
            %finish
            %if q = invalid width %start
               print symbol('@'); write(a,4); print string(": character")
               write(p,1)
               print string(" invalid in font ")
               print font(cur font)
               print symbol ('!') %unless cur font = nf
               newline
            %else
               out text (p, cur font, doc left margin+hh, doc top margin+vv)
            %finish
            -> done %if o >= 133
            q=0 %if q = invalid width
            hh = hh + pixel width(128*cur font + p)
            -> check right

      fin rule:
            q = signed quad
            out rule(rule pixels(q),rule pixels(p),
                                        doc left margin+hh,doc top margin+vv)
            -> done %if o=137
            hh = hh + rule pixels(q)
            -> check right

      move right:
            %if |p| >= font space(cur font) %start
               hh = pixel round (h+p)
            %else
               hh = hh + pixel round(p)
            %finish
            q = p
      check right:
            h = h+q
            -> done

      move down:
            %if |p| >= 5*font space(cur font) %start
               vv = pixel round(v+p)
            %else
               vv = vv + pixel round(p)
            %finish
            v = v+p
            -> done

      show state:
            -> done

      change font:
            font num(nf)=p; cur font=0
            cur font = cur font+1 %while font num(cur font)#p
            -> done

      done:
         %repeat
      %end

      %routine ensure font loading

         %integer %function heap grab(%integer bytes)
            %own %integer kill=0
            %integer address, dead
            %record (char info) %name corpse

            %on %event 2 %start
               dead=kill
               %cycle
                  kill=0 %if kill >= nf*128
                  corpse == char dir(kill)
                  kill = kill+1
                  %signal %event 2 %if kill=dead
               %repeat %until corpse_reqd=255 %and corpse_load>0
               heap put (corpse_load)
               corpse_load = -1
            %finish

            address = heap get(bytes)
            %result = address
         %end

         %integer char, mem, f, ref
         %byte %integer %name buffer
         %string(63) file
         %record (char info) %name this


         %if control flag(phase flag) %start
            print string("Loading fonts"); newline
         %finish
         %for char=0,1,nf*128-1 %cycle
            this == char dir(char)
            %if this_reqd=0 %and this_load<0 %start
               mem = ((this_pwidth+31)//32)*4*this_pheight
               this_load = heap grab(mem)
               f = char//128
               file = root.font directory(f).sep sym.font name(f).fil typ
               %if exists(file) %start
                  buffer == byte integer(this_load)
                  access file(file, 0, ref, f)
                  read region(ref, this_file*4, mem, buffer)
                  deaccess file(ref)
               %else
                  abort(" --- file '".file."' has disappeared!")
               %finish
            %finish
         %repeat
         %if control flag(phase flag) %start
            print string("Fonts loaded"); new line
         %finish
      %end


      %if loading = dynamic %start
         char dir(k)_reqd=255 %for k=0,1,nf*128-1
      %finish
      %if control flag(info flag + pages flag) %start
         newline
         write(cur loc-45,1)
         print string(": beginning of page ")
         %for k=0,1,9 %cycle
            write(count(current page, k),1)
            print symbol('.') %unless k=9
         %repeat
         new line
      %finish
      bad dvi("page ended unexpectedly") %unless do page
      ensure font loading %if loading = dynamic
  {    %cycle                                {    ***
  {       k = get byte                       {   *   *
  {       %if 243 <= k <= 246 %start         {       *
  {          p = first par(k)                {      *
  {          skip font                       {     *
  {          k = 138                         {     *
  {       %finish                            {
  {    %repeat %until k#138                  {     *
      %if control flag(info flag) %start
         write(stored,1); print string(" characters/rulers stored.")
         newline
      %finish
   %end


      %routine move to page(%integer p)
         cur loc = page pointer(p)+45
         set input(cur loc)
      %end


!$IF LEVEL1
!     %routine view page
!
!        %constant %integer prev page = ms LM,
!                           pick page = ms LR,
!                           next page = ms MR,
!                           zoom out  = ms L,
!                           zoom in   = ms R,
!                           draw wndw = ms M,
!                           quit prog = ms LMR,
!                           do nothing= ms none,
!                           page one  = 256,
!                           last page = 257,
!                           esc       = 999
!
!        %integer x displacement, y displacement, scale factor, tolerance
!        %integer mouse mask, dx, dy, cmnd, key, key mask
!
!        %routine set displacement(%integer x,y)
!           x displacement=x; y displacement=y
!        %end
!
!        %routine redraw
!           %label vloop, hloop, c1, c2, vnext, return, ruler, done
!           %label smallx, smally, cx, cy, clpy, clipped, offscreen
!           %label bigx, bigy, weex, weey, iloop, oloop, last
!           %integer reg d4, reg d5, reg d6, reg d7, reg a4, reg a5, reg a6
!           %short y first, lines, this, width, lc
!           %short  startpixel, xdisp, ydisp, bm, rm
!           %short skew, offset, vd
!           %integer sfactor
!           %record (char info) %name cd0
!           %record (entry) %name ip
!
!           cd0 == chardir(0)
!
!           sfactor = scale factor
!           vd = vertical displacement & 512
!
!           rm = (688 * scale factor)
!           bm = (512 * scale factor)
!
!           x disp = x displacement
!           y disp = y displacement
!
!           this = stored
!
!           ip == store(0)
!
!            *move.l       d4,regd4
!            *move.l       d5,regd5
!            *move.l       d6,regd6
!            *move.l       d7,regd7
!            *move.l       a4,rega4
!            *move.l       a5,rega5
!            *move.l       a6,rega6
!            *move.l       sfactor,d7
!loop:       *subq.w       #1,this
!            *bmi          done
!            *movea.l      ip,a2
!            *movem.w      (a2)+,d0-d3
!            *move.l       a2,ip
!            *cmpi.w       #-1,d0
!            *bne          ruler
!            *lsl.l        #4,d1
!            *movea.l      cd0,a3
!            *adda.l       d1,a3
!
!            *movea.l      12(a3),a0
!            *move.w       #32,startpixel
!            *move.w       (a3),d1
!            *moveq        #31,d4
!            *add.w        d1,d4
!            *sub.w        xdisp,d2
!            *sub.w        4(a3),d2
!            *bmi          smallx
!            *cmp.w        rm,d2
!            *bpl          offscreen
!            *bra          cx
!smallx:     *move.w       d2,d0
!            *add.w        d1,d0
!            *bmi          offscreen
!            *add.w        d2,d1
!            *neg.w        d2
!            *moveq        #31,d0
!            *and.w        d2,d0
!            *sub.w        d0,startpixel
!            *lsr.w        #5,d2
!            *lsl.w        #2,d2
!            *adda.w       d2,a0
!            *clr.w        d2
!cx:         *lsr.w        #5,d4
!            *lsl.w        #2,d4
!            *move.w       d4,a4
!            *move.w       d2,d0
!            *add.w        d1,d0
!            *sub.w        rm,d0
!            *bmi          clpy
!            *sub.w        d0,d1
!
!clpy:       *move.w       d1,width
!            *move.w       2(a3),d1
!            *sub.w        6(a3),d3
!            *sub.w        ydisp,d3
!            *bmi          smally
!            *cmp.w        bm,d3
!            *bmi          cy
!            *bra          offscreen
!smally:     *move.w       d3,d0
!            *add.w        d1,d0
!            *bmi          offscreen
!            *moveq        #31,d0
!            *add.w        (a3),d0
!            *lsr.w        #5,d0
!            *add.w        d3,d1
!            *neg.w        d3
!            *mulu         d0,d3
!            *lsl.w        #2,d3
!            *adda.w       d3,a0
!            *moveq        #0,d3
!cy:         *move.w       d3,d0
!            *add.w        d1,d0
!            *sub.w        bm,d0
!            *bmi          clipped
!            *sub.w        d0,d1
!
!clipped:    *swap      d3
!            *move.w    d1,lines
!
!            *divu      d7,d2
!            *swap      d2
!            *not.w     d2
!            *add.w     d7,d2
!            *move.w    d2,skew
!            *swap      d2
!            *move.w    d2,d3
!            *not.w     d3
!            *andi.w    #7,d3
!            *lsr.w     #3,d2
!            *move.w    d2,a2
!            *moveq     #1,d2
!            *lsl.w     d3,d2
!            *move.w    d2,offset
!            *clr.l     d2
!            *clr.w     d3
!            *swap      d3
!            *divu      d7,d3
!            *move.w    d3,d2
!            *swap      d3
!            *not.w     d3
!            *add.w     d7,d3
!            *move.w    d3,lc
!            *lea       16_E00000,a3
!            *adda.l    a3,a2
!            *neg.w     d2
!            *addi.w    #511,d2
!            *add.w     vd,d2
!            *lsl.l     #7,d2
!            *adda.l    d2,a2
!            *movea.l   a0,a3
!  vloop:    *move.l    a2,a1
!            *move.l    a3,a0
!            *move.l    (a0)+,d4
!            *move.w    startpixel,d0
!            *move.w    width,d1
!            *move.w    skew,d2
!            *move.w    offset,d3
!  hloop:    *subq.w    #1,d0
!            *bpl       c1
!            *move.l    (a0)+,d4
!            *addi.w    #32,d0
!  c1:       *btst      d0,d4
!            *beq       c2
!            *move.b    d3,(a1)
!            *sub.w     d2,d0
!            *sub.w     d2,d1
!            *sub.w     d2,d2
!  c2:       *subq.w    #1,d1
!            *ble       vnext
!            *dbra      d2,hloop
!            *add.w     d7,d2
!            *ror.b     #1,d3
!            *bcc       hloop
!            *addq.l    #1,a1
!            *bra       hloop
!  vnext:    *subq.w    #1,lines
!            *bls       return
!            *adda.w    a4,a3
!            *subq.w    #1,lc
!            *bpl       vloop
!            *add.w     d7,lc
!            *sub.w     #128,a2
!            *bra       vloop
!
!ruler:      *add.w     d2,d0
!            *add.l     d3,d1
!            *exg       d3,d1
!            *sub.w     xdisp,d2
!            *bpl       bigx
!            *moveq     #0,d2
!bigx:       *sub.w     ydisp,d3
!            *bpl       bigy
!            *moveq     #0,d3
!bigy:       *sub.w     xdisp,d0
!            *bmi       offscreen
!            *sub.w     ydisp,d1
!            *bmi       offscreen
!            *cmp.w     rm,d2
!            *bpl       offscreen
!            *cmp.w     bm,d3
!            *bpl       offscreen
!            *cmp.w     rm,d0
!            *bmi       weex
!            *move.w    rm,d0
!            *subq.w    #1,d0
!weex:       *cmp.w     bm,d1
!            *bmi       weey
!            *move.w    bm,d1
!            *subq.w    #1,d1
!weey:       *divu      d7,d0
!            *divu      d7,d1
!            *divu      d7,d2
!            *divu      d7,d3
!     {      *ext.l     d3     Hamish's fucking compiler "doesn't know" this!
!            *swap      d3
!            *clr.w     d3
!            *swap      d3
!            *sub.w     d3,d1
!            *neg.w     d3
!            *addi.w    #511,d3
!            *add.w     vd,d3
!            *lsl.l     #7,d3
!            *lea       16_E00000,a3
!            *adda.l    d3,a3
!            *moveq     #-1,d3
!            *moveq     #31,d4
!            *and.w     d2,d4
!            *lsr.w     #5,d2
!            *lsr.l     d4,d3
!            *moveq     #31,d4
!            *and.w     d0,d4
!            *lsr.w     #5,d0
!            *sub.w     d2,d0
!            *subq.w    #1,d0
!            *lsl.w     #2,d2
!            *adda.w    d2,a3
!            *moveq     #1,d2
!            *ror.l     #1,d2
!            *asr.l     d4,d2
!oloop:      *movea.l   a3,a2
!            *move.l    d3,d5
!            *move.w    d0,d4
!            *bmi       last
!iloop:      *move.l    d5,(a2)+
!            *moveq     #-1,d5
!            *dbra      d4,iloop
!last:       *and.l     d2,d5
!            *move.l    d5,(a2)
!            *sub.w     #128,a3
!            *dbra      d1,oloop
!
!offscreen:
!return:     *bra       loop
!
!done:       *move.l      regd4,d4
!            *move.l      regd5,d5
!            *move.l      regd6,d6
!            *move.l      regd7,d7
!            *move.l      rega4,a4
!            *move.l      rega5,a5
!            *move.l      rega6,a6
!        %end
!
!
!        %unless mouse present = mouse dead %start
!           ms x = 0; ms y = 0; mouse mask = ms none
!        %finish
!        key mask = 0
!        disable(blue+green)
!        clear(bottom half)
!        colour(red)
!        mode (bottom half ,bottom half ,1)
!        scale factor = 8
!        set displacement(0,0)
!        redraw
!        scale factor = 4
!        tolerance = 1
!        %cycle
!           enable(invert)
!           colour(invert)
!           mode(ditto, bottom half, 1)
!           box(x displacement>>3, y displacement>>3, 86*scale factor, 64*scale factor)
!           colour(black)
!
!           dx = 0; dy = 0; cmnd = do nothing
!           %while |dx| + |dy| < tolerance %and cmnd = do nothing %cycle
!              key = test symbol
!                 
!              %while key > -1 %cycle
!                 %if key=27 %start
!                    key mask = esc
!                 %else
!                    key = key + keymask
!                    keymask = 0
!                 %finish
!                 dy = dy-16 %if key = '7' %or key = '8' %or key = '9'
!                 dy = dy+16 %if key = '1' %or key = '2' %or key = '3'
!                 dx = dx-16 %if key = '7' %or key = '4' %or key = '1'
!                 dx = dx+16 %if key = '9' %or key = '6' %or key = '3'
!                 dy = dy-100%if key=esc+'L' %or key=esc+'i' %or key=esc+'1'
!                 dy = dy+100%if key=esc+'K' %or key=esc+'f' %or key=esc+'J'
!                 dx = dx-100%if key=esc+'L' %or key=esc+'M' %or key=esc+'K'
!                 dx = dx+100%if key=esc+'1' %or key=esc+'2' %or key=esc+'J'
!                 cmnd = draw wndw %and %exit %if key = '5'
!                 cmnd = draw wndw %and %exit %if key = esc+'O'
!                 cmnd = prev page %and %exit %if key = '0' 
!                 cmnd = page one  %and %exit %if key = esc+'p'
!                 cmnd = pick page %and %exit %if key = ','
!                 cmnd = pick page %and %exit %if key = esc+'^'
!                 cmnd = next page %and %exit %if key = '.'
!                 cmnd = last page %and %exit %if key = esc+']'
!                 cmnd = zoom out  %and %exit %if key = '-'
!                 cmnd = zoom in   %and %exit %if key = nl
!                 key = test symbol
!              %repeat
!              %if mouse present # mouse dead %start
!                 mouse present = mouse working %if ms x#0 %or ms y#0
!                 dx = dx + ms x*2; ms x=0
!                 dy = dy - ms y*2; ms y=0
!                 %if ms buttons = ms none %start
!                    %if cmnd = do nothing %start
!                       cmnd = mouse mask %if mouse present = mouse working
!                       mouse mask = do nothing
!                    %finish
!                 %else
!                    mouse mask = mouse mask ! ms buttons
!                 %finish
!              %finish
!           %repeat
!           tolerance = 1
!
!           box(x displacement>>3, y displacement>>3, 86*scale factor, 64*scale factor)
!           mode (bottom half ,bottom half ,1)
!           x displacement = x displacement + dx
!           y displacement = y displacement + dy
!           x displacement =    0 %if x displacement<0
!           x displacement = 2559 %if x displacement>2559
!           y displacement =    0 %if y displacement<0
!           y displacement = 3599 %if y displacement>3599
!           set displacement(x displacement, y displacement)
!           %if cmnd = zoom out %start
!              scale factor = scale factor+1 %unless scale factor=8
!           %else %if cmnd = zoom in
!              scale factor = scale factor-1 %unless scale factor=1
!           %else %if cmnd = prev page
!              current page = current page-1 %unless current page=1
!              %exit
!           %else %if cmnd = next page
!              current page = current page+1 %unless current page=total pages
!              %exit
!           %else %if cmnd = page one
!              current page = 1
!              %exit
!           %else %if cmnd = last page
!              current page = total pages
!              %exit
!           %else %if cmnd = quit prog
!              current page = total pages+1
!              %exit
!           %else %if cmnd = pick page
!              %begin
!                 %on %event 1,2,3,4,5,6,7,8,9,10 %start
!                     current page=0
!                 %finish
!                 select input(terminal channel)
!                 prompt ("Page: ")
!                 %cycle
!                 %repeat %until read in page number
!                 current page = start page
!              %end
!              select input(dvi channel)
!              %exit
!           %else %if cmnd = draw wndw
!              disable(black)
!              clear(top half)
!              mode(top half, top half, 1)
!              colour(yellow)
!              redraw
!              cmnd = test symbol %until cmnd<0
!              %if mouse present # mouse dead %start
!                 ms x = 0; ms y = 0
!              %finish
!              tolerance = 16
!           %finish
!        %repeat
!     %end
!$IF CANON
!     %routine paint
!        %integer symbol
!        %record (entry) %name item
!
!        %routine paint char(%integer c,x,y)
!           %constant %integer bytes per line = 320, {2560 bits}
!                              x max = 2560,         {2400 ?}
!                              y max = 3500          {for 3600?}
!
!           %integer x0, y0, clip left, clip right, xxxxx,
!                    p, bp, ptr, pntr,
!                    w, lw, line, word, shift, h
!
!           %byte %integer %name frame pontr
!           %record (char info) %name char data
!
!           char data == char dir(c)
!           frame pontr == frame(0)
!
!           w = char data_p width
!           h = char data_p height
!           bp= char data_load
!           %if bp<0 %start
!              print string("character not loaded => not printed");newline
!              %return
!           %finish
!           x0= x - char data_x offset
!           y0= y - char data_y offset
!           x = x0 + w - 1
!           y = y0 + h - 1
!           clip left = 0
!           clip right= 0
!           lw= ((w+31)>>5)*4
!
!           %unless x<0 %or x0 >= x max %orc
!                   y<0 %or y0 >= y max %start
!
!              %if y0<0 %start
!                 h = h+y0
!                 bp= bp - y0*lw
!                 y0= 0
!              %finish
!
!              %if y>= y max %start
!                 h = h + y max - y -1
!              %finish
!
!              %if x>= x max %start
!                 w = w + x max - x -1
!                 clip right = 1
!              %finish
!
!              x = x0
!               %if x0<0 %start
!                 x0= ((-x0)>>4)*2
!                 bp= bp + x0
!                 w = w - x0*8
!                 clip left = 1
!                 x0 = 0
!              %finish
!
!              pntr = addr(frame) + (x0>>4)*2 + y0*bytes per line
! {         print string("pntr = "); write(pntr,9); newline
! {         print string("addr(frame) = "); write(addr(frame),9); newline
! {         print string("x0 = "); write(x0,9); newline
! {         print string("y0 = "); write(y0,9); newline
! {            *move.l framepontr,xxxxx
! {            pntr = xxxxx + (x0>>4)*2 + y0*bytes per line
! {         print string("pntr = "); write(pntr,9); newline
! {         print string("xxxxx = "); write(xxxxx,9); newline
!              x0 = x & 15
!              shift = 16 - x0
!              w = (w-1)>>4 - clip left - clip right
!
!              %for line = 1,1,h %cycle
!                 p = bp
!                 ptr = pntr
!
!                 %if clip left#0 %start
!                    half integer(ptr) = half integer(ptr) %c
!                                      ! (half integer(p)<<shift)&16_FFff
!                    p = p+2
!                 %finish
!
!  {              %for word =0,1,w %cycle
!  {                 integer(ptr) = integer(ptr) ! (half integer(p)<<shift)
!  {                 ptr = ptr+2
!  {                 p = p+2
!  {              %repeat
!  {
!  {              %if clip right#0 %start
!  {                 half integer(ptr) = half integer(ptr) ! (half integer(p)>>x0)
!  {              %finish
!
!            *move.l   ptr,a1
!            *move.l   p,a0
!            *move.l   shift,d1
!            *move.l   w,d2
!            *bmi      #16
!            *moveq    #0,d0
!            *move.w   (a0)+,d0
!            *lsl.l    d1,d0
!            *or.l     d0,(a1)
!            *addq     #2,a1
!            *dbra     d2,#-12
!            *nop
!            *nop
!            *nop
!
!                 bp = bp + lw
!                 pntr = pntr + bytes per line
!              %repeat
!           %finish
!        %end
!
!        %routine paint ruler(%integer dx,dy,x,y)
!           %constant %short bytes per line = 320, {2560 bits}
!                            x max = 2560,         {2400 ?}
!                            y max = 3500          {for 3600?}
!
!           %label bigx, bigy, weex, weey, iloop, oloop, last, invisible
!           %integer regd4, regd5
!           %short xdisp, ydisp; xdisp=0; ydisp=0
!
!            *move.l    d4,regd4
!            *move.l    d5,regd5
!            *move.l    x,d2
!            *move.l    y,d1
!            *move.l    dx,d0
!            *bmi       invisible
!            *beq       invisible
!            *move.l    dy,d3
!            *neg.l     d3
!            *bgt       invisible
!            *add.w     d2,d0
!            *add.l     d1,d3
!            *sub.w     xdisp,d2
!            *bpl       bigx
!            *moveq     #0,d2
!bigx:       *sub.w     ydisp,d3
!            *bpl       bigy
!            *moveq     #0,d3
!bigy:       *sub.w     xdisp,d0
!            *bmi       invisible
!            *sub.w     ydisp,d1
!            *bmi       invisible
!            *cmp.w     #xmax,d2
!            *bpl       invisible
!            *cmp.w     #ymax,d3
!            *bpl       invisible
!            *cmp.w     #xmax,d0
!            *bmi       weex
!            *move.w    #xmax-1,d0
!weex:       *cmp.w     #ymax,d1
!            *bmi       weey
!            *move.w    #ymax-1,d1
!weey:       *sub.w     d3,d1
!            *mulu      #bytesperline,d3
!            *movea.l   frame,a3
!            *adda.l    d3,a3
!            *moveq     #-1,d3
!            *moveq     #31,d4
!            *and.w     d2,d4
!            *lsr.w     #5,d2
!            *lsr.l     d4,d3
!            *moveq     #31,d4
!            *and.w     d0,d4
!            *lsr.w     #5,d0
!            *sub.w     d2,d0
!            *subq.w    #1,d0
!            *lsl.w     #2,d2
!            *adda.w    d2,a3
!            *moveq     #1,d2
!            *ror.l     #1,d2
!            *asr.l     d4,d2
!oloop:      *movea.l   a3,a2
!            *move.l    d3,d5
!            *move.w    d0,d4
!            *bmi       last
!iloop:      *or.l      d5,(a2)+
!            *moveq     #-1,d5
!            *dbra      d4,iloop
!last:       *and.l     d2,d5
!            *or.l      d5,(a2)
!            *add.w     #bytesperline,a3
!            *dbra      d1,oloop
!invisible:  *move.l    regd4,d4
!            *move.l    regd5,d5
!       %end
!
!       reset frame
!       %for symbol=0,1,stored-1 %cycle
!          item == store(symbol)
!          %if item_type<0 %then paint char (item_code, item_x, item_y) %c
!               %else paint ruler(item_type, -item_code, item_x, item_y)
!       %repeat
!    %end
!
!
!     %routine print sheet
!        %if copies reqd (current page) > 0 %start
!           move to page(current page)
!           read in page
!           paint
!           %if control flag(pause flag) %start
!              select input(0); prompt("Press return when ready: ")
!              read symbol(copy) %until copy=nl
!              select input(dvi channel)
!           %finish
!           %if control flag(info flag ! pages flag) %start
!              print string("Printing"); write(copies reqd(current page),1)
!              %if copies reqd(current page) = 1 %start
!                 print string (" copy.")
!              %else
!                 print string(" copies.")
!              %finish
!              newline
!           %finish
!           print page %for copy=1,1,copies reqd(current page)
!  {        print symbol('.') %for copy=1,1,copies reqd(current page)
!        %finish
!     %end
!
!
!     %routine print pages(%integer from, step, to, mode)
!        %integer page, copy
!        %for page = from, step, to %cycle
!           current page = page
!           print sheet %if output mode(current page)=mode
!        %repeat
!     %end
!ALL


      %if pixel space*4+safety margin > free store %c
      %or control flag(dyn ld flag) %then loading = dynamic %c
                                    %else loading = static
      %if control flag(info flag + fonts flag) %start
         %if control flag(fonts flag) %start
            write(pixel space*4,0);print symbol('+');write(safety margin,0)
            print string(" vs."); write(free store,0);newline
         %finish
         %if loading=dynamic %start
            print string("(dynamically")
         %else
            print string("(statically")
         %finish
         print string(" loading fonts)."); newline
      %finish

      %if control flag(phase flag) %start
         print string("Pre-reading page numbers"); newline
      %finish
      pass bops setting count
      %if control flag(phase flag) %start
         print string("Defining fonts"); newline
      %finish
      define fonts
      %if control flag(phase flag) %start
         print string("Fonts defined"); new line
      %finish
!$IF LEVEL1
!     initialise level 1
!     current page=1
!     %while current page <= total pages %cycle
!        move to page(current page)
!        read in page
!        view page
!     %repeat
!$IF CANON
!     %if print sets = "" %start
!        copies reqd(current page) = copies %for current page =1,1,total pages
!     %else
!        %begin
!           %string(255) part range, print set
!        
!           %routine setup range(%string(255) range)
!        
!              %string(255) number
!              %integer do, first, last, page
!        
!              %integer %function decode(%string(255) text, %integer low, high)
!                  %integer acc, sign, sym
!        
!                  %on %event 1,2,3,4,5,6,7,8,9,10 %start
!                     %if control flag(error flag ! info flag) %start
!                        print string("*** ")
!                        print string(text)
!                        print string(": not a valid integer; zero substituted.")
!                        newline
!                     %finish
!                     %result = 0
!                  %finish
!        
!                  %if text -> ("-").text %start
!                     sign = -1
!                  %else
!                     sign = 1
!                  %finish
!        
!                  acc=0
!                  %signal %event 9 %if text = ""
!                  %for sym = 1, 1, length(text) %cycle
!                     %signal %event 9 %unless '0' <= charno(text,sym) <= '9'
!                     acc = acc*10 + charno(text, sym) - '0'
!                  %repeat
!        
!                  acc = acc * sign
!                  %signal %event 9 %unless low <= acc <= high
!                  %result = acc
!              %end
!        
!              %integer %function page number(%string(255) text)
!                 %constant %integer minus infinity = \((-1)>>1),
!                                    plus  infinity =   (-1)>>1
!                 %integer %array cnts(0:9)
!                 %integer cnt, inst, i,j
!                 %string(255) page
!
!                 %if text = "$" %start
!                    %result = total pages
!                 %else %if text -> ("#").text
!                    %result = decode(text, minus infinity, plus infinity)
!                 %else
!                    %if text -> text.("#").page %start
!                       inst = decode(page, 1, plus infinity)
!                    %else
!                       inst = 1
!                    %finish
!                    cnt=-1
!                    %while text -> page.(".").text %cycle
!                       %unless cnt=9 %start
!                          cnt = cnt + 1
!                          cnts (cnt) = decode (page, minus infinity, plus infinity)
!                       %finish
!                    %repeat
!                    %unless cnt=9 %start
!                       cnt = cnt + 1
!                       cnts (cnt) = decode (text, minus infinity, plus infinity)
!                    %finish
!                    
!                    %for i=1,1,total pages %cycle
!                       %for j=0,1,cnt %cycle
!                          %exit %if cnts(j) # count(i,j)
!                          inst = inst-1 %if j=cnt
!                       %repeat
!                       %result = i %if inst = 0
!                    %repeat
!                    %result = total pages
!                 %finish
!              %end
!        
!              %if range # "" %start
!                 %if range -> range.("*").number %start
!                    do = decode(number, 0, 255)
!                 %else
!                    do = copies
!                 %finish
!        
!                 %if range -> range.(":").number %start
!                    first = page number(range)
!                    last  = page number(number)
!                 %else
!                    first = page number(range)
!                    last  = first
!                 %finish
!        
!                 %if last >= first %start
!                    copies reqd(page) = do %for page=first,1,last
!                 %finish
!              %finish
!           %end
!     
!           copies reqd(current page) =0 %for current page=1,1,total pages
!
!           %while print sets -> print set.(" ").print sets %cycle
!              %while print set -> part range.(",").print set %cycle
!                 set up range(part range)
!              %repeat
!              set up range(print set)
!           %repeat
!           %while print sets -> part range.(",").print sets %cycle
!              set up range(part range)
!           %repeat
!           set up range(print sets)
!        %end
!     %finish
!
!     %if control flag(backd flag) %start
!        current page = 1
!        output mode(total pages)=0
!        output mode flag = 0
!        %while current page < total pages %cycle
!           %if |count(current page,0) - count(current page+1,0)| < 2 %start
!              output mode(current page)=1
!              current page = current page+1
!              output mode(current page)=2
!              output mode flag = 1
!           %else
!              output mode(current page)=0
!           %finish
!           current page = current page+1
!        %repeat
!        %unless output mode flag=0 %start
!           print pages(1,  1, total pages, 2)
!           select input(0); prompt("Transfer pages, press return when ready: ")
!           read symbol(copy) %until copy=nl
!           select input(dvi channel)
!           print pages(total pages, -1, 1, 1)
!        %finish
!        print pages(total pages, -1, 1, 0)
!     %else
!        print sheet %for current page=total pages,-1,1
!     %finish
!ALL
   %end
%end
jump out:
%end %of %program
