{**********************************************************************}
{*                          APMTEL Client                             *}
{*                  Andrew Ness  1988  CS4 project                    *}
{*               Modded version - see mod list below                  *}
{*                                                                    *}
{*                    Version 1.2 20 Jun 1988                         *}
{**********************************************************************}

! Control sub-module
!
!
!        USER INTERFACE TO THE APMTEL SERVER ON FILESTORE D
!
! History:
!
! 20/2/88      Initial naive unfriendly version written to test SERVER
! 22/2/88      Re-write and re-structure of the code for ease of maintainance
!  3/3/88      Inclusion of REGION untility to allow access to caching mechanism
!  3/3/88      Addition of cache structure access thru insert page to place a
!              file into a cache database 
!              So far this cache is write-only, but I am working on the code to
!              allow reading the cache
!  8/3/88      The cache is now read-write
! 10/5/88      Inclusion of Channel 5 - EUCSD pages
! 16/5/88      cache only indication if server is not running
! 17/5/88      Addition of design module 
! 17/5/88      Addition of termlib control for user interface
!

%option "-low-nons"
%include "APMTEL:ins_pg3.inc"
%include "inc:fs.imp"
%include "inc:fsutil.imp"
%include "inc:util.imp"
%include "inc:vtlib.imp"
%include "files.inc"

%include "level1:graphinc.imp"

%constinteger MaxR=23, MaxC=39,
escape     = 27,
keypad     = 79,
cursors    = 91,

uparrow    = 65,
downarrow  = 66,
rightarrow = 67,
leftarrow  = 68,
home       = 72,

enter      = 77,
pf1        = 80,
pf2        = 81,
pf3        = 82,
pf4        = 83,
padcomma   = 108,
padminus   = 109,
paddot     = 110,
pad0       = 112,   pad1=113, pad7=119, pad8=120, pad9=121,
delete     = 127

%externalroutinespec show comments

%constbyte  default mode = 0, 
            graphics mode = 1, 
            held mode = 2,
            double height mask = 4, 
            separated graphics mask = 8,
            conceal = 16

%constinteger hold graphics = 30,
              release graphics = 31,
              new background   = 29,
              black background = 28,
              double height    = 13,
              normal height    = 12,
              contiguous graphics = 25,
              separated graphics  = 26

%constinteger text = 0,
              graphics = 1,
              sep graphics = 2,
              double text = 3,
              double graphics = 4,
              double sep graphics = 5

%begin

%integer font w, font h

%ownbytearray page(0:31,0:MaxC)= ' '(*)
%ownbytearray dh(0:MaxR), {Set to 1 for rows containing double-height character}
              updR(0:MaxR), {Set 1 whenever the row is written to (for refresh)}
              updC(0:MaxC)  {Set 1 whenever col is written to (for refresh)}
%ownintegerarray virscreen(0:31, 0:MaxC) = 0(*)


%ownintegerarray font store (0 : 5) = 0(*)
%owninteger current font=text

%constinteger  server station = 16_35, { Filestore D station number
               magic number = 16,      { The magic number of the APMTEL server
               my port= 21,            { The local port used
               buf size = 520,         { Maximum size of the ether packet
               true = 1,
               false = 0

%integer      server port,
              n,
              c,
              graphics flag,
              cache only
%byte         comm
%integer      pagestore,       {100 * bytearray    page(0:31,0:39) }
%integer      i,
              j, 
              command, param,
              channel
%string (255) filename

%constinteger title row=0, menu row=2, menu col=40, error row=15,
   comment row=17, prompt row=menu row+8, com row=20,divider col=39
!spaceline is <divider col> spaces and a bar.
%conststring (40) spaceline = "|                                       "

%routine line(%integer row)
   vt at(row,menu col);
   printstring(spaceline);
   vt at(row, menu col)
%end

%routine print at line(%integer row, %string (255) text)
  %string (255) thistext
  %while text -> thistext.(snl).text %cycle
     vt at(row, menu col); printsymbol('|')
     printstring(thistext); spaces(40-length(thistext))
     row=row+1
  %repeat
  vt at(row, menu col); printsymbol('|')
  printstring(text); spaces(40-length(text))
%end

%routine title line(%string (255) text)
  line(title row); printstring(text)
%end

%routine flag error(%string (255) text)
  print at line(error row, text)
%end

%routine flag comment 2(%string (255) text)
  print at line(comment row+1, text)
%end

%routine flag comment(%string (255) text)
  print at line(comment row, text)
%end

%routine show prompt(%string (255) text)
  print at line(prompt row, text)
  vt at(prompt row+1, menu col)
%end

%predicate pending read(%integer port)
%integer bit
   bit=1<<port
   %true %if dtx & bit # 0
   %false
%end


%integerfn get ether(%byte port, %bytearrayname buf(0:*), %integer timeout)
%integer t, bytes
   bytes = 0
   t = cputime
   %cycle
      %if pending read(port) %then bytes = ether read(port,buf(0),BUF SIZE)
   %repeatuntil cputime-t > timeout*1000 %or bytes#0
   %return bytes
%end

%integerfn server handshake(%string (255) command, %integer timeout,
%bytearrayname response(0:*), %integername len)
   %integer t
   ether write(my port,charno(command,1),length(command))
   t = cputime
   %cycle
      %if pending read(my port) %then %c
         len = ether read(my port,response(0),BUF SIZE) %and %result=0
      %result=-1 %if cputime-t > timeout*1000
!!      %result=1 %if testsymbol=' '
   %repeat
%end

%predicate start talking
   %integer rc
   %string (255) command
   %bytearray buffer(0:1279)
   ether close(my port)                   {Make sure local port is closed
   ether open(my port, server station<<8) {Open connection to the SERVER
   command = tostring(magic number)
   rc=server handshake(command, 5, buffer, n); !"Hello server"
!
!If the number of bytes rxd is 0, then the filestore is not up or is busy....
!so tell the user to try again later   
!
   clear frame
   %if rc#0 %start
      flag error("Server not responding - cache only".snl. %c
      "Retry by attempting to force a download (menu option 2)")
!      ether close(my port)
      %false
   %finish
!
!Now, if the remote port number is less than 1, then the server is not running
!on the filestore
!
   server port = buffer(0) - '0'
   %if server port <1 %start
      flag error("Server not running - cache only".snl. %c
      "Retry by attempting to force a download (menu option 2)")
!      ether close(my port)
      %false
   %finish
   flag comment("Hi - APMTEL SERVER Connected")
   ether close(my port)
   ether open(my port, server station << 8 ! server port)
   rc=server handshake("A".current user, 5, buffer, n)
   cache only = false
   %true
%end


%bytefn to upper(%byte c)
%if 'a' <= c <= 'z' %thenreturn c-'a'+'A' %elsereturn c
%end


!Routine to take teletext page/subpage from header and convert to integer.
%integerfn txstoi(%integer packet)
   %constinteger hi=0, lo=1
   %integerfn nib(%integer offset,hilo)
      %integer n
      n = byteinteger(packet+offset)
      %if hilo=hi %then n=n>>4
      %result=n&15
   %end
   %result = %c
   (((((nib(5,lo)*10+nib(0,hi))*10+nib(0,lo))*10+nib(1,hi))*10+%c
   nib(1,lo))*10+nib(2,hi))*10+nib(2,lo)
%end

%integerfn pg(%integer channel, %integer page)
   !Takes page specified as an integer channel plus 
   !page number (we hope as a decimal number, 100<=n<=999) and turns it into
   !a 16-bit integer, top 4 bits channel, bottom 12 page number as BCD.
   %integer h,t,d

   h = page//100
   page = page - h*100
   t = page//10
   d = page - t*10
   channel = channel & 16_0F
   %result=((channel<<4+h)<<4+t)<<4+d
%end

%conststring (255) %array getfail(-1:4) = %c
   {-1}"Server <-> Teletext receiver timeout",
   {0} "OK",
   {1} "Request cancelled",
   {2} "Server died while transmitting on ether",
   {3} "Server failed to transmit page to ether",
   {4} "Software error"

%routine move(%integer bytes, %bytename from, to)
   !Move BYTES bytes from FROM to TO. Pinched from IE.
   !If addr(FROM) < addr(TO) do the move from the top down to allow overlap
   %return %if Bytes = 0 %or  From == To

   %if Addr (To) < Addr (From) %start
      *Subq.l #1, d0
   f loop:
      *move.b (a0)+, (a1)+
      *dbra   d0, f loop
   %else
      *add.l  d0, a0
      *add.l  d0, a1
      *subq.l #1, d0
   b loop:
      *move.b -(a0), -(a1)
      *dbra   d0, b loop
   %finish
%end

%ownstring(40) spaces40 = "                                        "

%integerfn get subpage from server(%integer param, to, %integername status)
   %string (255) command
   %bytearray buffer(0:1279), coda(0:511)
   %integer rc,rc2,n,i

   %routine unpack teletext(%bytearrayname buffer, to(0:1279))
      %integer row, p, mag,i
      %bytearray check(0:31)

      !Note:  Rows 26, 28 and 29 are not transmitted.   There may be up to 4
      !row 27s.  I put the first row 27 in row 27 and any others in rows
      !26 then 28 and 29.
      !Unused rows have MAG and ROW set to 0.

      p=0
      %for i=0,1,31 %cycle; check(i)=0; %repeat
      %for i=0,1,MaxR %cycle ;!Max. of 24 42-byte rows in 1024 chars
         mag=buffer(p); row=buffer(p+1)
         %if mag#0 %start
            %if row=27 %start
               !Clumsy
               !does it in received order without dehamming the subrow no.
               row=26 %if check(27)#0
               row=28 %if check(26)#0
               row=29 %if check(28)#0
            %finish
            move(40, buffer(p+2), to(row*40))
            check(row)=1
         %finish
         p=p+42
      %repeat

      !Fill in empty rows - assumed to contain spaces
      %for row=1,1,31 %cycle
         %if check(row)=0 %start
            move(40, charno(spaces40, 1), to(row*40))
         %finish
      %repeat

      to(5) = buffer(0) ;!Save the magazine in an unused header byte
      status = buffer(5)<<8+(buffer(6)&255)
 
   %end

   command = "B".itos(param,-1)
   rc=server handshake(command, 200, buffer, n)
   %if rc=0 %start ;!Success
      %if n=512 %start
         !Expect the 2nd frame fragment
         n= get ether (my port,array(addr(buffer(512))), 6)
         %if n=512 %start
            !Then the status message
            n=get ether(my port,coda,512)
            !Now unpack the frame
            unpack teletext(buffer, array(to))
         %else
            !Server died between sending blocks 1 and 2.
            %result=2
         %finish
      %else
         %result=3
      %finish
   %else
     %if rc>0 %start
!!     rc2=server handshake("E",5,array(to),n)
       !Note possibility for confusion if the cancel crosses the pages
       !coming back.  Sort this later.
     %finish
   %finish
   %result=rc
%end

%integerfn mod10(%integer no); %result = no - (no//10)*10; %end
%integerfn mod100(%integer no); %result = no - (no//100)*100; %end

%constinteger %c
   erase page       = 16_08, {byte 4}
   newsflash        = 16_10, {byte 4}
   subtitle         = 16_20, {byte 4}
   suppress header  = 16_01, {byte 5}
   update indicator = 16_02, {byte 5}
   out of sequence  = 16_04, {byte 5}
   inhibit display  = 16_08, {byte 5}
   serial magazine  = 16_10  {byte 5}

%string (15) %fn statusbits(%integer status)
   !Returns the frame status bits as a string
   %byte c4,c5
   %string (15) s
   c4 = status>>8; c5 = status & 16_FF
   s=""
   s=s."e" %if c4 & erase page # 0
   s=s."n" %if c4 & newsflash # 0
   s=s."s" %if c4 & subtitle # 0
   s=s."h" %if c5 & suppress header # 0
   s=s."u" %if c5 & update indicator # 0
   s=s."o" %if c5 & out of sequence # 0
   s=s."i" %if c5 & inhibit display # 0
   s=s."m" %if c5 & serial magazine # 0
   s=s."?" %if c4 & (\(erase page ! newsflash ! subtitle)) # 0 %or %c
   c5 & (\(suppress header ! update indicator ! out of sequence ! %c
   inhibit display ! serial magazine)) # 0
   s="[".s."]" %unless s=""
   %result=s
%end

%routine strip double (%integer line, %bytearrayname p(0:31,0:39))
   !Remove all the graphics characters in the scope of a double height code
   !We replace the double-graphics control char by itself & 127, and all
   !characters in its scope by itself ! 128.

   !Note we swap the characters onto the bottom of the two lines.  This
   !is because teletext tends to skip the second line, BUT our font requires
   !us to print tall double-height characters from the 2nd of the lines.

   !Note also the statement about double lines:
   !The info sent in row N applies to row N+1. Row N+1 is ignored if sent.
   !It is possible to mix single and double height chars but single height chars
   !can only appear in the top line.
   !From transmitted examples, graphics commands appy to both rows though.

   %integer in double,column
   in double=false
   %for column=0,1,39 %cycle
      %if p(line,column) & 127 =double height %then %start
         in double=true
         p(line,column)=141
         p(line+1,column) = double height
         !Mark the double-height control in the next line as the unmasked one.
      %else
         %if p(line,column) & 127 =normal height %then in double=false
         %if in double=true %start
            p(line+1,column)=p(line,column); p(line,column)=141; 
         %else
            p(line+1,column) = p(line,column) %if p(line,column)&127 <=' '
         %finish
      %finish
   %repeat
%end

%predicate alpha colour(%byte ch)
   %trueif 1<= ch&127 <= 7
   %false
%end

%predicate graphics colour(%byte ch)
   %trueif 17 <= ch&127 <= 23
   %false
%end

%predicate graphics present
   %on 0 %start
      %false
   %finish
   plot(0,0)
   %true
%end

%predicate double trouble (%integer row, %bytearrayname p(0:31,0:39))
   %integer column
   %for column=0,1,MaxC %cycle
      %true %if p(row,column)&127 = double height
   %repeat
   %false
%end

%routine print row (%byte row, %integer col, %bytearrayname page (0:31,0:MaxC))
%byte ch, background colour, last graphics char, mode, display colour
%integer column, temp font
%on 0 %start; %return; %finish

   %routine select font(%integer font no)
      current font = font no
      font(font store(current font))
   %end

   %routine process control(%bytename fch)
      ! set alpha colour
      %byte ch

      ch=fch&127
      %if alpha colour(ch) %start
         %if mode & double height mask # 0 %then select font(double text) %c
         %else select font(text)
         mode = mode & \graphics mode
         display colour = ch
         colour (ch)
         ch = ' '
         last graphics char = ' '

      %elseif graphics colour(ch)
         ! set graphics colour and font
         display colour = ch - 16
         colour(display colour)
         %if mode & held mode # 0 %then ch = last graphics char %else ch=' '

         %if mode & separated graphics mask # 0 %start
            ! select separated graphics
            %if mode & double height mask # 0 %start
               select font(double sep graphics)
            %else
               select font(sep graphics)
            %finish
         %else
            ! select contiguous graphics font
            %if mode & double height mask # 0 %start
               select font(double graphics)
            %else
               select font(graphics)
            %finish
         %finish
         mode = mode! graphics mode

      %elseif ch = contiguous graphics
         mode = mode & \separated graphics mask
         ! change graphics font type to contiguous
         %if mode & double height mask # 0 %start
            select font(double graphics)
         %else
            select font(graphics)
         %finish
         ch = last graphics char

      %elseif ch = separated graphics
         ! change graphics font type to contiguous
         mode = mode! separated graphics mask
         %if mode & double height mask # 0 %start
            select font(double sep graphics)
         %else
            select font(sep graphics)
         %finish
         ch = last graphics char

      %elseif ch = hold graphics
         ! font (graphics font) 
         mode = mode! held mode
         ch = last graphics char

      %elseif ch = release graphics
         mode = mode & \held mode
         ch = last graphics char

      %elseif ch = new background
         background colour = display colour
         ch = last graphics char

      %elseif ch = black background
         background colour = black
         ch = last graphics char

      %elseif ch = double height
         select font(current font+3) %if current font <= 2
         !this is either the double-graphics command or the masked-out characters
         !following it.  
         %if fch=141 %then ch=141 %else ch=last graphics char
         mode = mode! double height mask

      %elseif ch = normal height
         select font(current font-3) %if current font >= 3
         ch = last graphics char
         mode = mode & \double height mask

      %else
         ch = last graphics char
      %finish
      fch=ch
   %end
   
   %routine an show sym(%integer fc)
      %integer desc, char h, c
      c=fc&127
      desc = (((current font<<8)+background colour)<<8+display colour)<<8+fc
      %if desc # virscreen(row,column) %start
         %unless c = 127 %and mode & graphics mode # 1 %start
            char h = font h
            %if fc#141 %start ;  !Not masked-out double height characters
               colour (background colour)
               !Do a big background for double-height fonts.
               %if  current font>2 %then char h=font h<<1 %else char h=font h
               fill(column*font w, 476-row*font h,
               column*font w+(font w-1), 476-row*font h+(char h-1))
               colour(display colour)
            %finish
         %finish

         text at(column*font w, 476-row*font h) %and show symbol(c) %c
         %unless c = ' ' %or c=13
         virscreen(row,column) = desc
      %finish
   %end

   select font(text)
   last graphics char = ' ';
   mode = default mode; display colour = white
   background colour = black
   colour (display colour)
   %for column = 0, 1, MaxC %cycle
      ch = page (row, column)
      %if ch & 16_20#0 %and mode&held mode#0 %then last graphics char=ch&127
      %if ch&127 < 32 %then process control(ch) ;!Leaves ch= ' ' or last graphics char
      an show sym (ch)
   %repeat
%end

%routine print wy row (%byte row, %integer C column, %bytearrayname page(0:31,0:39))
   %byte mode, last graphics char, display colour, background colour
   %integer column, c, current mode
   %constinteger normal=0, underline=8, dim=1
   %bytearray line(0:MaxC)
   %bytename ch

   %routine change mode
      set shade(mode)
      current mode=mode
   %end

   move(MaxC, page(row, 0), line(0))
   vt at(row, 0)
   current mode=normal
   %for column = 0, 1, MaxC %cycle
      ch == line(column)
      %if row=0 %start
         ch=ch&127; ch=32 %if ch<32
         mode=intense
      %elseif ch<32
         ch=32; mode=normal
      %elseif 32<=ch<=127
         mode = normal
      %elseif 129<=ch<=135
         ch=32; mode=normal
      %elseif 156<=ch<=157 ;!New background
         ch=32; mode=normal
         ch[1]=32
      %elseif 128<=ch<=159
         ch=32; mode=intense
      %else
         ch=ch&127
         mode=intense
      %finish
      %if column = C column %start ;!Flip mode over cursor
        %if mode=intense %then mode=normal %else mode=intense
        change mode
        %if mode=normal %then mode=intense %else mode=normal
      %else
        change mode {%if mode # current mode}
      %finish
      printsymbol(ch)
   %repeat
%end

%routine show screen(%integer pg,C row, C column)
   %integer row, column, char pointer, col
   %bytearray page(0:31,0:MaxC)

   %constinteger hi=0, lo=1
   %integerfn nib(%integer offset,hilo)
      %integer n
      n = byteinteger(pg+offset)
      %if hilo=hi %then n=n>>4
      %result=n&15+'0'
   %end ;!of nib

   move(1280, byteinteger(pg), page(0,0))

   page(0,0) = nib(5,lo)
   page(0,1) = nib(0,hi)
   page(0,2) = nib(0,lo)
   page(0,3) = nib(1,hi)
   page(0,4) = nib(1,lo)
   page(0,5) = nib(2,hi)
   page(0,6) = nib(2,lo)
 
   row=0
   %cycle
      %if row=C row %then col = C column %else col = -1
      %if double trouble(row,page) %start
         strip double(row,page)
         print wy row (row,col, page); print row(row,col, page)
         row=row+1
      %finish
      print wy row (row,col, page); print row(row,col, page)
      row=row+1
   %repeatuntil row>=24
%end ;!of show screen

%routine refresh
%end

%integerfn get page from server(%integer page, base, %integername subpages)
   %integer rc, full pageno, f, firstf, maxsub, i, latestf, to, status
   firstf=-1; f=0; subpages=-1; maxsub=-1

   !Once the subpages have wrapped round, we know we have a complete page
   !and how big it is.
   subpages=0
   %cycle
      to = base + f * 1280
      rc=get subpage from server(page, to, status)
      %result=rc %if rc#0
      full pageno = txstoi(to)
      refresh
      latestf=f;  f = mod100(full pageno) ;!the subpage number

      %if firstf<0 %start;!start point in subpage cycle
         firstf=f 
         !Page is in subpage-0 slot.  Copy the page to the correct place
         move(1280,byteinteger(to), byteinteger(base+(f-1)*1280)) %if f>1
      %finish

      %if f=0 %start; !Only subpage
         flag comment("   Page ".itos(full pageno,-1)." ".status bits(status))
         subpages=1
         %result=0
      %elseif f=latestf ;!subpages are looping
         flag comment("Subpage ".itos(full pageno,-1)." looping")
         subpages=1
         %result=0
      %else
         flag comment("Subpage ".itos(full pageno,-1)." ".status bits(status)." arrived") 
      %finish

      %if f<latestf %start
         !We've turned the corner: Maxsub is the top subpage number.
         maxsub=latestf
         move(1280, byteinteger(to), byteinteger(base + (f-1)*1280))
         %if firstf=1 %then subpages=maxsub %and %result=0
         !special case where firstf=1: we've just wrapped round
      %finish

      %if f+1=firstf %then subpages=maxsub %and %result=0
      !about to complete the cycle
   %repeat
   %result=4
%end

%routine browse(%integer base, lo, hi)
   %integer c, offset, minbase, maxbase
   %routine r; %cycle; c=testsymbol; %repeatuntil c>=0; %end
   flag comment("Use up and down arrows to scan page.".snl. %c
   "Press <return> to exit")
   minbase=lo*1280; maxbase=hi*1280
   offset=minbase
   %cycle; %repeatuntil testsymbol<0
   %cycle
      show screen(base+offset,-1,-1)
      %cycle
         r
         %if c=escape %start
            r
            %if c=cursors %start
               r
               %if c=uparrow %start ;!Up
                  %if offset>minbase %then offset=offset-1280 %else offset=maxbase
               %elseif c=downarrow ;!Down
                  %if offset<maxbase %then offset=offset+1280 %else offset=minbase
               %finish
               %exit
            %finish
         %elseif c=10
            %exit
         %finish
      %repeat
      %exit %if c=10
   %repeat
%end

%routine carousel(%integer page)
   %integer rc, full pageno, f, firstf, subpages, maxsub, i
   flag comment("Press a key to exit".snl. %c
   "This may take some time so be patient")

   %cycle; %repeatuntil testsymbol=-1
   %cycle
      %exit %if testsymbol>=0
      rc=get page from server(page, pagestore, subpages)
      %if rc=0 %and subpages#0 %start
!!         %if subpages>1 %start
!!            show prompt("browse?")
!!            %cycle
!!              f=testsymbol
!!              f='N' %if f=13 %or f=10 %or f='n'
!!              f='Y' %if f='y'
!!            %repeatuntil f='Y' %or f='N'
!!            %if f='Y' %start
!!               browse(pagestore, 0, subpages-1)
!!            %finish
      %else
         flag error("Page request failed - ".getfail(rc).snl. %c
         "Press <space> to continue")
         %cycle; %repeatuntil testsymbol=' '
      %finish
   %repeat
%end

%owninteger subpages=0

%routine design

%integer font w, font h,
         m x, m y,
         char x, char y,
         old m x, old m y

%constinteger  cursor plane = 8,  rest = 7,
               TRUE = 1, FALSE = 0
   
%routine printline(%string (255) s)
   printstring(s); newline
%end ;!of printline in design

%routine setup screens
  set frame(0,24,0,80)
  clear frame
  %if graphics flag = true %start
    clear
    Offset (0,0)
    enable(rest)
  %finish
  set terminal mode(no page)
%end ;!of setup screens in design

! draw cursor:      draw a box round the character box containing (x,y)
!                   i.e. snap the cursor onto the character grid
%routine draw cursor(%integer x,y,h)
  %on 0 %start; %return; %finish
  x = (x // font w) * font w
!!  y = (y // font h+1) * font h+ font h//2+1
  y = (y // font h+1) * font h
  enable(cursor plane)
  colour(32767)
  hline (x,x+font w,y)
  hline (x,x+font w,y+font h*h)
  vline (x,y,y+font h*h)
  vline (x+font w,y,y+font h*h)
  enable(rest)
%end ;!of - in design

! undraw cursor:     erases the cursor from the screen
%routine undraw cursor(%integer x,y,h)
  %on 0 %start; %return; %finish
  x = (x // font w) * font w
!!  y = (y // font h+1)* font h+ font h//2+1
  y = (y // font h+1) * font h
  enable(cursor plane)
  colour(0)
  hline(x,x+font w,y)
  hline(x,x+font w,y+font h*h)
  vline(x,y,y+font h*h)
  vline(x+font w,y,y+font h*h)
  enable(rest)
%end ;!of - in design

%integerfn get m position
!
! Repeats a loop polling the m position until a button is pressed
!
%integer temp buttons, x off, y off, t
   set frame(15,5,0,40)
   clear frame
   print string("PLEASE SELECT MENU OPTION :-")
   %cycle
      x off = rel mouse x
      y off = rel mouse y
      m x = m x + x off 
      m y = m y + y off 
      %if mx > 39 * fontw %then mx = 39*fontw %elseif mx < 0 %then mx = 0
      %if my > 23 * fonth %then my = 23*fonth %elseif my < 0 %then my = 0
      %if m x # old m x %or m y#old m y %start
         undraw cursor(old m x, old m y,0)
         old m x = m x; old m y=m y
         draw cursor(old m x, old m y,0)
         char x = m x // font w 
         char y = m y // font h 
         !write(23-char y,5);write(char x,5);newline
      %finish
      temp buttons = test symbol - '0'
   %repeatuntil 1<=temp buttons <= 8
   newline
   %return temp buttons
%end ;!of - in design

! setup designer:    intialise the variables and framestore for use by the
!                    designer
%routine setup designer
   setup screens
   m x = 320
   m y = 256
   old m x = 0 ; old m y = 0
   font w = max font width
   font h = font height
%end ;!of - in design


%routine load file(%string (255) name,%bytearrayname p(0:31,0:39))
%label abort
%integer i,j,t
   %on 0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15 %start
       printline("Sorry cannot load ".name." because ".event_message)
       ->abort
   %finish
   open input(1,name)
   select input(1)
   %for i=0,1,23 %cycle
      %for j=0,1,39 %cycle
         read symbol(t)
         p(i,j) = t                              {NEEDED FOR VTLIB
      %repeat
   %repeat
abort:
   close input
   select input(0)
%end ;!of - in design

%routine save file(%string (255) name)
%label abort
%integer i,j
    %on 0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15 %start
       printline("Sorry cannot do that because ".event_message)
       -> abort
    %finish
    open output(1,name)
    select output(1)
    %for i=0,1,MaxR %cycle
       %for j=0,1,MaxC %cycle
       printsymbol(page(i,j))
       %repeat
    %repeat
abort:
    close output
    select output(0)
%end ;!of - in design

%integerfn pg(%integer channel, %integer page)
   !Takes page specified as an integer channel plus 
   !page number (we hope as a decimal number, 100<=n<=999) and turns it into
   !a 16-bit integer, top 4 bits channel, bottom 12 page number as BCD.

   %result=(page&16_FFF) ! (channel&16_0F)<<12
%end ;!of - in design

%routine save to db(%integer location, %string(255) comments)
   %integer page id
   page id = pg(5, location)
   !Forget comments   
   write cached page(page id, addr(page(0,0)), 1)
%end ;!of - in design

%routine load from db(%integer channel, location)
   %integer page id, subpages
   page id = pg(channel, location)
   read cached page(page id, addr(page(0,0)), subpages)
   %if subpages#0 %start
      show screen(addr(page(0,0)),-1,-1)
   %else
      printline("Page not present")
   %finish
%end ;!of - in design

%routine do design
  %constinteger norm=0
  %integer i,j,mode,control,channel,row,column,c,finished
  %string (255) line
  %bytearray dh(0:MaxR)

%routine reflag(%integer row, column)
  ! Flag the row and column has been updated and requires refresh
  updR(row) = updR(row)+1
  updC(column) = updC(column)+1
%end

%routine zap cursor
  %integer h
  reflag(row, column)
  %if dh(row)=0 %then h=1 %else h=2
  undraw cursor(column*font w, (23-row)*font h,h)
%end ;!of - in do design in design

%routine paint cursor
  %integer h
  reflag(row, column)
  %if dh(row)=0 %then h=1 %else h=2
  draw cursor(column*font w, (23-row)*font h,h)
%end ;!of - in do design in design

%integerfn succR(%integer row)
  !Return the number of the next valid row.  This looks after wraparound
  !and blocks access to the lower row of a double-height row
  %if row#MaxR %and dh(row)#0 %start
    row=row+1; row=0 %if row>MaxR
  %finish
  row=row+1; row=0 %if row>MaxR
  %result=row
%end

%integerfn predR(%integer row)
  !Return the number of the previous valid row.  This looks after wraparound
  !and blocks access to the lower row of a double-height row
  row=row-1; row=MaxR %if row<0
  %if row#0 %and dh(row-1)#0 %start
    row=row-1; row=MaxR %if row<0
  %finish
  %result=row
%end

%routine C right
  zap cursor
  column = column + 1
  %if column > MaxC %start { Wrapround
    column = 0 ; row = succR(row)
  %finish
  paint cursor
%end ;!of - in do design in design

%routine C down
  zap cursor
  row = succR(row)
  paint cursor
%end ;!of - in do design in design

%routine C up
  zap cursor
  row = predR(row)
  paint cursor
%end ;!of - in do design in design

%routine C left
  zap cursor
  column = column - 1
  %if column < 0 %start { Wrapround
    column = MaxC ; row = predR(row)
  %finish
  paint cursor
%end ;!of - in do design in design

%routine zap line(%integer row)
  %integer column
  %for column=0,1,MaxC %cycle; page(row,column) = ' '; reflag(row, column); %repeat
  dh(row)=0
%end

%routine C home
  zap cursor
  row=0; column=0
  paint cursor
%end ;!of - in do design in design

%routine get(%integername c)
   %cycle; c=testsymbol; %repeatuntil c>=0
%end

  %routine add(%byte c)
    %constinteger normal=0
    zap cursor
    %if page(row, column)&127 = double height %start
      %if c&127#double height %then dh(row) = dh(row) - 1
    %else
      %if c&127=double height %then dh(row) = dh(row) + 1
    %finish
    page(row, column) = c
    reflag(row, column)
!t  flag comment("add ".itos(page(row,column),-1)." ".itos(row,-1)." ".itos(column,-1))
    C right
 %end ;!of add in do design in design

%constintegerarray f(1:12) = 0,31,59,90,120,151,181,212,243,273,304,334
%conststring (3) %array dy(0:6) = "Mon", "Tue", "Wed","Thu", "Fri", "Sat", "Sun"

%string (9) %fn weekday(%string (*) %name date)
   !Returns the day of week of the supplied date. Works for all dates in the
   !format dd/mm/yy, yy assumed to be between 1900 and 1999.
   !White space on front of date is ignored and so is garbage after the date bit.
   %integer day, month, year, i
   i = 1
   i = i + 1 %while charno(date, i) < '0' ;!Skip past leading junk
   !Split date up into day, month, year
   day = stoi(substring(date, i, i+1))
   month = stoi(substring(date, i+3, i+4))
   year = stoi(substring(date, i+6, i+7))
   day = f(month) + day ;!Past months this year + days this month
   day = day + 1 %if year & 3 = 0 %and year # 0 %and month > 2 ;!Leap year correction
   !Complete past years + correction for day-of-week of 1/1/00
   day = day + year * 365 + 6
   day = day + (year-1)>>2 %if year # 0 ;!past leap years
   %result = dy(day - (day//7)*7)
%end

%routine form header(%bytearrayname pg(0:31, 0:MaxC), %integer pageno)
  %integer t
  %string (255) d
  %routine p(%byte val);     pg(0,t) = val; t=t+1;   %end
  %routine ps(%string (63) s)
    %integer i
    %for i=1,1,length(s) %cycle; p(charno(s,i)); %repeat
  %end
  t=0
  d = date
  p(mod100(pageno)//10<<4+mod10(pageno)); p(0); p(0); p(0); p(0); p(pageno//100)
  ps("  EU.CSD ".itos(pageno,3)."  ".weekday(d)." ".d."  ".time)
%end

! Do Design - Main code

%for row=0, 1, MaxR %cycle; zap line(row); %repeat
row=0; column=0
finished = false
form header(page, 500)
show screen(addr(page(0,0)),0,0)
C home
%cycle
  get(c)
  %if c = escape %start
    get(c)
    %if c=cursors %start
      get(c)
      %if c = uparrow %start
        C up

      %elseif c = downarrow
        C down

      %elseif c = leftarrow
        C left

      %elseif c = rightarrow
        C right

      %elseif c = home
        C home

      %finish
      refresh

    %elseif c=keypad
      get(c)
      %if pad1<=c<=pad7 %start
        add(c-pad0+128)
        mode=norm
        flag comment2(itos(c,3).itos(page(row,column), 3))

      %elseif c=pad8
        add(128+normal height)
      %elseif c=pad9 %and row#MaxR %and dh(row+1)=0
        zap line(row+1)
        add(128+double height)
      %elseif c=pad0
        get(c)
        %if c=escape %start
          get(c)
          %if c=keypad %start
            get(c)
            %if pad1<=c<=pad7 %start
              add(c-pad0+144)
            %elseif c=pad8
              add(128+black background)
            %elseif c=pad9
              add(128+new background)
            %finish
          %finish
        %finish
        refresh

      %elseif c=pf1
        show prompt("LOAD file:")
        read line(line)
        %if line#"" %then load file(line,page)

      %elseif c=pf2
        show prompt("SAVE file:")
        read line(line)
        save file(line)

      %elseif c=pf3
        show prompt("LOAD channel:")
        read(channel)
        show prompt("LOAD page id:")
        read(control)
        load from db(channel, control)

      %elseif c=pf4
        show prompt("SAVE id:")
        read(control)
        show prompt("Comment line:")
        read line(line)
        line = current user." <-> ".line
        save to db(control, line)

      %elseif c=padcomma
        zap line(row)
        refresh

      %elseif c=padminus
        %for i=0,1,MaxR %cycle
          zap line(i)
        %repeat
        refresh

      %elseif c=enter
        finished = true
      %finish
    %finish
  %elseif c=delete
    C left
    add(' ')
    C left
    refresh
  %else
    add(c)
    refresh
  %finish
  %repeatuntil finished = true
  clear frame
%end ;!of do design in design

%routine show menu
   print at line(0, " 1:alpha red         2:alpha green")
   print at line(1, " 3:alpha yellow      4:alpha blue")
   print at line(2, " 5:alpha magenta     6:alpha cyan")
   ! 1-7 alpha colours: red,green,yellow,blue,magenta,cyan,white
   ! 8: flash, 9: steady, 10,11: unused
   ! 12: normal height, 13: double height
   ! 14,15,16: unused
   ! 17-23 graphic colours: red,green,yellow,blue,magenta,cyan,white
   ! 24: conceal
   ! 25: contig graphics, 26: sep graphics
   ! 27: unused
   ! 28:black background 29:new background
   ! 30:hold graphics    31:release graphics
   print at line(3, " 7:alpha white       8:normal height")
   print at line(4, " 9:double height    01:graphic red")
   print at line(5, "02:graphic green    03:graphic yellow")
   print at line(6, "04:graphic blue     05:graphic magenta")
   print at line(7, "06:graphic cyan     07:graphic white")
   print at line(8, "08:black background 09:new background")
   print at line(9, "25:contig graphics  26:sep graphic")
   print at line(10, "30:hold graphics    31:release graphics|")
   print at line(11, "")
   print at line(12, "CONTROL CODES")
   print at line(13, "pf2: Save page to file")
   print at line(14, "pf1: Load page from file")
   print at line(15, "pf4: Save page to db")
   print at line(16, "pf3: Load page from db")
   print at line(17, " - : Clear page")
   print at line(18, " , : Clear line")
   print at line(19, "enter: quit")
   print at line(20, "")
   print at line(21, "")
   print at line(22, "")
   print at line(23, "")
%end ;!of - in design

!%integer i
   set video mode(specialpad)            { To initialise the TERMLIB stuff
   setup designer
   show menu
!!%cycle
!i=testsymbol; %if i>=0 %start; write(i, 3); newline; %finish; %repeat
   do design
%end ;!of design

%externalroutine an clear
   %integer i,j
   %for i=0,1,31 %cycle; %for j=0,1,39 %cycle; virscreen(i,j)=0; %repeat; %repeat
   clear
%end

%routine act on (%integer comm, param)
   %switch entry('B':'H')
   %bytearray buffer(0:1279)
   %half page
   %integer rc, page id
   -> entry(comm)

entry('B'):  !Read a page from cache if available then broadcast if not
    page id = pg(channel, param)
    open cache(database file)
    read cached page(page id, pagestore, subpages)
    close cache
    %if channel = 5 %start
       flag error("Page not available") %if subpages=0
    %else
       %if subpages=0 %start
          flag error("Page not available")
       %elseif subpages=1
          show screen(pagestore,-1,-1)
       %else
          browse(pagestore, 0, subpages-1)
       %finish
    %finish
    %return

entry('C'):   !Change channel
    channel = param
    rc=server handshake(tostring(command).itos(channel,-1), 60, buffer, n)
    %return

entry('D'):   !Quit
   %if cache only # true %start
      rc=server handshake(tostring(command), 1, buffer, n)
      ether close(my port)
   %finish
   clear frame
   %return

entry('E'):  !Force a page request from server
   page id = pg(channel, param)
   open cache(database file)
   read cached page(page id, pagestore, subpages)
   close cache
   flag comment("Page from cache") %and showscreen(pagestore,-1,-1) %if subpages#0
   %if channel = 5 %start
      flag error("Cannot force a download on channel 5")
   %else
      %if cache only = true %start
          flag error("Trying to reconnect to server")
          %if start talking %start
             flag comment("OK.") 
             cache only = false
          %finish
      %finish

      %if cache only = false %start
          open cache(database file)
          rc=get page from server(param, pagestore, subpages)
          %if rc=0 %start
             %if subpages>1 %then browse(pagestore, 0, subpages-1)
             page id = pg(channel, param)
             flag comment 2("Caching page".snl."")
             write cached page(page id, pagestore, subpages)
          %else
             flag error("Page request failed - ".getfail(rc).snl. %c
             "Press <space> to continue")
             %cycle; %repeatuntil testsymbol=' '
          %finish
          close cache
      %else
          flag error("Cannot force page - server not responding")
      %finish
   %finish
   %return

entry('F'):
   show prompt("SAVE file name:");
   %cycle
      vt at(prompt row+1,menu col)
      read line(filename)
   %repeatuntil filename#""
   open output(1,filename)
   select output(1)
   %for i=0,1,32*40*subpages-1 %cycle
      print symbol(byteinteger(pagestore+i))
   %repeat
   close output
   select output(0)
   %return
   
entry('G'):
      open cache(database file)
      design
      close cache
      an clear
   %return

entry('H'):
   %if channel = 5 %start
      flag error("Cannot carousel on channel 5")
   %else
      open cache(database file)
      carousel(param)
      close cache
   %finish
%end


%routine get command(%integername comm, param)
   !Show menu, get and validate command.
   %ownbytearray table('1':'7') = 'B','E','C','F','H','G','D'
   %integer c
   %on 10 %start
      !Bad integer typed in.
      flag error("Bad integer supplied".snl.%c
      "Press space to continue")
      %cycle; %repeatuntil testsymbol=' '
   %finish

   clear frame %if graphics flag#0
   set shade(reverse+intense+blink+underline)
   title line("APMTEL on channel ".itos(channel,-1).":")
   set shade(0)
   line(1)
   print at line(menu row, %c
   "1:Get page".snl. %c
   "2:Force get".snl. %c
   "3:Channel".snl. %c
   "4:Save to file".snl. %c
   "5:Carousel page".snl. %c
   "6:Design page".snl. %c
   "7:QUIT".snl)
   !The explicitly written rows will put a | in rows 0-10.
   %if graphics flag=0 %start
      %for c=11,1,23 %cycle; vt at(c, divider col); printsymbol('|'); %repeat
   %finish
   flag error("".snl.""); flag comment("".snl."")
   show prompt("?:")
   %cycle
      c = test symbol
   %repeatuntil '1' <= c <= '7'

   comm = table(c); param=0
   %if comm='B' %or comm='H' %or comm='E' %start 
      ! 'B': Get page, 'E': Force get from broadcast, 'H': Carousel
      show prompt("Page:") 
      %cycle
         read(param)
         %exit %if 100<=param<=999
         flag error("Valid pages 100-999 only")
         vt at(prompt row+1,menu col)
      %repeat
   
   %elseif comm='C'
      !Select channel
      show prompt("Channel:") 
      %cycle
         read(param)
         %exit %if 1<=param<=5
         flag error("Valid channels 1 (BBC1), 2(BBC2), 3(STV), 4(Channel 4), 5(EUCSD) only")
         vt at(prompt row+1, menu col)
      %repeatuntil 1<=param<=5
   %elseif comm='D'
      !Quit
   %finish
   vt at(comment row,menu col)
{}write(c, 3); printsymbol(comm); newline
%end

%predicate flagset(%integer c)
  %integer i
  %false %if cli param=""
  %for i=1,1,length(cli param) %cycle
     %true %if charno(cli param,i) & 16_5F = c&16_5F
  %repeat
  %false
%end

%externalroutine load fonts
   readfont("apmtel:TFONT0.BFT",   font store (text))
   readfont("apmtel:TFONT1.BFT",   font store (graphics))
   readfont("apmtel:TFONT2.BFT",   font store (sep graphics))
   readfont("apmtel:TFONT0DH.BFT", font store (double text))
   readfont("apmtel:TFONT1DH.BFT", font store (double graphics))
   readfont("apmtel:TFONT2DH.BFT", font store (double sep graphics))
   font(font store(text))
   font w = max font width
   font h = font height
%end

   %if flagset('v') %then graphics flag=0 %elsestart
      %if graphics present %then graphics flag=1 %else graphics flag=0
   %finish
   pagestore = heapget(100*1280)
   set video mode(specialpad)
   clear frame
   channel = 1
   %if flagset('l') %then cache only = true %elsestart
      %if start talking %then cache only = false %else cache only = true
   %finish
   %if graphics flag#0 %start
      an clear
      flag comment("Loading fonts ")
      load fonts                 { Load the teletext fonts up
   %finish

   %cycle
      get command(command, param)       { Get a menu choice .....
      act on(command, param)
   %repeatuntil command='D'
  
   %if cache only # true %then etherclose (myport)
   heapput(pagestore)
%endofprogram